File: d_odr.f

package info (click to toggle)
python-scipy 0.18.1-2
links: PTS, VCS
area: main
in suites: stretch
size: 75,464 kB
ctags: 79,406
sloc: python: 143,495; cpp: 89,357; fortran: 81,650; ansic: 79,778; makefile: 364; sh: 265
file content (10985 lines) | stat: -rw-r--r-- 367,867 bytes
parent folder | download | duplicates (7)
*DODR
      SUBROUTINE DODR
     +   (FCN,
     +   N,M,NP,NQ,
     +   BETA,
     +   Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   JOB,
     +   IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODR
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             MEASUREMENT ERROR MODELS,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           ROGERS, JANET E.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 
C            SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT)
C***DESCRIPTION
C   FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE.
C***REFERENCES  BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND
C                 R. B. SCHNABEL (1989),
C                 "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED 
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 ACM TRANS. MATH. SOFTWARE., 15(4):348-364. 
C               BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND
C                 R. B. SCHNABEL (1992),
C                 "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01,
C                 SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION,"
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 
C                 INTERNAL REPORT NUMBER 92-4834.
C               BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987),
C                 "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078.
C***ROUTINES CALLED  DODCNT
C***END PROLOGUE  DODR

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK,
     +   M,N,NDIGIT,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   NEGONE,PARTOL,SSTOL,TAUFAC,ZERO
      INTEGER
     +   IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT
      LOGICAL
     +   SHORT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1)
      INTEGER
     +   IFIXB(1),IFIXX(1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODCNT

C...DATA STATEMENTS
      DATA
     +   NEGONE,ZERO
     +   /-1.0D0,0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NEGONE:  THE VALUE -1.0D0.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   WD:      THE DELTA WEIGHTS.
C   WD1:     A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODR


C  INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES

      IFIXB(1) = -1
      IFIXX(1,1) = -1
      LDIFX = 1
      NDIGIT = -1
      TAUFAC = NEGONE
      SSTOL = NEGONE
      PARTOL = NEGONE
      MAXIT = -1
      STPB(1) = NEGONE
      STPD(1,1) = NEGONE
      LDSTPD = 1
      SCLB(1) = NEGONE
      SCLD(1,1) = NEGONE
      LDSCLD = 1

      SHORT = .TRUE.

      IF (WD(1,1,1).NE.ZERO) THEN
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO) 
      ELSE
         WD1(1,1,1) = NEGONE
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO) 
      END IF

      RETURN

      END
*DODRC
      SUBROUTINE DODRC
     +   (FCN,
     +   N,M,NP,NQ,
     +   BETA,
     +   Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC,
     +   SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD,
     +   SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODRC
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             MEASUREMENT ERROR MODELS,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           ROGERS, JANET E.
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION
C             NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C             BOULDER, CO 80303-3328
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING 
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE  
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST  
C            SQUARES (OLS) SOLUTION (LONG CALL STATEMENT)
C***DESCRIPTION
C   FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE.
C***REFERENCES  BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND
C                 R. B. SCHNABEL (1989),
C                 "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 ACM TRANS. MATH. SOFTWARE., 15(4):348-364.
C               BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND
C                 R. B. SCHNABEL (1992),
C                 "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01,
C                 SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION,"
C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
C                 INTERNAL REPORT NUMBER 92-4834.
C               BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987),
C                 "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078.
C***ROUTINES CALLED  DODCNT
C***END PROLOGUE  DODRC

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   NEGONE,ZERO
      LOGICAL
     +   SHORT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   WD1(1,1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODCNT

C...DATA STATEMENTS
      DATA
     +   NEGONE,ZERO
     +   /-1.0D0,0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   WD:      THE DELTA WEIGHTS.
C   WD1:     A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODRC


      SHORT = .FALSE.

      IF (WD(1,1,1).NE.ZERO) THEN
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO)
      ELSE
         WD1(1,1,1) = NEGONE
         CALL DODCNT
     +        (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        INFO)
      END IF

      RETURN

      END
*DACCES
      SUBROUTINE DACCES
     +   (N,M,NP,NQ,LDWE,LD2WE,
     +   WORK,LWORK,IWORK,LIWORK,
     +   ACCESS,ISODR,
     +   JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +   NNZW,NPP,
     +   JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +   LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +   WSS,RVAR,IDF,
     +   TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +   RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)
C***BEGIN PROLOGUE  DACCES
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  ACCESS OR STORE VALUES IN THE WORK ARRAYS
C***END PROLOGUE  DACESS

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND,
     +   RNORMS,RVAR,SSTOL,TAU,TAUFAC
      INTEGER
     +   IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT,
     +   LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV,
     +   NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK6
      LOGICAL
     +   ACCESS,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   WORK(LWORK),WSS(3)
      INTEGER
     +   IWORK(LIWORK)

C...LOCAL SCALARS
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,
     +   DELTAI,DELTNI,DELTSI,DIFFI,EPSI,
     +   EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT,
     +   IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI,
     +   MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI,
     +   NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,
     +   VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DIWINF,DWINF

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACCESS:  THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 
C            ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN
C            THEM (ACCESS=FALSE).
C   ACTRS:   THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   EPSI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS.
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IDFI:    THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   INT2:    THE NUMBER OF INTERNAL DOUBLING STEPS.
C   INT2I:   THE LOCATION IN ARRAY IWORK OF VARIABLE INT2.
C   IPR1:    THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE INITIAL SUMMARY REPORT.
C   IPR2:    THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE ITERATION REPORTS.
C   IPR2F:   THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
C   IPR3:    THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FINAL SUMMARY REPORT.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE 
C            FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   JPVT:    THE PIVOT VECTOR.
C   JPVTI:   THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT.
C   LDTTI:   THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE. 
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE. 
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGB:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGD:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITER:   THE NUMBER OF ITERATIONS TAKEN.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE NITER.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.
C   OLMAVG:  THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 
C            ITERATION.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGA:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERS:   THE SAVED PREDICTED RELATIVE REDUCTION IN THE 
C            SUM-OF-SQUARES.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   QRAUX:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCOND.
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORMS:  THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS.
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVAR:    THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SCLB:    THE SCALING VALUES USED FOR BETA.
C   SCLD:    THE SCALING VALUES USED FOR DELTA.
C   SD:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-
C            CALL (SHORT=FALSE).
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   U:       THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCV:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WRK1:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSS:     THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS.
C   WSSI:    THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1).
C   WSSDEI:  THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2).
C   WSSEPI:  THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3).
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.


C***FIRST EXECUTABLE STATEMENT  DACCES


C  FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE

      CALL DIWINF(M,NP,NQ,
     +            MSGB,MSGD,JPVTI,ISTOPI,
     +            NNZWI,NPPI,IDFI,
     +            JOBI,IPRINI,LUNERI,LUNRPI,
     +            NROWI,NTOLI,NETAI,
     +            MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +            LIWKMN)

C  FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE

      CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +           DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
     +           RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +           OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +           PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +           BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +           FSI,FJACBI,WE1I,DIFFI,
     +           DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +           WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +           LWKMN)

      IF (ACCESS) THEN

C  SET STARTING LOCATIONS FOR WORK VECTORS

         JPVT   = JPVTI
         OMEGA  = OMEGAI
         QRAUX  = QRAUXI
         SD     = SDI
         VCV    = VCVI
         U      = UI
         WRK1   = WRK1I
         WRK2   = WRK2I
         WRK3   = WRK3I
         WRK4   = WRK4I
         WRK5   = WRK5I
         WRK6   = WRK6I

C  ACCESS VALUES FROM THE WORK VECTORS

         ACTRS  = WORK(ACTRSI)
         ALPHA  = WORK(ALPHAI)
         ETA    = WORK(ETAI)
         OLMAVG = WORK(OLMAVI)
         PARTOL = WORK(PARTLI)
         PNORM  = WORK(PNORMI)
         PRERS  = WORK(PRERSI)
         RCOND  = WORK(RCONDI)
         WSS(1) = WORK(WSSI)
         WSS(2) = WORK(WSSDEI)
         WSS(3) = WORK(WSSEPI)
         RVAR   = WORK(RVARI)
         RNORMS = WORK(RNORSI)
         SSTOL  = WORK(SSTOLI)
         TAU    = WORK(TAUI)
         TAUFAC = WORK(TAUFCI)
   
         NETA   = IWORK(NETAI)
         IRANK  = IWORK(IRANKI)
         JOB    = IWORK(JOBI)
         LUNRPT = IWORK(LUNRPI)
         MAXIT  = IWORK(MAXITI)
         NFEV   = IWORK(NFEVI)
         NITER  = IWORK(NITERI)
         NJEV   = IWORK(NJEVI)
         NNZW   = IWORK(NNZWI)
         NPP    = IWORK(NPPI)
         IDF    = IWORK(IDFI)
         INT2   = IWORK(INT2I)
       
C  SET UP PRINT CONTROL VARIABLES
 
         IPRINT = IWORK(IPRINI)
   
         IPR1   = MOD(IPRINT,10000)/1000
         IPR2   = MOD(IPRINT,1000)/100
         IPR2F  = MOD(IPRINT,100)/10
         IPR3   = MOD(IPRINT,10)
    
      ELSE

C  STORE VALUES INTO THE WORK VECTORS

         WORK(ACTRSI)  = ACTRS   
         WORK(ALPHAI)  = ALPHA   
         WORK(OLMAVI)  = OLMAVG  
         WORK(PARTLI)  = PARTOL  
         WORK(PNORMI)  = PNORM   
         WORK(PRERSI)  = PRERS   
         WORK(RCONDI)  = RCOND   
         WORK(WSSI)    = WSS(1)
         WORK(WSSDEI)  = WSS(2)
         WORK(WSSEPI)  = WSS(3)
         WORK(RVARI)   = RVAR
         WORK(RNORSI)  = RNORMS  
         WORK(SSTOLI)  = SSTOL   
         WORK(TAUI)    = TAU     

         IWORK(IRANKI) = IRANK   
         IWORK(ISTOPI) = ISTOP   
         IWORK(NFEVI)  = NFEV    
         IWORK(NITERI) = NITER   
         IWORK(NJEVI)  = NJEV    
         IWORK(IDFI)   = IDF    
         IWORK(INT2I)  = INT2    
      END IF

      RETURN
      END
*DESUBI
      SUBROUTINE DESUBI
     +   (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E)
C***BEGIN PROLOGUE  DESUBI
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE E = WD + ALPHA*TT**2
C***END PROLOGUE  DESUBI

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA
      INTEGER
     +   LDTT,LDWD,LD2WD,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J,J1,J2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHA:  THE LEVENBERG-MARQUARDT PARAMETER.
C   E:      THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2
C   I:      AN INDEXING VARIABLE.
C   J:      AN INDEXING VARIABLE.
C   J1:     AN INDEXING VARIABLE.
C   J2:     AN INDEXING VARIABLE.
C   LDWD:   THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:  THE SECOND DIMENSION OF ARRAY WD.
C   M:      THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:      THE NUMBER OF OBSERVATIONS.
C   NP:     THE NUMBER OF RESPONSES PER OBSERVATION.
C   TT:     THE SCALING VALUES USED FOR DELTA.
C   WD:     THE SQUARED DELTA WEIGHTS, D**2.
C   ZERO:   THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DESUBI


C   N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE
C        OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS
C        OF THE MULTIPLY SUBSCRIPTED ARRAYS.

      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (WD(1,1,1).GE.ZERO) THEN
         IF (LDWD.GE.N) THEN
C  THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED

            IF (LD2WD.EQ.1) THEN
C  THE ARRAYS STORED IN WD ARE DIAGONAL
               CALL DZERO(M,M,E,M)
               DO 10 J=1,M
                  E(J,J) = WD(I,1,J)
   10          CONTINUE
            ELSE
C  THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES
               DO 30 J1=1,M
                  DO 20 J2=1,M
                     E(J1,J2) = WD(I,J1,J2)
   20             CONTINUE
   30          CONTINUE
            END IF

            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  DO 110 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(I,J)**2
  110             CONTINUE
               ELSE
                  DO 120 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(1,J)**2
  120             CONTINUE
               END IF
            ELSE
               DO 130 J=1,M
                  E(J,J) = E(J,J) + ALPHA*TT(1,1)**2
  130          CONTINUE
            END IF
         ELSE
C  WD IS AN M BY M MATRIX

            IF (LD2WD.EQ.1) THEN
C  THE ARRAY STORED IN WD IS DIAGONAL
               CALL DZERO(M,M,E,M)
               DO 140 J=1,M
                  E(J,J) = WD(1,1,J)
  140          CONTINUE
            ELSE
C  THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES
               DO 160 J1=1,M
                  DO 150 J2=1,M
                     E(J1,J2) = WD(1,J1,J2)
  150             CONTINUE
  160          CONTINUE
            END IF

            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  DO 210 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(I,J)**2
  210             CONTINUE
               ELSE
                  DO 220 J=1,M
                     E(J,J) = E(J,J) + ALPHA*TT(1,J)**2
  220             CONTINUE
               END IF
            ELSE
               DO 230 J=1,M
                  E(J,J) = E(J,J) + ALPHA*TT(1,1)**2
  230          CONTINUE
            END IF
         END IF
      ELSE
C  WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1))
         CALL DZERO(M,M,E,M)
         IF (TT(1,1).GT.ZERO) THEN
            IF (LDTT.GE.N) THEN
               DO 310 J=1,M
                  E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2
  310          CONTINUE
            ELSE
               DO 320 J=1,M
                  E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2
  320          CONTINUE
            END IF
         ELSE
            DO 330 J=1,M
               E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2
  330       CONTINUE
         END IF
      END IF

      RETURN
      END
*DETAF
      SUBROUTINE DETAF
     +   (FCN,
     +   N,M,NP,NQ,
     +   XPLUSD,BETA,EPSMAC,NROW,
     +   PARTMP,PV0,
     +   IFIXB,IFIXX,LDIFX,
     +   ISTOP,NFEV,ETA,NETA,
     +   WRK1,WRK2,WRK6,WRK7)
C***BEGIN PROLOGUE  DETAF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS
C            (ADAPTED FROM STARPAC SUBROUTINE ETAFUN)
C***END PROLOGUE  DETAF

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSMAC,ETA
      INTEGER
     +   ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),PARTMP(NP),PV0(N,NQ),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO
      INTEGER
     +   J,K,L

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,INT,LOG10,MAX,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P1,P2,P5,ONE,TWO,HUNDRD
     +   /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:      THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       PARAMETERS OF THE LOCAL FIT.
C   B:       PARAMETERS OF THE LOCAL FIT.
C   BETA:    THE FUNCTION PARAMETERS.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE NOISE IN THE MODEL RESULTS.
C   FAC:     A FACTOR USED IN THE COMPUTATIONS.
C   HUNDRD:  THE VALUE 1.0D2.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEX VARIABLE.
C   K:       AN INDEX VARIABLE.
C   L:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   P1:      THE VALUE 0.1D0.
C   P2:      THE VALUE 0.2D0.
C   P5:      THE VALUE 0.5D0.
C   PARTMP:  THE MODEL PARAMETERS.
C   PV0:     THE ORIGINAL PREDICTED VALUES.
C   STP:     A SMALL VALUE USED TO PERTURB THE PARAMETERS.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   WRK7:    A WORK ARRAY OF (5 BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DETAF


      STP = HUNDRD*EPSMAC
      ETA = EPSMAC

      DO 40 J=-2,2
         IF (J.EQ.0) THEN
            DO 10 L=1,NQ
               WRK7(J,L) = PV0(NROW,L)
   10       CONTINUE
         ELSE
            DO 20 K=1,NP
               IF (IFIXB(1).LT.0) THEN
                  PARTMP(K) = BETA(K) + J*STP*BETA(K)
               ELSE IF (IFIXB(K).NE.0) THEN
                  PARTMP(K) = BETA(K) + J*STP*BETA(K)
               ELSE 
                  PARTMP(K) = BETA(K)
               END IF
   20       CONTINUE
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               PARTMP,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               003,WRK2,WRK6,WRK1,ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF
            DO 30 L=1,NQ
               WRK7(J,L) = WRK2(NROW,L)
   30       CONTINUE
         END IF
   40 CONTINUE

      DO 100 L=1,NQ
         A = ZERO
         B = ZERO
         DO 50 J=-2,2
            A = A + WRK7(J,L)
            B = B + J*WRK7(J,L)
   50    CONTINUE
         A = P2*A
         B = P1*B
         IF ((WRK7(0,L).NE.ZERO) .AND. 
     +       (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN
            FAC = ONE/ABS(WRK7(0,L))
         ELSE
            FAC = ONE
         END IF
         DO 60 J=-2,2
            WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC)
            ETA = MAX(WRK7(J,L),ETA)
   60    CONTINUE
  100 CONTINUE
      NETA = MAX(TWO,P5-LOG10(ETA))

      RETURN
      END
*DEVJAC
      SUBROUTINE DEVJAC
     +   (FCN,
     +    ANAJAC,CDJAC, 
     +    N,M,NP,NQ,
     +    BETAC,BETA,STPB, 
     +    IFIXB,IFIXX,LDIFX,
     +    X,LDX,DELTA,XPLUSD,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,FN,
     +    STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +    NJEV,NFEV,ISTOP,INFO)
C***BEGIN PROLOGUE  DEVJAC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA
C***END PROLOGUE  DEVJAC

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE,
     +   M,N,NETA,NFEV,NJEV,NP,NQ
      LOGICAL
     +   ANAJAC,CDJAC,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),
     +   WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      INTEGER
     +   IDEVAL,J,K,K1,L
      DOUBLE PRECISION
     +   ZERO
      LOGICAL
     +   ERROR

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...DATA STATEMENTS
      DATA ZERO
     +   /0.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAC:   THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   DELTA:   THE ESTIMATED VALUES OF DELTA.
C   ERROR:   THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO 
C            VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER 
C            THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION
C            BY COMPUTING FJACD IN THE OLS CASE.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT.
C   IDEVAL:  THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE
C            PERFORMED BY USER-SUPPLIED SUBROUTINE FCN.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISTOP:   THE VARIABLE DESIGNATING THAT THE USER WISHES THE 
C            COMPUTATIONS STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   K1:      AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWE:    THE LEADING DIMENSION OF ARRAYS WE AND WE1.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LD2WE:   THE SECOND DIMENSION OF ARRAYS WE AND WE1.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   SSF:     THE SCALE USED FOR THE BETA'S.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   WE1:     THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   X:       THE INDEPENDENT VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DEVJAC


C  INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA

      CALL DUNPAC(NP,BETAC,BETA,IFIXB)

C  COMPUTE XPLUSD = X + DELTA

      CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)

C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND
C          THE JACOBIAN WRT DELTA (FJACD)

      ISTOP = 0
      IF (ISODR) THEN
         IDEVAL = 110
      ELSE
         IDEVAL = 010
      END IF
      IF (ANAJAC) THEN
         CALL FCN(N,M,NP,NQ,
     +            N,M,NP,
     +            BETA,XPLUSD,
     +            IFIXB,IFIXX,LDIFX,
     +            IDEVAL,WRK2,FJACB,FJACD,
     +            ISTOP)
         IF (ISTOP.NE.0) THEN
            RETURN
         ELSE
            NJEV = NJEV+1
         END IF
C  MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO
         IF (ISODR) THEN
            DO 10 L=1,NQ
               CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N)
   10       CONTINUE
         END IF
      ELSE IF (CDJAC) THEN
         CALL DJACCD(FCN,
     +               N,M,NP,NQ,
     +               BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +               STPB,STPD,LDSTPD,
     +               SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6,
     +               FJACB,ISODR,FJACD,NFEV,ISTOP)
      ELSE 
         CALL DJACFD(FCN,
     +               N,M,NP,NQ,
     +               BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +               STPB,STPD,LDSTPD,
     +               SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6,
     +               FJACB,ISODR,FJACD,NFEV,ISTOP)
      END IF
      IF (ISTOP.LT.0) THEN
         RETURN
      ELSE IF (.NOT.ISODR) THEN
C  TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD 
C  WITHIN FCN IN THE OLS CASE
         ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO
         IF (ERROR) THEN
            INFO = 50300
            RETURN
         END IF
      END IF

C  WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS

      IF (IFIXB(1).LT.0) THEN
         DO 20 K=1,NP
            CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                 FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP)
   20    CONTINUE
      ELSE
         K1 = 0
         DO 30 K=1,NP
            IF (IFIXB(K).GE.1) THEN
               K1 = K1 + 1
               CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                   FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP)
            END IF
   30    CONTINUE
      END IF

C  WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE

      IF (ISODR) THEN
         DO 40 J=1,M
            CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,
     +                FJACD(1,J,1),N*M,FJACD(1,J,1),N*M)
   40    CONTINUE
      END IF

      RETURN
      END
*DFCTR
      SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO)
C***BEGIN PROLOGUE  DFCTR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDOT
C***DATE WRITTEN   910706   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A
C            MODIFIED CHOLESKY FACTORIZATION
C            (ADAPTED FROM LINPACK SUBROUTINE DPOFA)
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE  DFCTR

C...SCALAR ARGUMENTS
      INTEGER INFO,LDA,N
      LOGICAL OKSEMI

C...ARRAY ARGUMENTS
      DOUBLE PRECISION A(LDA,N)

C...LOCAL SCALARS
      DOUBLE PRECISION XI,S,T,TEN,ZERO
      INTEGER J,K

C...EXTERNAL FUNCTIONS
      EXTERNAL DMPREC,DDOT
      DOUBLE PRECISION DMPREC,DDOT
 
C...INTRINSIC FUNCTIONS
      INTRINSIC SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,TEN
     +   /0.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       THE ARRAY TO BE FACTORED.  UPON RETURN, A CONTAINS THE
C            UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
C            WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO
C            IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C   I:       AN INDEXING VARIABLE.
C   INFO:    AN IDICATOR VARIABLE, WHERE IF
C            INFO = 0  THEN FACTORIZATION WAS COMPLETED
C            INFO = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
C                      OF ORDER  K  IS NOT POSITIVE (SEMI)DEFINITE.
C   J:       AN INDEXING VARIABLE.
C   LDA:     THE LEADING DIMENSION OF ARRAY A.
C   N:       THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A.
C   OKSEMI:  THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE 
C            SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO
C            BE POSITIVE DEFINITE (OKSEMI=FALSE).
C   TEN:     THE VALUE 10.0D0.
C   XI:      A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DFCTR


C  SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS.
      XI = -TEN*DMPREC()

C  COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A
      DO 20 J=1,N
         INFO = J
         S = ZERO
         DO 10 K=1,J-1
            IF (A(K,K).EQ.ZERO) THEN
               T      = ZERO
            ELSE
               T      = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
               T      = T/A(K,K)
            END IF
            A(K,J) = T
            S      = S + T*T
   10    CONTINUE
         S = A(J,J) - S
C     ......EXIT
         IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN
            RETURN
         ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN
            RETURN
         ELSE IF (S.LE.ZERO) THEN
            A(J,J) = ZERO
         ELSE
            A(J,J) = SQRT(S)
         END IF
   20 CONTINUE
      INFO = 0

C  ZERO OUT LOWER PORTION OF A
      DO 40 J=2,N
         DO 30 K=1,J-1
            A(J,K) = ZERO
   30    CONTINUE
   40 CONTINUE

      RETURN
      END
*DFCTRW
      SUBROUTINE DFCTRW
     +   (N,M,NQ,NPP,
     +   ISODR,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   WRK0,WRK4,
     +   WE1,NNZW,INFO)
C***BEGIN PROLOGUE  DFCTRW
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFCTR
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING
C            NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE
C            ODRPACK REFERENCE GUIDE 
C***END PROLOGUE  DFCTRW

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDWD,LDWE,LD2WD,LD2WE,
     +   M,N,NNZW,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),
     +   WRK0(NQ,NQ),WRK4(M,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,INF,J,J1,J2,L,L1,L2
      LOGICAL
     +   NOTZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DFCTR

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   J1:      AN INDEXING VARIABLE.
C   J2:      AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   L1:      AN INDEXING VARIABLE.
C   L2:      AN INDEXING VARIABLE.
C   LAST:    THE LAST ROW OF THE ARRAY TO BE ACCESSED.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NOTZRO:  THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE 
C            WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) 
C            OR NOT (NOTZRO=TRUE).
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATIONS.
C   WE:      THE (SQUARED) EPSILON WEIGHTS.
C   WE1:     THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE.
C   WD:      THE (SQUARED) DELTA WEIGHTS.
C   WRK0:    A WORK ARRAY OF (NQ BY NQ) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DFCTRW


C  CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1

      IF (WE(1,1,1).LT.ZERO) THEN
C  WE CONTAINS A SCALAR
         WE1(1,1,1) = -SQRT(ABS(WE(1,1,1)))
         NNZW = N

      ELSE
         NNZW = 0

         IF (LDWE.EQ.1) THEN

            IF (LD2WE.EQ.1) THEN
C  WE CONTAINS A DIAGONAL MATRIX
               DO 110 L=1,NQ
                  IF (WE(1,1,L).GT.ZERO) THEN
                     NNZW = N
                     WE1(1,1,L) = SQRT(WE(1,1,L))
                  ELSE IF (WE(1,1,L).LT.ZERO) THEN
                     INFO = 30010
                     GO TO 300
                  END IF
  110          CONTINUE
            ELSE

C  WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX 
               DO 130 L1=1,NQ
                  DO 120 L2=L1,NQ
                     WRK0(L1,L2) = WE(1,L1,L2)
  120             CONTINUE
  130          CONTINUE
               CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF)
               IF (INF.NE.0) THEN
                  INFO = 30010
                  GO TO 300
               ELSE
                  DO 150 L1=1,NQ
                     DO 140 L2=1,NQ
                        WE1(1,L1,L2) = WRK0(L1,L2)
  140                CONTINUE
                     IF (WE1(1,L1,L1).NE.ZERO) THEN
                        NNZW = N
                     END IF
  150             CONTINUE
               END IF
            END IF

         ELSE

            IF (LD2WE.EQ.1) THEN
C  WE CONTAINS AN ARRAY OF  DIAGONAL MATRIX
               DO 220 I=1,N
                  NOTZRO = .FALSE.
                  DO 210 L=1,NQ
                     IF (WE(I,1,L).GT.ZERO) THEN
                        NOTZRO = .TRUE.
                        WE1(I,1,L) = SQRT(WE(I,1,L))
                     ELSE IF (WE(I,1,L).LT.ZERO) THEN
                        INFO = 30010
                        GO TO 300
                     END IF
  210             CONTINUE
                  IF (NOTZRO) THEN
                     NNZW = NNZW + 1
                  END IF
  220          CONTINUE
            ELSE

C  WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES 
               DO 270 I=1,N
                  DO 240 L1=1,NQ
                     DO 230 L2=L1,NQ
                        WRK0(L1,L2) = WE(I,L1,L2)
  230                CONTINUE
  240             CONTINUE
                  CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF)
                  IF (INF.NE.0) THEN
                     INFO = 30010
                     GO TO 300
                  ELSE
                     NOTZRO = .FALSE.
                     DO 260 L1=1,NQ
                        DO 250 L2=1,NQ
                           WE1(I,L1,L2) = WRK0(L1,L2)
  250                   CONTINUE
                        IF (WE1(I,L1,L1).NE.ZERO) THEN
                           NOTZRO = .TRUE.
                        END IF
  260                CONTINUE
                  END IF
                  IF (NOTZRO) THEN
                     NNZW = NNZW + 1
                  END IF
  270          CONTINUE
            END IF
         END IF
      END IF

C  CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS

      IF (NNZW.LT.NPP) THEN
         INFO = 30020
      END IF


C  CHECK DELTA WEIGHTS

  300 CONTINUE
      IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN
C  PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR
         RETURN

      ELSE

         IF (LDWD.EQ.1) THEN

            IF (LD2WD.EQ.1) THEN
C  WD CONTAINS A DIAGONAL MATRIX
               DO 310 J=1,M
                  IF (WD(1,1,J).LE.ZERO) THEN
                     INFO = MAX(30001,INFO+1)
                     RETURN
                  END IF
  310          CONTINUE
            ELSE

C  WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX 
               DO 330 J1=1,M
                  DO 320 J2=J1,M
                     WRK4(J1,J2) = WD(1,J1,J2)
  320             CONTINUE
  330          CONTINUE
               CALL DFCTR(.FALSE.,WRK4,M,M,INF)
               IF (INF.NE.0) THEN
                  INFO = MAX(30001,INFO+1)
                  RETURN
               END IF
            END IF

         ELSE

            IF (LD2WD.EQ.1) THEN
C  WD CONTAINS AN ARRAY OF DIAGONAL MATRICES
               DO 420 I=1,N
                  DO 410 J=1,M
                     IF (WD(I,1,J).LE.ZERO) THEN
                        INFO = MAX(30001,INFO+1)
                        RETURN
                     END IF
  410             CONTINUE
  420          CONTINUE
            ELSE

C  WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES 
               DO 470 I=1,N
                  DO 440 J1=1,M
                     DO 430 J2=J1,M
                        WRK4(J1,J2) = WD(I,J1,J2)
  430                CONTINUE
  440             CONTINUE
                  CALL DFCTR(.FALSE.,WRK4,M,M,INF)
                  IF (INF.NE.0) THEN
                     INFO = MAX(30001,INFO+1)
                     RETURN
                  END IF
  470          CONTINUE
            END IF
         END IF
      END IF

      RETURN
      END
*DFLAGS
      SUBROUTINE DFLAGS
     +   (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
C***BEGIN PROLOGUE  DFLAGS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB
C***END PROLOGUE  DFLAGS

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...LOCAL SCALARS
      INTEGER
     +   J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MOD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 
C            (CHKJAC=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF 
C            ARRAY WORK (INITD=FALSE).
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       THE VALUE OF A SPECIFIC DIGIT OF JOB.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).


C***FIRST EXECUTABLE STATEMENT  DFLAGS


      IF (JOB.GE.0) THEN

         RESTRT= JOB.GE.10000

         INITD = MOD(JOB,10000)/1000.EQ.0

         J = MOD(JOB,1000)/100
         IF (J.EQ.0) THEN
            DOVCV = .TRUE.
            REDOJ = .TRUE.
         ELSE IF (J.EQ.1) THEN
            DOVCV = .TRUE.
            REDOJ = .FALSE.
         ELSE
            DOVCV = .FALSE.
            REDOJ = .FALSE.
         END IF

         J = MOD(JOB,100)/10
         IF (J.EQ.0) THEN
            ANAJAC = .FALSE.
            CDJAC  = .FALSE.
            CHKJAC = .FALSE.
         ELSE IF (J.EQ.1) THEN
            ANAJAC = .FALSE.
            CDJAC  = .TRUE.
            CHKJAC = .FALSE.
         ELSE IF (J.EQ.2) THEN
            ANAJAC = .TRUE.
            CDJAC  = .FALSE.
            CHKJAC = .TRUE.
         ELSE
            ANAJAC = .TRUE.
            CDJAC  = .FALSE.
            CHKJAC = .FALSE.
         END IF

         J = MOD(JOB,10)
         IF (J.EQ.0) THEN
            ISODR  = .TRUE.
            IMPLCT = .FALSE.
         ELSE IF (J.EQ.1) THEN
            ISODR  = .TRUE.
            IMPLCT = .TRUE.
         ELSE 
            ISODR  = .FALSE.
            IMPLCT = .FALSE.
         END IF

      ELSE

         RESTRT  = .FALSE.
         INITD   = .TRUE.
         DOVCV   = .TRUE.
         REDOJ   = .TRUE.
         ANAJAC  = .FALSE.
         CDJAC   = .FALSE.
         CHKJAC  = .FALSE.
         ISODR   = .TRUE.
         IMPLCT  = .FALSE.

      END IF

      RETURN
      END
*DHSTEP
      DOUBLE PRECISION FUNCTION DHSTEP
     +   (ITYPE,NETA,I,J,STP,LDSTP)
C***BEGIN PROLOGUE  DHSTEP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES
C***END PROLOGUE  DHSTEP

C...SCALAR ARGUMENTS
      INTEGER
     +   I,ITYPE,J,LDSTP,NETA

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   STP(LDSTP,J)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEN,THREE,TWO,ZERO
 
C...DATA STATEMENTS
      DATA
     +   ZERO,TWO,THREE,TEN
     +   /0.0D0,2.0D0,3.0D0,10.0D0/
 
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES.
C   ITYPE:   THE FINITE DIFFERENCE METHOD BEING USED, WHERE
C            ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND
C            ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES.
C   J:       AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES.
C   LDSTP:   THE LEADING DIMENSION OF ARRAY STP.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TEN:     THE VALUE 10.0D0.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   ZERO:    THE VALUE 0.0D0.



C***FIRST EXECUTABLE STATEMENT  DHSTEP


C  SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE

      IF (STP(1,1).LE.ZERO) THEN

         IF (ITYPE.EQ.0) THEN
C  USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE
            DHSTEP = TEN**(-ABS(NETA)/TWO - TWO)

         ELSE
C  USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE
            DHSTEP = TEN**(-ABS(NETA)/THREE)
         END IF

      ELSE IF (LDSTP.EQ.1) THEN
         DHSTEP = STP(1,J)

      ELSE
         DHSTEP = STP(I,J)
      END IF

      RETURN
      END
*DIFIX
      SUBROUTINE DIFIX
     +   (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX)
C***BEGIN PROLOGUE  DIFIX
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   910612   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX
C***END PROLOGUE  DIFIX

C...SCALAR ARGUMENTS
      INTEGER
     +   LDIFIX,LDT,LDTFIX,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),TFIX(LDTFIX,M)
      INTEGER
     +   IFIX(LDIFIX,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE
C            SET TO ZERO.
C   J:       AN INDEXING VARIABLE.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   LDIFIX:  THE LEADING DIMENSION OF ARRAY IFIX.
C   LDTFIX:  THE LEADING DIMENSION OF ARRAY TFIX.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE ARRAY.
C   N:       THE NUMBER OF ROWS OF DATA IN THE ARRAY.
C   T:       THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS 
C            OF IFIX.
C   TFIX:    THE RESULTING ARRAY.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DIFIX


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (IFIX(1,1).GE.ZERO) THEN
         IF (LDIFIX.GE.N) THEN
            DO 20 J=1,M
               DO 10 I=1,N
                  IF (IFIX(I,J).EQ.0) THEN
                     TFIX(I,J) = ZERO
                  ELSE
                     TFIX(I,J) = T(I,J)
                  END IF
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 100 J=1,M
               IF (IFIX(1,J).EQ.0) THEN
                  DO 30 I=1,N
                     TFIX(I,J) = ZERO
   30             CONTINUE
               ELSE
                  DO 90 I=1,N
                     TFIX(I,J) = T(I,J)
   90             CONTINUE
               END IF
  100       CONTINUE
         END IF
      END IF

      RETURN
      END
*DINIWK
      SUBROUTINE DINIWK
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +   BETA,SCLB,
     +   SSTOL,PARTOL,MAXIT,TAUFAC,
     +   JOB,IPRINT,LUNERR,LUNRPT,
     +   EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI,
     +   JOBI,IPRINI,LUNERI,LUNRPI,
     +   SSFI,TTI,LDTTI,DELTAI)
C***BEGIN PROLOGUE  DINIWK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DMPREC,DSCLB,DSCLD,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  INITIALIZE WORK VECTORS AS NECESSARY
C***END PROLOGUE  DINIWK

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX,
     +   LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M,
     +   MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M)
      INTEGER
     +   IFIXX(LDIFX,M),IWORK(LIWORK)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,THREE,TWO,ZERO
      INTEGER
     +   I,J 
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION 
     +   DMPREC
      EXTERNAL
     +   DMPREC

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY,DFLAGS,DSCLB,DSCLD,DZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TWO,THREE
     +   /0.0D0,1.0D0,2.0D0,3.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   I:       AN INDEXING VARIABLE.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 
C            AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   IWORK:   THE INTEGER WORK SPACE.
C   J:       AN INDEXING VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDTTI:   THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   THREE:   THE VALUE 3.0D0.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT.
C   TWO:     THE VALUE 2.0D0.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE INDEPENDENT VARIABLE.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DINIWK


      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)

C  STORE VALUE OF MACHINE PRECISION IN WORK VECTOR

      WORK(EPSMAI) = DMPREC()

C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  PARAMETERS  (SEE ALSO SUBPROGRAM DODCNT)

      IF (PARTOL.LT.ZERO) THEN
         WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE)
      ELSE
         WORK(PARTLI) = MIN(PARTOL, ONE)
      END IF

C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS

      IF (SSTOL.LT.ZERO) THEN
         WORK(SSTOLI) = SQRT(WORK(EPSMAI))
      ELSE
         WORK(SSTOLI) = MIN(SSTOL, ONE)
      END IF

C  SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION

      IF (TAUFAC.LE.ZERO) THEN
         WORK(TAUFCI) = ONE
      ELSE
         WORK(TAUFCI) = MIN(TAUFAC, ONE)
      END IF

C  SET MAXIMUM NUMBER OF ITERATIONS

      IF (MAXIT.LT.0) THEN
         IWORK(MAXITI) = 50
      ELSE
         IWORK(MAXITI) = MAXIT
      END IF

C  STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL
C  VARIABLE

      IF (JOB.LE.0) THEN
         IWORK(JOBI) = 0
      ELSE
         IWORK(JOBI) = JOB
      END IF

C  SET PRINT CONTROL

      IF (IPRINT.LT.0) THEN
         IWORK(IPRINI) = 2001
      ELSE
         IWORK(IPRINI) = IPRINT
      END IF

C  SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES

      IF (LUNERR.LT.0) THEN
         IWORK(LUNERI) = 6
      ELSE
         IWORK(LUNERI) = LUNERR
      END IF

C  SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS

      IF (LUNRPT.LT.0) THEN
         IWORK(LUNRPI) = 6
      ELSE
         IWORK(LUNRPI) = LUNRPT
      END IF

C  COMPUTE SCALING FOR BETA'S AND DELTA'S

      IF (SCLB(1).LE.ZERO) THEN
         CALL DSCLB(NP,BETA,WORK(SSFI))
      ELSE
         CALL DCOPY(NP,SCLB,1,WORK(SSFI),1)
      END IF
      IF (ISODR) THEN
         IF (SCLD(1,1).LE.ZERO) THEN
            IWORK(LDTTI) = N
            CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI))
         ELSE
            IF (LDSCLD.EQ.1) THEN
               IWORK(LDTTI) = 1
               CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1)
            ELSE
               IWORK(LDTTI) = N
               DO 10 J=1,M
                  CALL DCOPY(N,SCLD(1,J),1,
     +                        WORK(TTI+(J-1)*IWORK(LDTTI)),1)
   10          CONTINUE
            END IF
         END IF
      END IF

C  INITIALIZE DELTA'S AS NECESSARY

      IF (ISODR) THEN
         IF (INITD) THEN
            CALL DZERO(N,M,WORK(DELTAI),N)
         ELSE
            IF (IFIXX(1,1).GE.0) THEN
               IF (LDIFX.EQ.1) THEN
                  DO 20 J=1,M
                     IF (IFIXX(1,J).EQ.0) THEN
                        CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N)
                     END IF
   20             CONTINUE
               ELSE
                  DO 40 J=1,M
                     DO 30 I=1,N
                        IF (IFIXX(I,J).EQ.0) THEN
                           WORK(DELTAI-1+I+(J-1)*N) = ZERO
                        END IF
   30                CONTINUE
   40             CONTINUE
               END IF
            END IF
         END IF
      ELSE
         CALL DZERO(N,M,WORK(DELTAI),N)
      END IF

      RETURN
      END
*DIWINF
      SUBROUTINE DIWINF
     +   (M,NP,NQ,
     +   MSGBI,MSGDI,IFIX2I,ISTOPI,
     +   NNZWI,NPPI,IDFI,
     +   JOBI,IPRINI,LUNERI,LUNRPI,
     +   NROWI,NTOLI,NETAI,
     +   MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +   LIWKMN)
C***BEGIN PROLOGUE  DIWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE
C***END PROLOGUE  DIWINF

C...SCALAR ARGUMENTS
      INTEGER
     +   IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN,
     +   LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI,
     +   NNZWI,NP,NPPI,NQ,NROWI,NTOLI

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   IDFI:    THE LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   IFIX2I:  THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2.
C   INT2I:   THE LOCATION IN ARRAY IWORK OF VARIABLE INT2.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   LDTTI:   THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGBI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGDI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABEL NITER.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.


C***FIRST EXECUTABLE STATEMENT  DIWINF


      IF (NP.GE.1 .AND. M.GE.1) THEN
         MSGBI  = 1
         MSGDI  = MSGBI  + NQ*NP+1
         IFIX2I = MSGDI  + NQ*M+1
         ISTOPI = IFIX2I + NP
         NNZWI  = ISTOPI + 1
         NPPI   = NNZWI  + 1
         IDFI   = NPPI   + 1
         JOBI   = IDFI   + 1
         IPRINI = JOBI   + 1
         LUNERI = IPRINI + 1
         LUNRPI = LUNERI + 1
         NROWI  = LUNRPI + 1
         NTOLI  = NROWI  + 1
         NETAI  = NTOLI  + 1
         MAXITI = NETAI  + 1
         NITERI = MAXITI + 1
         NFEVI  = NITERI + 1
         NJEVI  = NFEVI  + 1
         INT2I  = NJEVI  + 1
         IRANKI = INT2I  + 1
         LDTTI  = IRANKI + 1
         LIWKMN = LDTTI
      ELSE
         MSGBI  = 1
         MSGDI  = 1
         IFIX2I = 1
         ISTOPI = 1
         NNZWI  = 1
         NPPI   = 1
         IDFI   = 1
         JOBI   = 1
         IPRINI = 1
         LUNERI = 1
         LUNRPI = 1
         NROWI  = 1
         NTOLI  = 1
         NETAI  = 1
         MAXITI = 1
         NITERI = 1
         NFEVI  = 1
         NJEVI  = 1
         INT2I  = 1
         IRANKI = 1
         LDTTI  = 1
         LIWKMN = 1
      END IF

      RETURN
      END
*DJACCD
      SUBROUTINE DJACCD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,NFEV,ISTOP)
C***BEGIN PROLOGUE  DJACCD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE
C            JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS
C***END PROLOGUE  DJACCD

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ),
     +   X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAK,ONE,TYPJ,ZERO
      INTEGER
     +   I,J,K,L
      LOGICAL
     +   DOIT,SETZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAK:   THE K-TH FUNCTION PARAMETER.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOIT:    THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN
C            BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT 
C            (DOIT=FALSE).
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 
C            AT THEIR INPUT VALUES OR NOT.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SETZRO:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 
C            DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT
C            (SETZRO=FALSE).
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJACCD


C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS

      DO 60 K=1,NP
         IF (IFIXB(1).GE.0) THEN
            IF (IFIXB(K).EQ.0) THEN
               DOIT = .FALSE.
            ELSE
               DOIT = .TRUE.
            END IF
         ELSE
            DOIT = .TRUE.
         END IF
         IF (.NOT.DOIT) THEN
            DO 10 L=1,NQ
               CALL DZERO(N,1,FJACB(1,K,L),N)
   10       CONTINUE
         ELSE
            BETAK = BETA(K)
            IF (BETAK.EQ.ZERO) THEN
               IF (SSF(1).LT.ZERO) THEN
                  TYPJ = ONE/ABS(SSF(1))
               ELSE
                  TYPJ = ONE/SSF(K)
               END IF
            ELSE
               TYPJ = ABS(BETAK)
            END IF
            WRK3(K) = BETAK 
     +                + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1)
            WRK3(K) = WRK3(K) - BETAK

            BETA(K) = BETAK + WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
               DO 30 L=1,NQ
                  DO 20 I=1,N
                     FJACB(I,K,L) = WRK2(I,L)
   20             CONTINUE
   30          CONTINUE
            END IF

            BETA(K) = BETAK - WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF

            DO 50 L=1,NQ
               DO 40 I=1,N
                  FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K))
   40          CONTINUE
   50       CONTINUE
            BETA(K) = BETAK
         END IF
   60 CONTINUE

C  COMPUTE THE JACOBIAN WRT THE X'S

      IF (ISODR) THEN
         DO 220 J=1,M
            IF (IFIXX(1,1).LT.0) THEN
               DOIT = .TRUE.
               SETZRO = .FALSE.
            ELSE IF (LDIFX.EQ.1) THEN
               IF (IFIXX(1,J).EQ.0) THEN
                  DOIT = .FALSE.
               ELSE
                  DOIT = .TRUE.
               END IF
               SETZRO = .FALSE.
            ELSE
               DOIT = .FALSE.
               SETZRO = .FALSE.
               DO 100 I=1,N
                  IF (IFIXX(I,J).NE.0) THEN
                     DOIT = .TRUE.
                  ELSE
                     SETZRO = .TRUE.
                  END IF
  100          CONTINUE
            END IF
            IF (.NOT.DOIT) THEN
               DO 110 L=1,NQ
                  CALL DZERO(N,1,FJACD(1,J,L),N)
  110          CONTINUE
            ELSE
               DO 120 I=1,N
                  IF (XPLUSD(I,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(I,J)
                     END IF
                  ELSE
                     TYPJ = ABS(XPLUSD(I,J))
                  END IF
                  STP(I) = XPLUSD(I,J)
     +                     + SIGN(ONE,XPLUSD(I,J))
     +                       *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD)
                  STP(I) = STP(I) - XPLUSD(I,J)
                  XPLUSD(I,J) = XPLUSD(I,J) + STP(I)
  120          CONTINUE
               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
                  DO 140 L=1,NQ
                     DO 130 I=1,N
                        FJACD(I,J,L) = WRK2(I,L)
  130                CONTINUE
  140             CONTINUE
               END IF

               DO 150 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I)
  150          CONTINUE
               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
               END IF

               IF (SETZRO) THEN
                  DO 180 I=1,N
                     IF (IFIXX(I,J).EQ.0) THEN
                        DO 160 L=1,NQ
                           FJACD(I,J,L) = ZERO
  160                   CONTINUE
                     ELSE
                        DO 170 L=1,NQ
                           FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/
     +                                    (2*STP(I))
  170                   CONTINUE
                     END IF
  180             CONTINUE
               ELSE
                  DO 200 L=1,NQ
                     DO 190 I=1,N
                        FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/
     +                                 (2*STP(I))
  190                CONTINUE
  200             CONTINUE
               END IF
               DO 210 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J)
  210          CONTINUE
            END IF
  220    CONTINUE
      END IF

      RETURN
      END
*DJACFD
      SUBROUTINE DJACFD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6,
     +    FJACB,ISODR,FJACD,NFEV,ISTOP)
C***BEGIN PROLOGUE  DJACFD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE
C            JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS
C***END PROLOGUE  DJACFD

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),
     +   SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ),
     +   X(LDX,M),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAK,ONE,TYPJ,ZERO
      INTEGER
     +   I,J,K,L
      LOGICAL
     +   DOIT,SETZRO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DZERO

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAK:   THE K-TH FUNCTION PARAMETER.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOIT:    THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A 
C            GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE)
C            OR NOT (DOIT=FALSE).
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE NEW PREDICTED VALUES FROM THE FUNCTION.
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SETZRO:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 
C            DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT
C            (SETZRO=FALSE).
C   SSF:     THE SCALE USED FOR THE BETA'S.
C   STP:     THE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJACFD


C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS

      DO 40 K=1,NP
         IF (IFIXB(1).GE.0) THEN
            IF (IFIXB(K).EQ.0) THEN
               DOIT = .FALSE.
            ELSE
               DOIT = .TRUE.
            END IF
         ELSE
            DOIT = .TRUE.
         END IF
         IF (.NOT.DOIT) THEN
            DO 10 L=1,NQ
               CALL DZERO(N,1,FJACB(1,K,L),N)
   10       CONTINUE
         ELSE
            BETAK = BETA(K)
            IF (BETAK.EQ.ZERO) THEN
               IF (SSF(1).LT.ZERO) THEN
                  TYPJ = ONE/ABS(SSF(1))
               ELSE   
                  TYPJ = ONE/SSF(K)
               END IF 
            ELSE
               TYPJ = ABS(BETAK)
            END IF
            WRK3(K) = BETAK 
     +                + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1)
            WRK3(K) = WRK3(K) - BETAK
            BETA(K) = BETAK + WRK3(K)
            ISTOP = 0
            CALL FCN(N,M,NP,NQ,
     +               N,M,NP,
     +               BETA,XPLUSD,
     +               IFIXB,IFIXX,LDIFX,
     +               001,WRK2,WRK6,WRK1,
     +               ISTOP)
            IF (ISTOP.NE.0) THEN
               RETURN
            ELSE
               NFEV = NFEV + 1
            END IF
            DO 30 L=1,NQ
               DO 20 I=1,N
                  FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K)
   20          CONTINUE
   30       CONTINUE
            BETA(K) = BETAK
         END IF
   40 CONTINUE

C  COMPUTE THE JACOBIAN WRT THE X'S

      IF (ISODR) THEN
         DO 220 J=1,M
            IF (IFIXX(1,1).LT.0) THEN
               DOIT = .TRUE.
               SETZRO = .FALSE.
            ELSE IF (LDIFX.EQ.1) THEN
               IF (IFIXX(1,J).EQ.0) THEN
                  DOIT = .FALSE.
               ELSE
                  DOIT = .TRUE.
               END IF
               SETZRO = .FALSE.
            ELSE
               DOIT = .FALSE.
               SETZRO = .FALSE.
               DO 100 I=1,N
                  IF (IFIXX(I,J).NE.0) THEN
                     DOIT = .TRUE.
                  ELSE
                     SETZRO = .TRUE.
                  END IF
  100          CONTINUE
            END IF
            IF (.NOT.DOIT) THEN
               DO 110 L=1,NQ
                  CALL DZERO(N,1,FJACD(1,J,L),N)
  110          CONTINUE
            ELSE
               DO 120 I=1,N
                  IF (XPLUSD(I,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(I,J)
                     END IF
                  ELSE
                     TYPJ = ABS(XPLUSD(I,J))
                  END IF

                  STP(I) = XPLUSD(I,J)
     +                     + SIGN(ONE,XPLUSD(I,J))
     +                       *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD)
                  STP(I) = STP(I) - XPLUSD(I,J)
                  XPLUSD(I,J) = XPLUSD(I,J) + STP(I)
  120          CONTINUE

               ISTOP = 0
               CALL FCN(N,M,NP,NQ,
     +                  N,M,NP,
     +                  BETA,XPLUSD,
     +                  IFIXB,IFIXX,LDIFX,
     +                  001,WRK2,WRK6,WRK1,
     +                  ISTOP)
               IF (ISTOP.NE.0) THEN
                  RETURN
               ELSE
                  NFEV = NFEV + 1
                  DO 140 L=1,NQ
                     DO 130 I=1,N
                        FJACD(I,J,L) = WRK2(I,L)
  130                CONTINUE
  140             CONTINUE

               END IF

               IF (SETZRO) THEN
                  DO 180 I=1,N
                     IF (IFIXX(I,J).EQ.0) THEN
                        DO 160 L=1,NQ
                           FJACD(I,J,L) = ZERO
  160                   CONTINUE
                     ELSE
                        DO 170 L=1,NQ
                           FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I)
  170                   CONTINUE
                     END IF
  180             CONTINUE
               ELSE
                  DO 200 L=1,NQ
                     DO 190 I=1,N
                        FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I)
  190                CONTINUE
  200             CONTINUE
               END IF
               DO 210 I=1,N
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J)
  210          CONTINUE
            END IF
  220    CONTINUE
      END IF

      RETURN
      END
*DJCK
      SUBROUTINE DJCK
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,
     +    IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD,
     +    SSF,TT,LDTT,
     +    ETA,NETA,NTOL,NROW,ISODR,EPSMAC,
     +    PV0,FJACB,FJACD,
     +    MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DHSTEP,DJCKM
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS
C            (ADAPTED FROM STARPAC SUBROUTINE DCKCNT)
C***END PROLOGUE  DJCK

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSMAC,ETA
      INTEGER
     +   ISTOP,LDIFX,LDSTPD,LDTT,
     +   M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO
      INTEGER
     +   IDEVAL,J,LQ,MSGB1,MSGD1
      LOGICAL
     +   ISFIXD,ISWRTB

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKM

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,INT,LOG10

C...DATA STATEMENTS
      DATA
     +   ZERO,P5,ONE
     +   /0.0D0,0.5D0,1.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   H0:      THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   HC0:     THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   IDEVAL:  THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE 
C            PERFORMED BY USER SUPPLIED SUBROUTINE FCN.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISFIXD:  THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED
C            (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER
C            SET BY THE USER OR COMPUTED BY DETAF.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES.
C   ONE:     THE VALUE 1.0D0.
C   P5:      THE VALUE 0.5D0.
C   PV:      THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C            ROW   NROW   IS STORED.
C   PV0:     THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   STPB:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA.
C   STPD:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCK


C  SET TOLERANCE FOR CHECKING DERIVATIVES

      TOL  = ETA**(0.25D0)
      NTOL = MAX(ONE,P5-LOG10(TOL))


C  COMPUTE USER SUPPLIED DERIVATIVE VALUES

      ISTOP = 0
      IF (ISODR) THEN
         IDEVAL = 110
      ELSE
         IDEVAL = 010
      END IF
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         IDEVAL,WRK2,FJACB,FJACD,
     +         ISTOP)
      IF (ISTOP.NE.0) THEN
         RETURN
      ELSE
         NJEV = NJEV + 1
      END IF

C  CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW

      MSGB1 = 0
      MSGD1 = 0

      DO 30 LQ=1,NQ

C  SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES
         PV = PV0(NROW,LQ)

         ISWRTB = .TRUE.
         DO 10 J=1,NP

            IF (IFIXB(1).LT.0) THEN
               ISFIXD = .FALSE.
            ELSE IF (IFIXB(J).EQ.0) THEN
               ISFIXD = .TRUE.
            ELSE
               ISFIXD = .FALSE.
            END IF

            IF (ISFIXD) THEN
               MSGB(1+LQ+(J-1)*NQ) = -1
            ELSE
               IF (BETA(J).EQ.ZERO) THEN
                  IF (SSF(1).LT.ZERO) THEN
                     TYPJ = ONE/ABS(SSF(1))
                  ELSE
                     TYPJ = ONE/SSF(J)
                  END IF
               ELSE
                  TYPJ = ABS(BETA(J))
               END IF
   
               H0  = DHSTEP(0,NETA,1,J,STPB,1)
               HC0 = H0

C  CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW

               CALL DJCKM(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,
     +                    IFIXB,IFIXX,LDIFX,
     +                    ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +                    ISWRTB,PV,FJACB(NROW,J,LQ),
     +                    DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
               IF (ISTOP.NE.0) THEN
                  MSGB(1) = -1
                  RETURN
               ELSE
                  DIFF(LQ,J) = DIFFJ
               END IF
            END IF

   10    CONTINUE

C  CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW

         IF (ISODR) THEN
            ISWRTB = .FALSE.
            DO 20 J=1,M

               IF (IFIXX(1,1).LT.0) THEN
                  ISFIXD = .FALSE.
               ELSE IF (LDIFX.EQ.1) THEN
                  IF (IFIXX(1,J).EQ.0) THEN
                     ISFIXD = .TRUE.
                  ELSE
                     ISFIXD = .FALSE.
                  END IF
               ELSE
                  ISFIXD = .FALSE.
               END IF

               IF (ISFIXD) THEN
                  MSGD(1+LQ+(J-1)*NQ) = -1
               ELSE

                  IF (XPLUSD(NROW,J).EQ.ZERO) THEN
                     IF (TT(1,1).LT.ZERO) THEN
                        TYPJ = ONE/ABS(TT(1,1))
                     ELSE IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(NROW,J)
                     END IF
                  ELSE  
                     TYPJ = ABS(XPLUSD(NROW,J))
                  END IF
 
                  H0  = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD)
                  HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD)

C  CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW

                  CALL DJCKM(FCN,
     +                       N,M,NP,NQ,
     +                       BETA,XPLUSD,
     +                       IFIXB,IFIXX,LDIFX,
     +                       ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +                       ISWRTB,PV,FJACD(NROW,J,LQ),
     +                       DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV,
     +                       WRK1,WRK2,WRK6)
                  IF (ISTOP.NE.0) THEN
                     MSGD(1) = -1
                     RETURN
               ELSE
                  DIFF(LQ,NP+J) = DIFFJ
                  END IF
               END IF

   20       CONTINUE
         END IF
   30 CONTINUE
      MSGB(1) = MSGB1
      MSGD(1) = MSGD1

      RETURN
      END
*DJCKC
      SUBROUTINE DJCKC
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB,
     +    FD,TYPJ,PVPSTP,STP0,
     +    PV,D,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKF,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE
C            DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKCRV)
C***END PROLOGUE  DJCKC

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKF,DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SIGN

C...DATA STATEMENTS
      DATA
     +   P01,ONE,TWO,TEN
     +   /0.01D0,1.0D0,2.0D0,10.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CURVE:   A MEASURE OF THE CURVATURE IN THE MODEL.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE MODEL
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   HC:      THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE OF THE MODEL FOR ROW   NROW   .
C   PVMCRV:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV.
C   PVPCRV:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV.
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P01:     THE VALUE 0.01D0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   STP:     A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   STPCRV:  THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL.
C   TEN:     THE VALUE 10.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TWO:     THE VALUE 2.0D0.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DJCKC


      IF (ISWRTB) THEN

C  PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA

         STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STPCRV,
     +             ISTOP,NFEV,PVPCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STPCRV,
     +             ISTOP,NFEV,PVMCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      ELSE

C  PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA

         STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - 
     +            XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STPCRV,
     +             ISTOP,NFEV,PVPCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STPCRV,
     +             ISTOP,NFEV,PVMCRV,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      END IF

C  ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL

      CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV)
      CURVE = CURVE + 
     +        ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2)


C  CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT.
      CALL DJCKF(FCN,
     +           N,M,NP,NQ,
     +           BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +           ETA,TOL,NROW,J,LQ,ISWRTB,
     +           FD,TYPJ,PVPSTP,STP0,CURVE,PV,D,
     +           DIFFJ,MSG,ISTOP,NFEV,
     +           WRK1,WRK2,WRK6)
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF
      IF (MSG(LQ,J).EQ.0) THEN
         RETURN
      END IF

C  CHECK IF HIGH CURVATURE COULD BE THE PROBLEM.

      STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC)
      IF (STP.LT.ABS(TEN*STP0)) THEN
         STP = MIN(STP,P01*ABS(STP0))
      END IF


      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
         STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
         STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - 
     +         XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF
      END IF

C  COMPUTE THE NEW NUMERICAL DERIVATIVE

      FD = (PVPSTP-PV)/STP
      DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D))

C  CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK
      IF (ABS(FD-D).LE.TOL*ABS(D)) THEN
         MSG(LQ,J) = 0

C  CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2)
      ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP))
     +                                + CURVE*(EPSMAC*TYPJ)**2) THEN
         MSG(LQ,J) = 5
      END IF

      RETURN
      END
*DJCKF
      SUBROUTINE DJCKF
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,J,LQ,ISWRTB,
     +    FD,TYPJ,PVPSTP,STP0,CURVE,PV,D,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE
C            CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKFPA)
C***END PROLOGUE  DJCKF

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   HUNDRD,ONE,P1,STP,TWO
      LOGICAL
     +   LARGE

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SIGN

C...DATA STATEMENTS
      DATA
     +   P1,ONE,TWO,HUNDRD
     +   /0.1D0,1.0D0,2.0D0,100.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CURVE:   A MEASURE OF THE CURVATURE IN THE MODEL.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   ETA:     THE RELATIVE NOISE IN THE MODEL
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   HUNDRD:  THE VALUE 100.0D0.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LARGE:   THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN 
C            THE STEP SIZE WOULD BE GREATER THAN TYPJ.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FOR ROW   NROW   .
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P1:      THE VALUE 0.1D0.
C   STP0:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TWO:     THE VALUE 2.0D0.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DJCKF


C  FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM.
C  TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR

      STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D))
      IF (STP.GT.ABS(P1*STP0)) THEN
         STP = MAX(STP,HUNDRD*ABS(STP0))
      END IF
      IF (STP.GT.TYPJ) THEN
         STP = TYPJ
         LARGE = .TRUE.
      ELSE
         LARGE = .FALSE.
      END IF
 
      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
         STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
         STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) -
     +         XPLUSD(NROW,J)
         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,STP,
     +             ISTOP,NFEV,PVPSTP,
     +             WRK1,WRK2,WRK6)
      END IF
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF

      FD = (PVPSTP-PV)/STP
      DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D))

C  CHECK FOR AGREEMENT

      IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN
C  FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE.
         MSG(LQ,J) = 0

      ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN
C  CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2)
         IF (LARGE) THEN
            MSG(LQ,J) = 4
         ELSE
            MSG(LQ,J) = 5
         END IF
      END IF

      RETURN
      END
*DJCKM
      SUBROUTINE DJCKM
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0,
     +    ISWRTB,PV,D,
     +    DIFFJ,MSG1,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKC,DJCKZ,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL
C            DERIVATIVES
C            (ADAPTED FROM STARPAC SUBROUTINE DCKMN)
C***END PROLOGUE  DJCKM

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0,
     +   TEN,THREE,TOL2,TWO,ZERO
      INTEGER
     +   I

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DJCKC,DJCKZ,DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,SIGN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD
     +   /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/
      DATA
     +   BIG,TOL2
     +   /1.0D19,5.0D-2/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BIG:     A BIG VALUE, USED TO INITIALIZE DIFFJ.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   H:       THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   H0:      THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   H1:      THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES.
C   HC:      THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HC0:     THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HC1:     THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES.
C   HUNDRD:  THE VALUE 100.0D0.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   MSG1:    THE ERROR CHECKING RESULTS SUMMARY.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FROM THE MODEL FOR ROW   NROW   .
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH 
C            PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   P01:     THE VALUE 0.01D0.
C   P1:      THE VALUE 0.1D0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   TEN:     THE VALUE 10.0D0.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TOL2:    A MINIMUM AGREEMENT TOLERANCE.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCKM


C  CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE
C  QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES

      H1  = SQRT(ETA)
      HC1 = ETA**(ONE/THREE)

      MSG(LQ,J) = 7
      DIFFJ = BIG

      DO 10 I=1,3

         IF (I.EQ.1) THEN
C  TRY INITIAL RELATIVE STEP SIZE
            H  = H0
            HC = HC0

         ELSE IF (I.EQ.2) THEN
C  TRY LARGER RELATIVE STEP SIZE
            H  = MAX(TEN*H1, MIN(HUNDRD*H0, ONE))
            HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE))

         ELSE IF (I.EQ.3) THEN
C  TRY SMALLER RELATIVE STEP SIZE
            H  = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC))
            HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC))
         END IF

         IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA

            STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
            CALL DPVB(FCN,
     +                N,M,NP,NQ,
     +                BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                NROW,J,LQ,STP0,
     +                ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
         ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA

            STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J))
     +            - XPLUSD(NROW,J)
            CALL DPVD(FCN,
     +                N,M,NP,NQ,
     +                BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                NROW,J,LQ,STP0,
     +                ISTOP,NFEV,PVPSTP,
     +                WRK1,WRK2,WRK6)
         END IF
         IF (ISTOP.NE.0) THEN
            RETURN
         END IF

         FD = (PVPSTP-PV)/STP0

C  CHECK FOR AGREEMENT

         IF (ABS(FD-D).LE.TOL*ABS(D)) THEN
C  NUMERICAL AND ANALYTIC DERIVATIVES AGREE

C  SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT
            IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN
               DIFFJ = ABS(FD-D)
            ELSE
               DIFFJ = ABS(FD-D)/ABS(D)
            END IF

C  SET MSG FLAG.
            IF (D.EQ.ZERO) THEN

C  JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO.
               MSG(LQ,J) = 1

            ELSE
C  JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO.
               MSG(LQ,J) = 0
            END IF

         ELSE

C  NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE.  CHECK WHY
            IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN
               CALL DJCKZ(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                    NROW,EPSMAC,J,LQ,ISWRTB,
     +                    TOL,D,FD,TYPJ,PVPSTP,STP0,PV,
     +                    DIFFJ,MSG,ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
            ELSE
               CALL DJCKC(FCN,
     +                    N,M,NP,NQ,
     +                    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +                    ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB,
     +                    FD,TYPJ,PVPSTP,STP0,PV,D,
     +                    DIFFJ,MSG,ISTOP,NFEV,
     +                    WRK1,WRK2,WRK6)
            END IF
            IF (MSG(LQ,J).LE.2) THEN
               GO TO 20
            END IF
         END IF
   10 CONTINUE

C  SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS
   20 CONTINUE
      IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6
      IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN
         MSG1 = MAX(MSG1,1)
      ELSE IF (MSG(LQ,J).GE.7) THEN
         MSG1 = 2
      END IF

      RETURN
      END
*DJCKZ
      SUBROUTINE DJCKZ
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,EPSMAC,J,LQ,ISWRTB,
     +    TOL,D,FD,TYPJ,PVPSTP,STP0,PV,
     +    DIFFJ,MSG,ISTOP,NFEV,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DJCKZ
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE
C            DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC
C            DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO
C            (ADAPTED FROM STARPAC SUBROUTINE DCKZRO)
C***END PROLOGUE  DJCKZ

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW
      LOGICAL
     +   ISWRTB

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CD,ONE,PVMSTP,THREE,TWO,ZERO

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPVB,DPVD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TWO,THREE
     +   /0.0D0,1.0D0,2.0D0,3.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CD:      THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   D:       THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER.
C   DIFFJ:   THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING
C            CHECKED.
C   EPSMAC:  THE VALUE OF MACHINE PRECISION.
C   FD:      THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISWRTB:  THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 
C            (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSG:     THE ERROR CHECKING RESULTS.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 
C            THE DERIVATIVE IS TO BE CHECKED.
C   ONE:     THE VALUE 1.0D0.
C   PV:      THE PREDICTED VALUE FROM THE MODEL FOR ROW   NROW   .
C   PVMSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0.
C   PVPSTP:  THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C            USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 
C            JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0.
C   STP0:    THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   THREE:   THE VALUE 3.0D0.
C   TWO:     THE VALUE 2.0D0.
C   TOL:     THE AGREEMENT TOLERANCE.
C   TYPJ:    THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
C   WRK1:    A WORK ARRAY OF (N BY M BY NQ) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DJCKZ


C  RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP
C  SIZE OF 2*STP0

      IF (ISWRTB) THEN

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA

         CALL DPVB(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STP0,
     +             ISTOP,NFEV,PVMSTP,
     +             WRK1,WRK2,WRK6)
      ELSE

C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA

         CALL DPVD(FCN,
     +             N,M,NP,NQ,
     +             BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +             NROW,J,LQ,-STP0,
     +             ISTOP,NFEV,PVMSTP,
     +             WRK1,WRK2,WRK6)
      END IF
      IF (ISTOP.NE.0) THEN
         RETURN
      END IF

      CD = (PVPSTP-PVMSTP)/(TWO*STP0)
      DIFFJ = MIN(ABS(CD-D),ABS(FD-D))

C  CHECK FOR AGREEMENT

      IF (DIFFJ.LE.TOL*ABS(D)) THEN

C  FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE.
         IF (D.EQ.ZERO) THEN
            MSG(LQ,J) = 1
         ELSE
            MSG(LQ,J) = 0
         END IF

      ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN
C  DERIVATIVES ARE BOTH CLOSE TO ZERO
         MSG(LQ,J) = 2

      ELSE
C  DERIVATIVES ARE NOT BOTH CLOSE TO ZERO
         MSG(LQ,J) = 3
      END IF

      RETURN
      END
*DODCHK
      SUBROUTINE DODCHK
     +   (N,M,NP,NQ,
     +   ISODR,ANAJAC,IMPLCT,
     +   IFIXB,
     +   LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LDY,
     +   LWORK,LWKMN,LIWORK,LIWKMN,
     +   SCLB,SCLD,STPB,STPD,
     +   INFO)
C***BEGIN PROLOGUE  DODCHK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING
C            NONZERO VALUES OF ARGUMENT INFO 
C***END PROLOGUE  DODCHK

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ
      LOGICAL
     +   ANAJAC,IMPLCT,ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M)
      INTEGER
     +   IFIXB(NP)

C...LOCAL SCALARS
      INTEGER
     +   I,J,K,LAST,NPP

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   LAST:    THE LAST ROW OF THE ARRAY TO BE ACCESSED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY X.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATIONS.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUE FOR DELTA.
C   STPB:    THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA.
C   STPD:    THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA.


C***FIRST EXECUTABLE STATEMENT  DODCHK


C  FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED

      IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN
         NPP = NP
      ELSE
         NPP = 0
         DO 10 K=1,NP
            IF (IFIXB(K).NE.0) THEN
               NPP = NPP + 1
            END IF
   10    CONTINUE
      END IF

C  CHECK PROBLEM SPECIFICATION PARAMETERS

      IF (N.LE.0 .OR. 
     +    M.LE.0 .OR. 
     +    (NPP.LE.0 .OR. NPP.GT.N) .OR.
     +    (NQ.LE.0)) THEN

         INFO = 10000
         IF (N.LE.0) THEN
            INFO = INFO + 1000
         END IF
         IF (M.LE.0) THEN
            INFO = INFO + 100
         END IF
         IF (NPP.LE.0 .OR. NPP.GT.N) THEN
            INFO = INFO + 10
         END IF
         IF (NQ.LE.0) THEN
            INFO = INFO + 1
         END IF

         RETURN

      END IF

C  CHECK DIMENSION SPECIFICATION PARAMETERS

      IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR.
     +    (LDX.LT.N) .OR.
     +    (LDWE.NE.1 .AND. LDWE.LT.N) .OR.
     +    (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR.
     +    (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR.
     +    (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR.
     +    (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR.
     +    (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR.
     +    (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR.
     +    (LWORK.LT.LWKMN) .OR. 
     +    (LIWORK.LT.LIWKMN)) THEN

         INFO = 20000
         IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN
            INFO = INFO + 1000
         END IF
         IF (LDX.LT.N) THEN
            INFO = INFO + 2000
         END IF

         IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR.
     +       (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN
            INFO = INFO + 100
         END IF
         IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. 
     +                    (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN
            INFO = INFO + 200
         END IF

         IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN
            INFO = INFO + 10
         END IF
         IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN
            INFO = INFO + 20
         END IF
         IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN
            INFO = INFO + 40
         END IF

         IF (LWORK.LT.LWKMN) THEN
            INFO = INFO + 1
         END IF
         IF (LIWORK.LT.LIWKMN) THEN
            INFO = INFO + 2
         END IF
         RETURN

      END IF

C  CHECK DELTA SCALING

      IF (ISODR .AND. SCLD(1,1).GT.0) THEN
         IF (LDSCLD.GE.N) THEN
            LAST = N
         ELSE
            LAST = 1
         END IF
         DO 120 J=1,M
            DO 110 I=1,LAST
               IF (SCLD(I,J).LE.0) THEN
                  INFO = 30200
                  GO TO 130
               END IF
  110       CONTINUE
  120    CONTINUE
      END IF
  130 CONTINUE

C  CHECK BETA SCALING

      IF (SCLB(1).GT.0) THEN
         DO 210 K=1,NP
            IF (SCLB(K).LE.0) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 30100
               ELSE
                  INFO = INFO + 100
               END IF
               GO TO 220
            END IF
  210    CONTINUE
      END IF
  220 CONTINUE

C  CHECK DELTA FINITE DIFFERENCE STEP SIZES

      IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN
         IF (LDSTPD.GE.N) THEN
            LAST = N
         ELSE
            LAST = 1
         END IF
         DO 320 J=1,M
            DO 310 I=1,LAST
               IF (STPD(I,J).LE.0) THEN
                  IF (INFO.EQ.0) THEN
                     INFO = 32000
                  ELSE
                     INFO = INFO + 2000
                  END IF
                  GO TO 330
               END IF
  310       CONTINUE
  320    CONTINUE
      END IF
  330 CONTINUE

C  CHECK BETA FINITE DIFFERENCE STEP SIZES

      IF (ANAJAC .AND. STPB(1).GT.0) THEN
         DO 410 K=1,NP
            IF (STPB(K).LE.0) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 31000
               ELSE
                  INFO = INFO + 1000
               END IF
               GO TO 420
            END IF
  410    CONTINUE
      END IF
  420 CONTINUE

      RETURN
      END
*DODCNT
      SUBROUTINE DODCNT
     +   (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODCNT
C***REFER TO   DODR,DODRC
C***ROUTINES CALLED  DODDRV
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  DOUBLE PRECISION DRIVER ROUTINE FOR FINDING
C            THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 
C            REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 
C            SQUARES (OLS) SOLUTION
C***END PROLOGUE  DODCNT

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ
      LOGICAL
     +   SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO
      INTEGER
     +   IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5,
     +   MAXITI,MAXIT1
      LOGICAL
     +   DONE,FSTITR,HEAD,IMPLCT,PRTPEN

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   PNLTY(1,1,1)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODDRV

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DMPREC
      EXTERNAL
     +   DMPREC

C...DATA STATEMENTS
      DATA
     +   PCHECK,PSTART,PFAC,ZERO,ONE,THREE
     +   /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   CNVTOL:  THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS.
C   DONE:    THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS 
C            BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE).
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPRINT:  THE PRINT CONTROL VARIABLES.
C   IPRNTI:  THE PRINT CONTROL VARIABLES.
C   IPR1:    THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR2:    THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR3:    THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE.
C   IPR4:    THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOB1:    THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB2:    THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB3:    THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB4:    THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   JOB5:    THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM 
C            INITIALIZATION AND COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXITI:  FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR
C            THE CURRENT PENALTY PARAMETER VALUE.
C   MAXIT1:  FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR
C            THE NEXT PENALTY PARAMETER VALUE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   ONE:     THE VALUE 1.0D0.
C   PARTOL:  THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PCHECK:  THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED
C            BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED.
C   PFAC:    THE FACTOR FOR INCREASING THE PENALTY PARAMETER.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PRTPEN:  THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE
C            PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT
C            (PRTPEN=FALSE).
C   PSTART:  THE FACTOR FOR INCREASING THE PENALTY PARAMETER.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO DELTA.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL
C            (SHORT=.FALSE.).
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   THREE:   THE VALUE 3.0D0.
C   TSTIMP:  THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL
C            VALUES AND THE SOLUTION.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   X:       THE INDEPENDENT VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODCNT


      IMPLCT = MOD(JOB,10).EQ.1
      FSTITR = .TRUE.
      HEAD   = .TRUE.
      PRTPEN = .FALSE.
 
      IF (IMPLCT) THEN 

C  SET UP FOR IMPLICIT PROBLEM

         IF (IPRINT.GE.0) THEN
            IPR1   = MOD(IPRINT,10000)/1000
            IPR2   = MOD(IPRINT,1000)/100
            IPR2F  = MOD(IPRINT,100)/10
            IPR3   = MOD(IPRINT,10)
         ELSE
            IPR1   = 2
            IPR2   = 0
            IPR2F  = 0
            IPR3   = 1
         END IF
         IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 

         JOB5   = MOD(JOB,100000)/10000
         JOB4   = MOD(JOB,10000)/1000
         JOB3   = MOD(JOB,1000)/100
         JOB2   = MOD(JOB,100)/10
         JOB1   = MOD(JOB,10)
         JOBI   = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1

         IF (WE(1,1,1).LE.ZERO) THEN
            PNLTY(1,1,1)  = -PSTART
         ELSE
            PNLTY(1,1,1)  = -WE(1,1,1)
         END IF

         IF (PARTOL.LT.ZERO) THEN
            CNVTOL = DMPREC()**(ONE/THREE)
         ELSE
            CNVTOL = MIN(PARTOL,ONE)
         END IF

         IF (MAXIT.GE.1) THEN
            MAXITI = MAXIT
         ELSE
            MAXITI = 100
         END IF

         DONE   = MAXITI.EQ.0
         PRTPEN = .TRUE.

   10    CONTINUE
            CALL DODDRV   
     +           (SHORT,HEAD,FSTITR,PRTPEN, 
     +           FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +           PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +           JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI,
     +           IPRNTI,LUNERR,LUNRPT,
     +           STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +           WORK,LWORK,IWORK,LIWORK,
     +           MAXIT1,TSTIMP, INFO) 

            IF (DONE) THEN
               RETURN
            ELSE
               DONE = MAXIT1.LE.0 .OR.
     +                (ABS(PNLTY(1,1,1)).GE.PCHECK .AND.  
     +                 TSTIMP.LE.CNVTOL)
            END IF

            IF (DONE) THEN
               IF (TSTIMP.LE.CNVTOL) THEN
                  INFO = (INFO/10)*10 + 2
               ELSE
                  INFO = (INFO/10)*10 + 4
               END IF
               JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1
               MAXITI = 0
               IPRNTI = IPR3
            ELSE
               PRTPEN = .TRUE.
               PNLTY(1,1,1) = PFAC*PNLTY(1,1,1)
               JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1
               MAXITI = MAXIT1
               IPRNTI = 0000 + IPR2*100 + IPR2F*10 
            END IF
         GO TO 10
      ELSE        
         CALL DODDRV
     +        (SHORT,HEAD,FSTITR,PRTPEN, 
     +        FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +        WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +        JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +        IPRINT,LUNERR,LUNRPT,
     +        STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +        WORK,LWORK,IWORK,LIWORK,
     +        MAXIT1,TSTIMP, INFO)
      END IF

      RETURN

      END
*DODDRV
      SUBROUTINE DODDRV
     +   (SHORT,HEAD,FSTITR,PRTPEN, 
     +   FCN,  N,M,NP,NQ, BETA, Y,LDY,X,LDX,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX,
     +   JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD,
     +   WORK,LWORK,IWORK,LIWORK,
     +   MAXIT1,TSTIMP, INFO)
C***BEGIN PROLOGUE  DODDRV
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS,
C                    DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN,
C                    DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN
C            PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION
C            (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS)
C***END PROLOGUE  DODDRV

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC,TSTIMP
      INTEGER
     +   INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,
     +   LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1,
     +   N,NDIGIT,NP,NQ
      LOGICAL
     +   FSTITR,HEAD,PRTPEN,SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M),
     +   WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK),
     +   X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   EPSMAC,ETA,P5,ONE,TEN,ZERO
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI,
     +   DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI,
     +   IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN,
     +   LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI,
     +   NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI,
     +   NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,
     +   VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK,
     +   DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY

C...DATA STATEMENTS
      DATA
     +   ZERO,P5,ONE,TEN
     +   /0.0D0,0.5D0,1.0D0,10.0D0/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT
C            (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 
C            COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY F.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   I:       AN INDEX VARIABLE.
C   IDFI:    THE LOCATION IN ARRAY IWORK OF VARIABLE IDF.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED
C            TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   INT2I:   THE IN ARRAY IWORK OF VARIABLE INT2.
C   IPRINI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT.
C   IPRINT:  THE PRINT CONTROL VARIABLE.
C   IRANKI:  THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP.
C   IWORK:   THE INTEGER WORK SPACE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOBI:    THE LOCATION IN ARRAY IWORK OF VARIABLE JOB.
C   JPVTI:   THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT.
C   K:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDTTI:   THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LUNERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LUNRPI:  THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C   MAXIT1:  FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT 
C            PENALTY PARAMETER VALUE.
C   MAXITI:  THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT.
C   MSGB:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB.
C   MSGD:    THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NDIGIT:  THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS
C            SUPPLIED BY THE USER.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NETAI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NETA.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NFEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV.
C   NITERI:  THE LOCATION IN ARRAY IWORK OF VARIABLE NITER.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NJEVI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV.
C   NNZW:    THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS.
C   NNZWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NPPI:    THE LOCATION IN ARRAY IWORK OF VARIABLE NPP.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NROWI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NROW.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES,
C            SET BY DJCK.
C   NTOLI:   THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   ONE:     THE VALUE 1.0D0.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS 
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   P5:      THE VALUE 0.5D0.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCOND.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SCLB:    THE SCALING VALUES FOR BETA.
C   SCLD:    THE SCALING VALUES FOR DELTA.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL 
C            (SHORT=FALSE).
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   STPB:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA.
C   STPD:    THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TEN:     THE VALUE 10.0D0.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TSTIMP:  THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL
C            VALUES AND THE SOLUTION.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WRK:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK,
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSSI:    THE LOCATION IN ARRAY WORK OF VARIABLE WSS.
C   WSSDEI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL.
C   WSSEPI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODDRV


C  INITIALIZE NECESSARY VARIABLES

      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)

C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C  (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF)

      CALL DIWINF(M,NP,NQ,
     +            MSGB,MSGD,JPVTI,ISTOPI,
     +            NNZWI,NPPI,IDFI,
     +            JOBI,IPRINI,LUNERI,LUNRPI,
     +            NROWI,NTOLI,NETAI,
     +            MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI,
     +            LIWKMN)

C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C  (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE 
C  ARE HANDLED REASONABLY BY DWINF)

      CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +           DELTAI,FI,XPLUSI,FNI,SDI,VCVI,
     +           RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +           OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +           PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +           BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +           FSI,FJACBI,WE1I,DIFFI,
     +           DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +           WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +           LWKMN)
      IF (ISODR) THEN
         WRK = WRK1I
         LWRK = N*M*NQ + N*NQ
      ELSE
         WRK = WRK2I
         LWRK = N*NQ
      END IF

C  UPDATE THE PENALTY PARAMETERS 
C  (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE)
      IF (RESTRT .AND. IMPLCT) THEN
         WE(1,1,1)  = MAX(WORK(WE1I)**2,ABS(WE(1,1,1)))
         WORK(WE1I) = -SQRT(ABS(WE(1,1,1)))
      END IF

      IF (RESTRT) THEN

C  RESET MAXIMUM NUMBER OF ITERATIONS

         IF (MAXIT.GE.0) THEN
            IWORK(MAXITI) = IWORK(NITERI) + MAXIT
         ELSE
            IWORK(MAXITI) = IWORK(NITERI) + 10
         END IF

         IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN
            INFO = 0
         END IF

         IF (JOB.GE.0) IWORK(JOBI) = JOB
         IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT
         IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL
         IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL

         WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI)

         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
         ELSE
            CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
         END IF
         CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N)
         WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1)
         WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI)

      ELSE

C  PERFORM ERROR CHECKING

         INFO = 0

         CALL DODCHK(N,M,NP,NQ,
     +               ISODR,ANAJAC,IMPLCT,
     +               IFIXB,
     +               LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +               LDY,
     +               LWORK,LWKMN,LIWORK,LIWKMN,
     +               SCLB,SCLD,STPB,STPD,
     +               INFO)
         IF (INFO.GT.0) THEN
            GO TO 50
         END IF

C  INITIALIZE WORK VECTORS AS NECESSARY

         DO 10 I=N*M+N*NQ+1,LWORK
            WORK(I) = ZERO
   10    CONTINUE
         DO 20 I=1,LIWORK
            IWORK(I) = 0
   20    CONTINUE

         CALL DINIWK(N,M,NP,
     +               WORK,LWORK,IWORK,LIWORK,
     +               X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +               BETA,SCLB,
     +               SSTOL,PARTOL,MAXIT,TAUFAC,
     +               JOB,IPRINT,LUNERR,LUNRPT,
     +               EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI,
     +               JOBI,IPRINI,LUNERI,LUNRPI,
     +               SSFI,TTI,LDTTI,DELTAI)

         IWORK(MSGB) = -1
         IWORK(MSGD) = -1
         WORK(TAUI)   = -WORK(TAUFCI)

C  SET UP FOR PARAMETER ESTIMATION -
C  PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES
C  AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY

         CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB)
         CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB)
         NPP = IWORK(NPPI)

C  CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, 
C  SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS

         CALL DFCTRW(N,M,NQ,NPP,
     +               ISODR,
     +               WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +               WORK(WRK2I),WORK(WRK4I),
     +               WORK(WE1I),NNZW,INFO)
         IWORK(NNZWI) = NNZW

         IF (INFO.NE.0) THEN
            GO TO 50
         END IF

C  EVALUATE THE PREDICTED VALUES AND
C               WEIGHTED EPSILONS AT THE STARTING POINT
 
         CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB)
         CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N)
         ISTOP = 0
         CALL FCN(N,M,NP,NQ,
     +            N,M,NP,
     +            BETA,WORK(XPLUSI),
     +            IFIXB,IFIXX,LDIFX,
     +            002,WORK(FNI),WORK(WRK6I),WORK(WRK1I),
     +            ISTOP)
         IWORK(ISTOPI) = ISTOP
         IF (ISTOP.EQ.0) THEN
            IWORK(NFEVI) = IWORK(NFEVI) + 1
            IF (IMPLCT) THEN
               CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
            ELSE
               CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
            END IF
            CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N)
         ELSE 
            INFO = 52000
            GO TO 50
         END IF

C  COMPUTE NORM OF THE INITIAL ESTIMATES

         CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP,
     +              WORK(WRK),NPP)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N,
     +                 WORK(WRK+NPP),N)
            WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1)
         ELSE
            WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1)
         END IF
 
C  COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS
 
         WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N)
            WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1)
         ELSE
            WORK(WSSDEI) = ZERO
         END IF
         WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI)

C  SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS

         NROW = -1
         CALL DSETN(N,M,WORK(XPLUSI),N,NROW)
         IWORK(NROWI) = NROW

C  SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS

         EPSMAC = WORK(EPSMAI)
         IF (NDIGIT.LT.2) THEN
            IWORK(NETAI) = -1
            NFEV = IWORK(NFEVI)
            CALL DETAF(FCN,
     +                 N,M,NP,NQ,
     +                 WORK(XPLUSI),BETA,EPSMAC,NROW,
     +                 WORK(BETANI),WORK(FNI),
     +                 IFIXB,IFIXX,LDIFX,
     +                 ISTOP,NFEV,ETA,NETA,
     +                 WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I))
            IWORK(ISTOPI) = ISTOP
            IWORK(NFEVI) = NFEV
            IF (ISTOP.NE.0) THEN
               INFO = 53000
               IWORK(NETAI) = 0
               WORK(ETAI) = ZERO
               GO TO 50
            ELSE
               IWORK(NETAI) = -NETA
               WORK(ETAI) = ETA
            END IF
         ELSE
            IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC)))
            WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT))
         END IF

C  CHECK DERIVATIVES IF NECESSARY

         IF (CHKJAC .AND. ANAJAC) THEN
            NTOL = -1
            NFEV = IWORK(NFEVI)
            NJEV = IWORK(NJEVI)
            NETA = IWORK(NETAI)
            LDTT = IWORK(LDTTI)
            ETA = WORK(ETAI)
            EPSMAC = WORK(EPSMAI)
            CALL DJCK(FCN,
     +                N,M,NP,NQ,
     +                BETA,WORK(XPLUSI),
     +                IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD,
     +                WORK(SSFI),WORK(TTI),LDTT,
     +                ETA,NETA,NTOL,NROW,ISODR,EPSMAC,
     +                WORK(FNI),WORK(FJACBI),WORK(FJACDI),
     +                IWORK(MSGB),IWORK(MSGD),WORK(DIFFI),
     +                ISTOP,NFEV,NJEV,
     +                WORK(WRK1I),WORK(WRK2I),WORK(WRK6I))
            IWORK(ISTOPI) = ISTOP
            IWORK(NFEVI) = NFEV
            IWORK(NJEVI) = NJEV
            IWORK(NTOLI) = NTOL
            IF (ISTOP.NE.0) THEN
               INFO = 54000
            ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN
               INFO = 40000
            END IF
         ELSE

C  INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED
            IWORK(MSGB) = -1
            IWORK(MSGD) = -1
         END IF

C  PRINT APPROPRIATE ERROR MESSAGES

   50    IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN
            IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN
               CALL DODPER
     +            (INFO,LUNERR,SHORT,
     +            N,M,NP,NQ,
     +            LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +            LWKMN,LIWKMN,
     +            WORK(FJACBI),WORK(FJACDI),
     +            WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD),
     +            WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI))
            END IF

C  SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS

            IF (INFO.EQ.40000) THEN
               IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN
                  IF (IWORK(MSGB).EQ.2) THEN
                     INFO = INFO + 1000
                  END IF
                  IF (IWORK(MSGD).EQ.2) THEN
                     INFO = INFO + 100
                  END IF
               ELSE 
                  INFO = 0
               END IF
            END IF
            IF (INFO.NE.0) THEN
               RETURN
            END IF
         END IF
      END IF

C  SAVE THE INITIAL VALUES OF BETA
      CALL DCOPY(NP,BETA,1,WORK(BETA0I),1)

C  FIND LEAST SQUARES SOLUTION

      CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1)
      LDTT = IWORK(LDTTI)
      CALL DODMN(HEAD,FSTITR,PRTPEN,
     +           FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX,
     +           WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD,
     +           IFIXB,IFIXX,LDIFX,
     +           WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI),
     +           WORK(DELTAI),WORK(DELTNI),WORK(DELTSI),
     +           WORK(TI),WORK(FI),WORK(FNI),WORK(FSI),
     +           WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD),
     +           WORK(SSFI),WORK(SSI),WORK(TTI),LDTT,
     +           STPB,STPD,LDSTPD,
     +           WORK(XPLUSI),WORK(WRK),LWRK,
     +           WORK,LWORK,IWORK,LIWORK,INFO)
      MAXIT1 = IWORK(MAXITI) - IWORK(NITERI)
      TSTIMP = ZERO
      DO 100 K=1,NP
         IF (BETA(K).EQ.ZERO) THEN
            TSTIMP = MAX(TSTIMP,
     +                   ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K))
         ELSE
            TSTIMP = MAX(TSTIMP,
     +                   ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K)))
         END IF
  100 CONTINUE

      RETURN

      END
*DODLM
      SUBROUTINE DODLM
     +   (N,M,NP,NQ,NPP,
     +   F,FJACB,FJACD,
     +   WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +   ALPHA2,TAU,EPSFCN,ISODR,
     +   TFJACB,OMEGA,U,QRAUX,JPVT,
     +   S,T,NLMS,RCOND,IRANK,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODLM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDOT,DNRM2,DODSTP,DSCALE,DWGHT
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T
C            USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT
C            ALGORITHM
C***END PROLOGUE  DODLM

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA2,EPSFCN,RCOND,TAU
      INTEGER
     +   IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP),
     +   T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M),
     +   WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M)
      INTEGER
     +   JPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO
      INTEGER
     +   I,IWRK,J,K,L
      LOGICAL
     +   FORVCV

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODSTP,DSCALE,DWGHT

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MAX,MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P001,P1
     +   /0.0D0,0.001D0,0.1D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHAN:  THE NEW LEVENBERG-MARQUARDT PARAMETER.
C   ALPHA1:  THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER.
C   ALPHA2:  THE CURRENT LEVENBERG-MARQUARDT PARAMETER.
C   BOT:     THE LOWER LIMIT FOR SETTING ALPHA.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN 
C            SUBROUTINE DODSTP.
C   IWRK:    AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   JPVT:    THE PIVOT VECTOR.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NLMS:    THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OMEGA:   THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2)  WHERE
C            P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   P001:    THE VALUE 0.001D0
C   P1:      THE VALUE 0.1D0
C   PHI1:    THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   PHI2:    THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
C   S:       THE STEP FOR BETA.
C   SA:      THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2).
C   SS:      THE SCALING VALUES USED FOR THE UNFIXED BETAS.
C   T:       THE STEP FOR DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TFJACB:  THE ARRAY OMEGA*FJACB.
C   TOP:     THE UPPER LIMIT FOR SETTING ALPHA.
C   TT:      THE SCALE USED FOR THE DELTA'S.
C   U:       THE APPROXIMATE NULL VECTOR FOR TFJACB.
C   WD:      THE DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS, 
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODLM

      FORVCV = .FALSE.
      ISTOPC = 0

C  COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0)

      ALPHA1 = ZERO
      CALL DODSTP(N,M,NP,NQ,NPP,
     +            F,FJACB,FJACD,
     +            WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +            ALPHA1,EPSFCN,ISODR,
     +            TFJACB,OMEGA,U,QRAUX,JPVT,
     +            S,T,PHI1,IRANK,RCOND,FORVCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
      IF (ISTOPC.NE.0) THEN
         RETURN
      END IF

C  INITIALIZE TAU IF NECESSARY

      IF (TAU.LT.ZERO) THEN
         TAU = ABS(TAU)*PHI1
      END IF

C  CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL

      IF ((PHI1-TAU).LE.P1*TAU) THEN
         NLMS = 1
         ALPHA2 = ZERO
         RETURN
      END IF

C  FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION -
C  FIND LOCALLY CONSTRAINED OPTIMAL STEP

      PHI1 = PHI1 - TAU

C  INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA

      BOT = ZERO

      DO 30 K=1,NPP
         DO 20 L=1,NQ
            DO 10 I=1,N
               TFJACB(I,L,K) = FJACB(I,K,L)
   10       CONTINUE
   20    CONTINUE
         WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1)
   30 CONTINUE
      CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP)

      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N)
         IWRK = NPP
         DO 50 J=1,M
            DO 40 I=1,N
               IWRK = IWRK + 1
               WRK(IWRK) = WRK(IWRK) + 
     +                     DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N)
   40       CONTINUE
   50    CONTINUE
         CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N)
         TOP = DNRM2(NPP+N*M,WRK,1)/TAU
      ELSE
         TOP = DNRM2(NPP,WRK,1)/TAU
      END IF

      IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN
         ALPHA2 = P001*TOP
      END IF

C  MAIN LOOP

      DO 60 I=1,10

C  COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR
C  CURRENT VALUE OF ALPHA

         CALL DODSTP(N,M,NP,NQ,NPP,
     +               F,FJACB,FJACD,
     +               WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +               ALPHA2,EPSFCN,ISODR,
     +               TFJACB,OMEGA,U,QRAUX,JPVT,
     +               S,T,PHI2,IRANK,RCOND,FORVCV,
     +               WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
         IF (ISTOPC.NE.0) THEN
            RETURN
         END IF
         PHI2 = PHI2-TAU

C  CHECK WHETHER CURRENT STEP IS OPTIMAL

         IF (ABS(PHI2).LE.P1*TAU .OR.
     +      (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN
            NLMS = I+1
            RETURN
         END IF

C  CURRENT STEP IS NOT OPTIMAL

C  UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA

         IF (PHI1-PHI2.EQ.ZERO) THEN
            NLMS = 12
            RETURN
         END IF
         SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2)
         IF (PHI2.LT.ZERO) THEN
            TOP = MIN(TOP,ALPHA2)
         ELSE
            BOT = MAX(BOT,ALPHA2)
         END IF
         IF (PHI1*PHI2.GT.ZERO) THEN
            BOT = MAX(BOT,ALPHA2-SA)
         ELSE
            TOP = MIN(TOP,ALPHA2-SA)
         END IF

         ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU
         IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN
            ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT))
         END IF

C  GET READY FOR NEXT ITERATION

         ALPHA1 = ALPHA2
         ALPHA2 = ALPHAN
         PHI1 = PHI2
   60 CONTINUE

C  SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS

      NLMS = 12

      RETURN
      END
*DODMN
      SUBROUTINE DODMN
     +   (HEAD,FSTITR,PRTPEN, 
     +   FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX,
     +   WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS,
     +   T,F,FN,FS,FJACB,MSGB,FJACD,MSGD,
     +   SSF,SS,TT,LDTT,STPB,STPD,LDSTPD,
     +   XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO)
C***BEGIN PROLOGUE  DODMN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM,
C                    DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  ITERATIVELY COMPUTE LEAST SQUARES SOLUTION
C***END PROLOGUE  DODMN

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LIWORK,LWORK,LWRK,M,N,NP,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP),
     +   DELTA(N,M),DELTAN(N,M),DELTAS(N,M),
     +   F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ),
     +   S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M),
     +   T(N,M),TT(LDTT,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),
     +   WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK),
     +   MSGB(NQ*NP+1),MSGD(NQ*M+1)
      LOGICAL
     +   FSTITR,HEAD,PRTPEN

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE,
     +   P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS,
     +   RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC,
     +   TEMP,TEMP1,TEMP2,TSNORM,ZERO
      INTEGER
     +   I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK,
     +   ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT,
     +   MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX,
     +   SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6
      LOGICAL
     +   ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV,
     +   IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   WSS(3)

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT,DNRM2
      EXTERNAL
     +   DDOT,DNRM2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DACCES,DCOPY,DEVJAC,DFLAGS,
     +   DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN,MOD,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,P0001,P1,P25,P5,P75,ONE
     +   /0.0D0,0.00010D0,0.10D0,0.250D0,
     +   0.50D0,0.750D0,1.0D0/
      DATA
     +   LUDFLT
     +   /6/

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACCESS:  THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 
C            ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN 
C            THEM (ACCESS=FALSE).
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ACTRS:   THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAC:   THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   BETAN:   THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   BETAS:   THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   CNVPAR:  THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS 
C            ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE).
C   CNVSS:   THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE
C            WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DELTAN:  THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DELTAS:  THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DIRDER:  THE DIRECTIONAL DERIVATIVE.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX
C            SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   ETA:     THE RELATIVE NOISE IN THE FUNCTION RESULTS.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FN:      THE NEW PREDICTED VALUES FROM THE FUNCTION.
C   FS:      THE SAVED PREDICTED VALUES FROM THE FUNCTION.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFLAG:   THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   INT2:    THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN.
C   INTDBL:  THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE 
C            USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE).
C   IPR:     THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT.
C   IPR1:    THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE INITIAL SUMMARY REPORT.
C   IPR2:    THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE ITERATION REPORT.
C   IPR2F:   THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
C   IPR3:    THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT,
C            WHICH CONTROLS THE FINAL SUMMARY REPORT.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. 
C   IWORK:   THE INTEGER WORK SPACE.
C   IWRK:    AN INDEX VARIABLE.
C   J:       AN INDEX VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JPVT:    THE STARTING LOCATION IN IWORK OF ARRAY JPVT.
C   L:       AN INDEX VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE AND WE1.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE AND WE1.
C   LIWORK:  THE LENGTH OF VECTOR IWORK.
C   LOOPED:  A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP
C            HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE
C            ENOUGH THE COMPUTATIONS WILL BE STOPPED.
C   LSTEP:   THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS 
C            BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE).
C   LUDFLT:  THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION
C            REPORTS TO THE SCREEN.
C   LUNR:    THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   LWORK:   THE LENGTH OF VECTOR WORK.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS TAKEN.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NLMS:    THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NPR:     THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OLMAVG:  THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 
C            ITERATION.
C   OMEGA:   THE STARTING LOCATION IN WORK OF ARRAY OMEGA.
C   ONE:     THE VALUE 1.0D0.
C   P0001:   THE VALUE 0.0001D0.
C   P1:      THE VALUE 0.1D0.
C   P25:     THE VALUE 0.25D0.
C   P5:      THE VALUE 0.5D0.
C   P75:     THE VALUE 0.75D0.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRERS:   THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO
C            BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   QRAUX:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RATIO:   THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED
C            RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RNORM:   THE NORM OF THE WEIGHTED ERRORS.
C   RNORMN:  THE NEW NORM OF THE WEIGHTED ERRORS.
C   RNORMS:  THE SAVED NORM OF THE WEIGHTED ERRORS.
C   RSS:     THE RESIDUAL SUM OF SQUARES.
C   RVAR:    THE RESIDUAL VARIANCE.
C   S:       THE STEP FOR BETA.
C   SD:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SS:      THE SCALING VALUES USED FOR THE UNFIXED BETAS.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO EACH BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   T:       THE STEP FOR DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TEMP:    A TEMPORARY STORAGE LOCATION.
C   TEMP1:   A TEMPORARY STORAGE LOCATION.
C   TEMP2:   A TEMPORARY STORAGE LOCATION.
C   TSNORM:  THE NORM OF THE SCALED STEP.
C   TT:      THE SCALING VALUES USED FOR DELTA.
C   U:       THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCV:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE:      THE EPSILON WEIGHTS.
C   WE1:     THE SQUARE ROOT OF THE EPSILON WEIGHTS.
C   WD:      THE DELTA WEIGHTS.
C   WORK:    THE DOUBLE PRECISION WORK SPACE.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   WRK:     A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2
C   WRK1:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   X:       THE EXPLANATORY VARIABLE.
C   XPLUSD:  THE VALUES OF X + DELTA.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODMN


C  INITIALIZE NECESSARY VARIABLES

      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
      ACCESS = .TRUE.
      CALL DACCES(N,M,NP,NQ,LDWE,LD2WE,
     +            WORK,LWORK,IWORK,LIWORK,
     +            ACCESS,ISODR,
     +            JPVT,OMEGA,U,QRAUX,SD,VCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +            NNZW,NPP,
     +            JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +            LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +            WSS,RVAR,IDF,
     +            TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +            RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)
      RNORM = SQRT(WSS(1))

      DIDVCV = .FALSE.
      INTDBL = .FALSE.
      LSTEP = .TRUE.

C  PRINT INITIAL SUMMARY IF DESIRED

      IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
         IFLAG = 1
         IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN
            NPR = 2
         ELSE
            NPR = 1
         END IF
         IF (IPR1.GE.6) THEN
            IPR = 2 
         ELSE
            IPR = 2 - MOD(IPR1,2)
         END IF
         LUNR = LUNRPT
         DO 10 I=1,NPR
            CALL DODPCR(IPR,LUNR, 
     +                   HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                   N,M,NP,NQ,NPP,NNZW,
     +                   MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                   IFIXB,IFIXX,LDIFX,
     +                   SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                   WSS,RVAR,IDF,WORK(SD),
     +                   NITER,NFEV,NJEV,ACTRED,PRERED,
     +                   TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
            IF (IPR1.GE.5) THEN
               IPR = 2
            ELSE
               IPR = 1
            END IF
            LUNR = LUDFLT
   10    CONTINUE

      END IF

C  STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION

      IF (RNORM.EQ.ZERO) THEN
         INFO = 1
         OLMAVG = ZERO
         ISTOP = 0
         GO TO 150
      END IF

C  STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED

      IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN
         ISTOP = 0
         GO TO 150
      ELSE IF (NITER.GE.MAXIT) THEN
         INFO = 4
         ISTOP = 0
         GO TO 150
      END IF

C  MAIN LOOP

  100 CONTINUE
 
      NITER = NITER + 1
      RNORMS = RNORM
      LOOPED = 0

C  EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS)

      IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN
         ISTOP = 0
      ELSE
         CALL DEVJAC(FCN,
     +               ANAJAC,CDJAC, 
     +               N,M,NP,NQ,
     +               BETAC,BETA,STPB, 
     +               IFIXB,IFIXX,LDIFX,
     +               X,LDX,DELTA,XPLUSD,STPD,LDSTPD, 
     +               SSF,TT,LDTT,NETA,FS,
     +               T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
     +               FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +               NJEV,NFEV,ISTOP,INFO)
      END IF
      IF (ISTOP.NE.0) THEN
         INFO = 51000
         GO TO 200
      ELSE IF (INFO.EQ.50300) THEN
         GO TO 200
      END IF

C  SUB LOOP FOR
C     INTERNAL DOUBLING OR
C     COMPUTING NEW STEP WHEN OLD FAILED

  110 CONTINUE

C  COMPUTE STEPS S AND T

      IF (LOOPED.GT.100) THEN
         INFO = 60000
         GO TO 200
      ELSE
         LOOPED = LOOPED + 1
         CALL DODLM(N,M,NP,NQ,NPP,
     +              F,FJACB,FJACD,
     +              WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +              ALPHA,TAU,ETA,ISODR,
     +              WORK(WRK6),WORK(OMEGA),
     +              WORK(U),WORK(QRAUX),IWORK(JPVT),
     +              S,T,NLMS,RCOND,IRANK,
     +              WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4),
     +              WORK(WRK5),WRK,LWRK,ISTOPC)
      END IF
      IF (ISTOPC.NE.0) THEN
         INFO = ISTOPC
         GO TO 200
      END IF
      OLMAVG = OLMAVG+NLMS

C  COMPUTE BETAN = BETAC + S
C          DELTAN = DELTA + T

      CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP)
      IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N)

C  COMPUTE NORM OF SCALED STEPS S AND T (TSNORM)

      CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
      IF (ISODR) THEN
         CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
         TSNORM = DNRM2(NPP+N*M,WRK,1)
      ELSE 
         TSNORM = DNRM2(NPP,WRK,1)
      END IF

C  COMPUTE SCALED PREDICTED REDUCTION

      IWRK = 0
      DO 130 L=1,NQ
         DO 120 I=1,N
           IWRK = IWRK + 1
           WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1)
           IF (ISODR) WRK(IWRK) = WRK(IWRK) + 
     +                            DDOT(M,FJACD(I,1,L),N,T(I,1),N)
  120    CONTINUE
  130 CONTINUE
      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N)
         TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1)
         TEMP1 = SQRT(TEMP1)/RNORM
      ELSE
         TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM
      END IF
      TEMP2 = SQRT(ALPHA)*TSNORM/RNORM
      PRERED = TEMP1**2+TEMP2**2/P5

      DIRDER = -(TEMP1**2+TEMP2**2)

C  EVALUATE PREDICTED VALUES AT NEW POINT

      CALL DUNPAC(NP,BETAN,BETA,IFIXB)
      CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N)
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         002,FN,WORK(WRK6),WORK(WRK1),
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      END IF

      IF (ISTOP.LT.0) THEN

C  SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN

         INFO = 51000
         GO TO 200
      ELSE IF (ISTOP.GT.0) THEN

C  SET NORM TO INDICATE STEP SHOULD BE REJECTED

         RNORMN = RNORM/(P1*P75)
      ELSE

C  COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN)

         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,FN,1,WRK,1)
         ELSE
            CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N)
         END IF
         CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N)
         IF (ISODR) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N)
            RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + 
     +                    DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1))
         ELSE
            RNORMN = DNRM2(N*NQ,WRK,1)
         END IF
      END IF

C  COMPUTE SCALED ACTUAL REDUCTION

      IF (P1*RNORMN.LT.RNORM) THEN
         ACTRED = ONE - (RNORMN/RNORM)**2
      ELSE
         ACTRED = -ONE
      END IF

C  COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION

      IF(PRERED .EQ. ZERO) THEN
         RATIO = ZERO
      ELSE
         RATIO = ACTRED/PRERED
      END IF

C  CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE

      IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN
         ISTOP = 0
         TAU = TAU*P5
         ALPHA = ALPHA/P5
         CALL DCOPY(NPP,BETAS,1,BETAN,1)
         CALL DCOPY(N*M,DELTAS,1,DELTAN,1)
         CALL DCOPY(N*NQ,FS,1,FN,1)
         ACTRED = ACTRS
         PRERED = PRERS
         RNORMN = RNORMS
         RATIO = P5
      END IF

C  UPDATE STEP BOUND

      INTDBL = .FALSE.
      IF (RATIO.LT.P25) THEN
         IF (ACTRED.GE.ZERO) THEN
            TEMP = P5
         ELSE
            TEMP = P5*DIRDER/(DIRDER+P5*ACTRED)
         END IF
         IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN
            TEMP = P1
         END IF
         TAU = TEMP*MIN(TAU,TSNORM/P1)
         ALPHA = ALPHA/TEMP

      ELSE IF (ALPHA.EQ.ZERO) THEN
         TAU = TSNORM/P5

      ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN

C  STEP QUALIFIES FOR INTERNAL DOUBLING
C     - UPDATE TAU AND ALPHA
C     - SAVE INFORMATION FOR CURRENT POINT

         INTDBL = .TRUE.

         TAU = TSNORM/P5
         ALPHA = ALPHA*P5

         CALL DCOPY(NPP,BETAN,1,BETAS,1)
         CALL DCOPY(N*M,DELTAN,1,DELTAS,1)
         CALL DCOPY(N*NQ,FN,1,FS,1)
         ACTRS = ACTRED
         PRERS = PRERED
         RNORMS = RNORMN
      END IF

C  IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS

      IF (INTDBL .AND. TAU.GT.ZERO) THEN
         INT2 = INT2+1
         GO TO 110
      END IF

C  CHECK ACCEPTANCE

      IF (RATIO.GE.P0001) THEN
         CALL DCOPY(N*NQ,FN,1,FS,1)
         IF (IMPLCT) THEN
            CALL DCOPY(N*NQ,FS,1,F,1)
         ELSE
            CALL DXMY(N,NQ,FS,N,Y,LDY,F,N)
         END IF
         CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N)
         CALL DCOPY(NPP,BETAN,1,BETAC,1)
         CALL DCOPY(N*M,DELTAN,1,DELTA,1)
         RNORM = RNORMN
         CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP)
         IF (ISODR) THEN
            CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N)
            PNORM = DNRM2(NPP+N*M,WRK,1)
         ELSE
            PNORM = DNRM2(NPP,WRK,1)
         END IF
         LSTEP = .TRUE.
      ELSE
         LSTEP = .FALSE.
      END IF

C  TEST CONVERGENCE

      INFO = 0
      CNVSS = RNORM.EQ.ZERO
     +        .OR.
     +        (ABS(ACTRED).LE.SSTOL .AND.
     +         PRERED.LE.SSTOL      .AND.
     +         P5*RATIO.LE.ONE)
      CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT)
      IF (CNVSS)                            INFO = 1
      IF (CNVPAR)                           INFO = 2
      IF (CNVSS .AND. CNVPAR)               INFO = 3

C  PRINT ITERATION REPORT

      IF (INFO.NE.0 .OR. LSTEP) THEN
         IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN
            IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN
               IFLAG = 2
               CALL DUNPAC(NP,BETAC,BETA,IFIXB)
               WSS(1) = RNORM*RNORM
               IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN
                  NPR = 2
               ELSE
                  NPR = 1
               END IF
               IF (IPR2.GE.6) THEN
                  IPR = 2 
               ELSE
                  IPR = 2 - MOD(IPR2,2)
               END IF
               LUNR = LUNRPT
               DO 140 I=1,NPR
                  CALL DODPCR(IPR,LUNR,
     +                        HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                        N,M,NP,NQ,NPP,NNZW,
     +                        MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                        WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                        IFIXB,IFIXX,LDIFX,
     +                        SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                        JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                        WSS,RVAR,IDF,WORK(SD),
     +                        NITER,NFEV,NJEV,ACTRED,PRERED,
     +                        TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
                  IF (IPR2.GE.5) THEN
                     IPR = 2
                  ELSE
                     IPR = 1
                  END IF
                  LUNR = LUDFLT
  140          CONTINUE
               FSTITR = .FALSE.
               PRTPEN = .FALSE.
            END IF
         END IF
      END IF

C  CHECK IF FINISHED

      IF (INFO.EQ.0) THEN
         IF (LSTEP) THEN

C  BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET

            IF (NITER.GE.MAXIT) THEN
               INFO = 4
            ELSE
               GO TO 100
            END IF
         ELSE

C  STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET

            GO TO 110
         END IF
      END IF

  150 CONTINUE

      IF (ISTOP.GT.0) INFO = INFO + 100

C  STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER

      IF (IMPLCT) THEN
         CALL DCOPY(N*NQ,FS,1,F,1)
      ELSE
         CALL DXMY(N,NQ,FS,N,Y,LDY,F,N)
      END IF
      CALL DUNPAC(NP,BETAC,BETA,IFIXB)
      CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)

C  COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C  IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED

      IF (DOVCV .AND. ISTOP.EQ.0) THEN
            
C  RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
C  OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
C  TO COMPUTE COVARIANCE MATRIX

         IF (REDOJ) THEN
            CALL DEVJAC(FCN,
     +                   ANAJAC,CDJAC,
     +                   N,M,NP,NQ,
     +                   BETAC,BETA,STPB,
     +                   IFIXB,IFIXX,LDIFX,
     +                   X,LDX,DELTA,XPLUSD,STPD,LDSTPD,
     +                   SSF,TT,LDTT,NETA,FS,
     +                   T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
     +                   FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
     +                   NJEV,NFEV,ISTOP,INFO)


            IF (ISTOP.NE.0) THEN
               INFO = 51000
               GO TO 200
            ELSE IF (INFO.EQ.50300) THEN
               GO TO 200
            END IF
         END IF

         IF (IMPLCT) THEN
            CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
            RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
         ELSE
            RSS = RNORM*RNORM
         END IF
         IF (REDOJ .OR. NITER.GE.1) THEN
            CALL DODVCV(N,M,NP,NQ,NPP,
     +                  F,FJACB,FJACD,
     +                  WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA,
     +                  ETA,ISODR,
     +                  WORK(VCV),WORK(SD),
     +                  WORK(WRK6),WORK(OMEGA),
     +                  WORK(U),WORK(QRAUX),IWORK(JPVT),
     +                  S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB,
     +                  WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4),
     +                  WORK(WRK5),WRK,LWRK,ISTOPC)
            IF (ISTOPC.NE.0) THEN
               INFO = ISTOPC
               GO TO 200
            END IF
            DIDVCV = .TRUE.
         END IF

      END IF

C  SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS

  200 DO 210 I=0,NP-1
         WORK(WRK3+I) = IWORK(JPVT+I)
         IWORK(JPVT+I) = -2
  210 CONTINUE
      IF (REDOJ .OR. NITER.GE.1) THEN
         DO 220 I=0,NPP-1
            J = WORK(WRK3+I) - 1
            IF (I.LE.NPP-IRANK-1) THEN
               IWORK(JPVT+J) = 1
            ELSE 
               IWORK(JPVT+J) = -1
            END IF
  220    CONTINUE
         IF (NPP.LT.NP) THEN
            J = NPP-1
            DO 230 I=NP-1,0,-1
               IF (IFIXB(I+1).EQ.0) THEN
                  IWORK(JPVT+I) = 0
               ELSE
                  IWORK(JPVT+I) = IWORK(JPVT+J)
                  J = J - 1
               END IF
  230       CONTINUE
         END IF
      END IF

C  STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER

      IF (NITER.GE.1) THEN
         OLMAVG = OLMAVG/NITER
      ELSE
         OLMAVG = ZERO
      END IF

C  COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER

      CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N)
      WSS(3) = DDOT(N*NQ,WRK,1,WRK,1)
      IF (ISODR) THEN
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
         WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
      ELSE
         WSS(2) = ZERO
      END IF
      WSS(1) = WSS(2) + WSS(3)

      ACCESS = .FALSE.
      CALL DACCES(N,M,NP,NQ,LDWE,LD2WE,
     +            WORK,LWORK,IWORK,LIWORK,
     +            ACCESS,ISODR,
     +            JPVT,OMEGA,U,QRAUX,SD,VCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK6,
     +            NNZW,NPP,
     +            JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA,
     +            LUNRPT,IPR1,IPR2,IPR2F,IPR3,
     +            WSS,RVAR,IDF,
     +            TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG,
     +            RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP)

C  ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO

      IF (INFO.LE.9 .OR. INFO.GE.60000) THEN
         IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN
            INFO = INFO + 1000
         END IF
         IF (ISTOP.NE.0) THEN
            INFO = INFO + 100
         END IF
         IF (IRANK.GE.1) THEN
            IF (NPP.GT.IRANK) THEN
               INFO = INFO + 10
            ELSE
               INFO = INFO + 20
            END IF
         END IF
      END IF

C  PRINT FINAL SUMMARY

      IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN
         IFLAG = 3

         IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN
            NPR = 2
         ELSE
            NPR = 1
         END IF
         IF (IPR3.GE.6) THEN
            IPR = 2 
         ELSE
            IPR = 2 - MOD(IPR3,2)
         END IF
         LUNR = LUNRPT
         DO 240 I=1,NPR
            CALL DODPCR(IPR,LUNR, 
     +                  HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +                  N,M,NP,NQ,NPP,NNZW,
     +                  MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +                  WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +                  IWORK(JPVT),IFIXX,LDIFX,
     +                  SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +                  JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                  WSS,RVAR,IDF,WORK(SD),
     +                  NITER,NFEV,NJEV,ACTRED,PRERED,
     +                  TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
            IF (IPR3.GE.5) THEN
               IPR = 2
            ELSE
               IPR = 1
            END IF
            LUNR = LUDFLT
  240    CONTINUE
      END IF

      RETURN

      END
*DODPC1
      SUBROUTINE DODPC1
     +   (IPR,LUNRPT,
     +   ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ,
     +   MSGB1,MSGB,MSGD1,MSGD,
     +   N,M,NP,NQ,NPP,NNZW,
     +   X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD,
     +   Y,LDY,WE,LDWE,LD2WE,PNLTY,
     +   BETA,IFIXB,SSF,STPB,
     +   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   WSS,WSSDEL,WSSEPS)
C***BEGIN PROLOGUE  DODPC1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DHSTEP
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE INITIAL SUMMARY REPORT
C***END PROLOGUE  DODPC1

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS
      INTEGER
     +   IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
     +   LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M),
     +   TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M),
     +   Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP1,TEMP2,TEMP3,ZERO
      INTEGER
     +   I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L

C...LOCAL ARRAYS
      CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DHSTEP
      EXTERNAL
     +   DHSTEP


C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,MIN

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES 
C            (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 
C            (CHKJAC=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ITEMP:   A TEMPORARY INTEGER VALUE.
C   J:       AN INDEXING VARIABLE.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   JOB1:    THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB2:    THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB3:    THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB4:    THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   JOB5:    THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB.
C   L:       AN INDEXING VARIABLE.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C            A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY
C            ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED
C            BY THE USER.
C   NNZW:    THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   SSF:     THE SCALING VALUES FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TEMPC0:  A TEMPORARY CHARACTER*2 VALUE.
C   TEMPC1:  A TEMPORARY CHARACTER*5 VALUE.
C   TEMPC2:  A TEMPORARY CHARACTER*13 VALUE.
C   TEMP1:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TEMP2:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TEMP3:   A TEMPORARY DOUBLE PRECISION VALUE.
C   TT:      THE SCALING VALUES FOR DELTA.
C   WD:      THE DELTA WEIGHTS.
C   WE:      THE EPSILON WEIGHTS.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   WSSDEL:  THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS.
C   WSSEPS:  THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE RESPONSE VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODPC1


C  PRINT PROBLEM SIZE SPECIFICATION

      WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP


C  PRINT CONTROL VALUES

      JOB1 = JOB/10000
      JOB2 = MOD(JOB,10000)/1000
      JOB3 = MOD(JOB,1000)/100
      JOB4 = MOD(JOB,100)/10
      JOB5 = MOD(JOB,10)
      WRITE (LUNRPT,1100) JOB
      IF (RESTRT) THEN
         WRITE (LUNRPT,1110) JOB1
      ELSE
         WRITE (LUNRPT,1111) JOB1
      END IF
      IF (ISODR) THEN
         IF (INITD) THEN
            WRITE (LUNRPT,1120) JOB2
         ELSE
            WRITE (LUNRPT,1121) JOB2
         END IF
      ELSE
         WRITE (LUNRPT,1122) JOB2,JOB5
      END IF
      IF (DOVCV) THEN
         WRITE (LUNRPT,1130) JOB3
         IF (REDOJ) THEN
            WRITE (LUNRPT,1131) 
         ELSE
            WRITE (LUNRPT,1132)
         END IF
      ELSE
         WRITE (LUNRPT,1133) JOB3
      END IF
      IF (ANAJAC) THEN
         WRITE (LUNRPT,1140) JOB4
         IF (CHKJAC) THEN
            IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN
               WRITE (LUNRPT,1141)
            ELSE
               WRITE (LUNRPT,1142)
            END IF
         ELSE
            WRITE (LUNRPT,1143)
         END IF
      ELSE IF (CDJAC) THEN
         WRITE (LUNRPT,1144) JOB4
      ELSE 
         WRITE (LUNRPT,1145) JOB4
      END IF
      IF (ISODR) THEN
         IF (IMPLCT) THEN
            WRITE (LUNRPT,1150) JOB5
         ELSE
            WRITE (LUNRPT,1151) JOB5
         END IF
      ELSE
         WRITE (LUNRPT,1152) JOB5
      END IF
      IF (NETA.LT.0) THEN
         WRITE (LUNRPT,1200) -NETA
      ELSE
         WRITE (LUNRPT,1210) NETA
      END IF
      WRITE (LUNRPT,1300) TAUFAC


C  PRINT STOPPING CRITERIA

      WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT


C  PRINT INITIAL SUM OF SQUARES

      IF (IMPLCT) THEN
         WRITE (LUNRPT,1500) WSSDEL
         IF (ISODR) THEN
            WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY
         END IF
      ELSE
         WRITE (LUNRPT,1600) WSS
         IF (ISODR) THEN
            WRITE (LUNRPT,1610) WSSDEL,WSSEPS
         END IF
      END IF

 
      IF (IPR.GE.2) THEN


C  PRINT FUNCTION PARAMETER DATA

         WRITE (LUNRPT,4000)
         IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
            WRITE (LUNRPT,4110)
         ELSE IF (ANAJAC) THEN
            WRITE (LUNRPT,4120)
         ELSE 
            WRITE (LUNRPT,4200)
         END IF 
         DO 130 J=1,NP
            IF (IFIXB(1).LT.0) THEN
               TEMPC1 = '   NO'
            ELSE
               IF (IFIXB(J).NE.0) THEN
                  TEMPC1 = '   NO'
               ELSE
                  TEMPC1 = '  YES'
               END IF
            END IF
            IF (ANAJAC) THEN
               IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
                  ITEMP = -1
                  DO 110 L=1,NQ
                     ITEMP = MAX(ITEMP,MSGB(L,J))
  110             CONTINUE
                  IF (ITEMP.LE.-1) THEN
                     TEMPC2 = '    UNCHECKED'
                  ELSE IF (ITEMP.EQ.0) THEN
                     TEMPC2 = '     VERIFIED'
                  ELSE IF (ITEMP.GE.1) THEN
                     TEMPC2 = ' QUESTIONABLE'
                  END IF
               ELSE
                  TEMPC2 = '             '
               END IF
            ELSE
               TEMPC2 = '             '
            END IF
            IF (SSF(1).LT.ZERO) THEN
               TEMP1 = ABS(SSF(1))
            ELSE
               TEMP1 = SSF(J)
            END IF
            IF (ANAJAC) THEN
               WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2
            ELSE
               IF (CDJAC) THEN 
                  TEMP2 = DHSTEP(1,NETA,1,J,STPB,1)
               ELSE
                  TEMP2 = DHSTEP(0,NETA,1,J,STPB,1)
               END IF
               WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2
            END IF
  130    CONTINUE

C  PRINT EXPLANATORY VARIABLE DATA

         IF (ISODR) THEN
            WRITE (LUNRPT,2010)
            IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN
               WRITE (LUNRPT,2110)
            ELSE IF (ANAJAC) THEN
               WRITE (LUNRPT,2120)
            ELSE
               WRITE (LUNRPT,2130)
            END IF
         ELSE
            WRITE (LUNRPT,2020)
            WRITE (LUNRPT,2140)
         END IF
         IF (ISODR) THEN
            DO 240 J = 1,M
               TEMPC0 = '1,'
               DO 230 I=1,N,N-1

                  IF (IFIXX(1,1).LT.0) THEN
                     TEMPC1 = '   NO'
                  ELSE
                     IF (LDIFX.EQ.1) THEN
                        IF (IFIXX(1,J).EQ.0) THEN
                           TEMPC1 = '  YES'
                        ELSE
                           TEMPC1 = '   NO'
                        END IF
                     ELSE
                        IF (IFIXX(I,J).EQ.0) THEN
                           TEMPC1 = '  YES'
                        ELSE
                           TEMPC1 = '   NO'
                        END IF
                     END IF
                  END IF

                  IF (TT(1,1).LT.ZERO) THEN
                     TEMP1 = ABS(TT(1,1))
                  ELSE
                     IF (LDTT.EQ.1) THEN
                        TEMP1 = TT(1,J)
                     ELSE
                        TEMP1 = TT(I,J)
                     END IF
                  END IF

                  IF (WD(1,1,1).LT.ZERO) THEN
                     TEMP2 = ABS(WD(1,1,1))
                  ELSE
                     IF (LDWD.EQ.1) THEN
                        IF (LD2WD.EQ.1) THEN
                           TEMP2 = WD(1,1,J)
                        ELSE
                           TEMP2 = WD(1,J,J)
                        END IF
                     ELSE
                        IF (LD2WD.EQ.1) THEN
                           TEMP2 = WD(I,1,J)
                        ELSE
                           TEMP2 = WD(I,J,J)
                        END IF
                     END IF
                  END IF

                  IF (ANAJAC) THEN
                     IF (CHKJAC .AND. 
     +                   (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND.
     +                    (I.EQ.1))) THEN
                        ITEMP = -1
                        DO 210 L=1,NQ
                           ITEMP = MAX(ITEMP,MSGD(L,J))
  210                   CONTINUE
                        IF (ITEMP.LE.-1) THEN
                           TEMPC2 = '    UNCHECKED'
                        ELSE IF (ITEMP.EQ.0) THEN
                           TEMPC2 = '     VERIFIED'
                        ELSE IF (ITEMP.GE.1) THEN
                           TEMPC2 = ' QUESTIONABLE'
                        END IF
                     ELSE
                        TEMPC2 = '             '
                     END IF
                     IF (M.LE.9) THEN
                        WRITE (LUNRPT,5110) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2
                     ELSE
                        WRITE (LUNRPT,5120) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2
                     END IF
                  ELSE
                     TEMPC2 = '             '  
                     IF (CDJAC) THEN 
                        TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD)
                     ELSE
                        TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD)
                     END IF
                     IF (M.LE.9) THEN
                        WRITE (LUNRPT,5210) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3
                     ELSE
                        WRITE (LUNRPT,5220) 
     +                     TEMPC0,J,X(I,J),
     +                     DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3
                     END IF
                  END IF

                  TEMPC0 = 'N,'

  230          CONTINUE
               IF (J.LT.M) WRITE (LUNRPT,6000)
  240       CONTINUE
         ELSE

            DO 260 J = 1,M
               TEMPC0 = '1,'
               DO 250 I=1,N,N-1
                  IF (M.LE.9) THEN
                     WRITE (LUNRPT,5110) 
     +                  TEMPC0,J,X(I,J)
                  ELSE
                     WRITE (LUNRPT,5120) 
     +                  TEMPC0,J,X(I,J)
                  END IF
                  TEMPC0 = 'N,'
  250          CONTINUE
               IF (J.LT.M) WRITE (LUNRPT,6000)
  260       CONTINUE
         END IF

C  PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS

         IF (.NOT.IMPLCT) THEN
            WRITE (LUNRPT,3000)
            WRITE (LUNRPT,3100)
            DO 310 L=1,NQ
               TEMPC0 = '1,'
               DO 300 I=1,N,N-1
                  IF (WE(1,1,1).LT.ZERO) THEN
                     TEMP1 = ABS(WE(1,1,1))
                  ELSE IF (LDWE.EQ.1) THEN
                     IF (LD2WE.EQ.1) THEN
                        TEMP1 = WE(1,1,L)
                     ELSE 
                        TEMP1 = WE(1,L,L)
                     END IF
                  ELSE 
                     IF (LD2WE.EQ.1) THEN
                        TEMP1 = WE(I,1,L)
                     ELSE 
                        TEMP1 = WE(I,L,L)
                     END IF
                  END IF
                  IF (NQ.LE.9) THEN
                     WRITE (LUNRPT,5110) 
     +                  TEMPC0,L,Y(I,L),TEMP1
                  ELSE
                     WRITE (LUNRPT,5120) 
     +                  TEMPC0,L,Y(I,L),TEMP1
                  END IF
                  TEMPC0 = 'N,'
  300          CONTINUE
               IF (L.LT.NQ) WRITE (LUNRPT,6000)
  310       CONTINUE
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

 1000 FORMAT
     +  (/' --- PROBLEM SIZE:'/
     +    '            N = ',I5,
     +    '          (NUMBER WITH NONZERO WEIGHT = ',I5,')'/
     +    '           NQ = ',I5/
     +    '            M = ',I5/
     +    '           NP = ',I5,
     +    '          (NUMBER UNFIXED = ',I5,')')
 1100 FORMAT
     +  (/' --- CONTROL VALUES:'/
     +    '          JOB = ',I5.5/
     +    '              = ABCDE, WHERE')
 1110 FORMAT
     +   ('                       A=',I1,' ==> FIT IS A RESTART.')
 1111 FORMAT
     +   ('                       A=',I1,' ==> FIT IS NOT A RESTART.')
 1120 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE INITIALIZED',
     +                                     ' TO ZERO.')
 1121 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE INITIALIZED',
     +                                     ' BY USER.')
 1122 FORMAT
     +   ('                       B=',I1,' ==> DELTAS ARE FIXED AT',
     +                                     ' ZERO SINCE E=',I1,'.')
 1130 FORMAT
     +   ('                       C=',I1,' ==> COVARIANCE MATRIX WILL',
     +                                     ' BE COMPUTED USING')
 1131 FORMAT
     +   ('                               DERIVATIVES RE-',
     +                                     'EVALUATED AT THE SOLUTION.')
 1132 FORMAT
     +   ('                               DERIVATIVES FROM THE',
     +                                     ' LAST ITERATION.')
 1133 FORMAT
     +   ('                       C=',I1,' ==> COVARIANCE MATRIX WILL',
     +                                     ' NOT BE COMPUTED.')
 1140 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' SUPPLIED BY USER.')
 1141 FORMAT
     +   ('                               DERIVATIVES WERE CHECKED.'/
     +    '                               RESULTS APPEAR QUESTIONABLE.')
 1142 FORMAT
     +   ('                               DERIVATIVES WERE CHECKED.'/
     +    '                               RESULTS APPEAR CORRECT.')
 1143 FORMAT
     +   ('                               DERIVATIVES WERE NOT',
     +                                     ' CHECKED.')
 1144 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' ESTIMATED BY CENTRAL',
     +                                     ' DIFFERENCES.')
 1145 FORMAT
     +   ('                       D=',I1,' ==> DERIVATIVES ARE',
     +                                     ' ESTIMATED BY FORWARD',
     +                                     ' DIFFERENCES.')
 1150 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS IMPLICIT ODR.')
 1151 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS EXPLICIT ODR.')
 1152 FORMAT
     +   ('                       E=',I1,' ==> METHOD IS EXPLICIT OLS.')
 1200 FORMAT
     +   ('       NDIGIT = ',I5,'          (ESTIMATED BY ODRPACK)')
 1210 FORMAT
     +   ('       NDIGIT = ',I5,'          (SUPPLIED BY USER)')
 1300 FORMAT
     +   ('       TAUFAC = ',1P,D12.2)
 1400 FORMAT
     +   (/' --- STOPPING CRITERIA:'/
     +     '        SSTOL = ',1P,D12.2,
     +                      '   (SUM OF SQUARES STOPPING TOLERANCE)'/
     +     '       PARTOL = ',1P,D12.2,
     +                      '   (PARAMETER STOPPING TOLERANCE)'/
     +     '        MAXIT = ',I5,
     +                      '          (MAXIMUM NUMBER OF ITERATIONS)')
 1500 FORMAT
     +   (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =',
     +     17X,1P,D17.8)
 1510 FORMAT
     +   ( '         INITIAL PENALTY FUNCTION VALUE     =',1P,D17.8/
     +     '                 PENALTY TERM               =',1P,D17.8/
     +     '                 PENALTY PARAMETER          =',1P,D10.1)
 1600 FORMAT
     +   (/' --- INITIAL WEIGHTED SUM OF SQUARES        =',
     +     17X,1P,D17.8)
 1610 FORMAT
     +   ( '         SUM OF SQUARED WEIGHTED DELTAS     =',1P,D17.8/
     +     '         SUM OF SQUARED WEIGHTED EPSILONS   =',1P,D17.8)
 2010 FORMAT
     +   (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:')
 2020 FORMAT
     +   (/' --- EXPLANATORY VARIABLE SUMMARY:')
 2110 FORMAT
     +   (/'       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT    DERIVATIVE'/
     +     '                                             ',
     +           '                        ASSESSMENT'/,
     +     '       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)              '/)
 2120 FORMAT
     +   (/'       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT              '/
     +     '                                             ',
     +           '                                  '/,
     +     '       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)              '/)
 2130 FORMAT
     +   (/'       INDEX      X(I,J)  DELTA(I,J)    FIXED',
     +           '     SCALE    WEIGHT    DERIVATIVE'/
     +     '                                             ',
     +           '                         STEP SIZE'/,
     +     '       (I,J)                          (IFIXX)',
     +           '    (SCLD)      (WD)        (STPD)'/)
 2140 FORMAT
     +   (/'       INDEX      X(I,J)'/
     +     '       (I,J)            '/)
 3000 FORMAT
     +   (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT',
     +   ' SUMMARY:')
 3100 FORMAT
     +   (/'       INDEX      Y(I,L)      WEIGHT'/
     +     '       (I,L)                    (WE)'/)
 4000 FORMAT
     +   (/' --- FUNCTION PARAMETER SUMMARY:')
 4110 FORMAT
     +   (/'       INDEX         BETA(K)    FIXED           SCALE',
     +     '    DERIVATIVE'/
     +     '                                                     ',
     +     '    ASSESSMENT'/,
     +     '         (K)                  (IFIXB)          (SCLB)',
     +     '              '/)
 4120 FORMAT
     +   (/'       INDEX         BETA(K)    FIXED           SCALE',
     +     '              '/
     +     '                                                     ',
     +     '              '/,
     +     '         (K)                  (IFIXB)          (SCLB)',
     +     '              '/)
 4200 FORMAT
     +   (/'       INDEX         BETA(K)    FIXED           SCALE',
     +     '    DERIVATIVE'/
     +     '                                                     ',
     +     '     STEP SIZE'/,
     +     '         (K)                  (IFIXB)          (SCLB)',
     +     '        (STPB)'/)
 4310 FORMAT
     +    (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13)
 4320 FORMAT
     +    (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5)
 5110 FORMAT
     +    (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13)
 5120 FORMAT
     +    (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13)
 5210 FORMAT
     +    (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5)
 5220 FORMAT
     +    (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5)
 6000 FORMAT
     +   (' ')
      END
*DODPC2
      SUBROUTINE DODPC2
     +   (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 
     +   PNLTY,
     +   NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA)
C***BEGIN PROLOGUE  DODPC2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  GENERATE ITERATION REPORTS
C***END PROLOGUE  DODPC2

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS
      INTEGER
     +   IPR,LUNRPT,NFEV,NITER,NP
      LOGICAL
     +   FSTITR,IMPLCT,PRTPEN

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   RATIO,ZERO
      INTEGER
     +   J,K,L
      CHARACTER GN*3

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   BETA:    THE FUNCTION PARAMETERS.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.).
C   GN:      THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON
C            STEP WAS TAKEN.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 
C            (PRTPEN=FALSE).
C   RATIO:   THE RATIO OF TAU TO PNORM.
C   TAU:     THE TRUST REGION DIAMETER.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODPC2


      IF (FSTITR) THEN
         IF (IPR.EQ.1) THEN
            IF (IMPLCT) THEN
               WRITE (LUNRPT,1121)
            ELSE
               WRITE (LUNRPT,1122)
            END IF
         ELSE
            IF (IMPLCT) THEN
               WRITE (LUNRPT,1131)
            ELSE
               WRITE (LUNRPT,1132)
            END IF
         END IF
      END IF
      IF (PRTPEN) THEN
         WRITE (LUNRPT,1133) PNLTY
      END IF

      IF (ALPHA.EQ.ZERO) THEN
         GN = 'YES'
      ELSE
         GN = ' NO'
      END IF
      IF (PNORM.NE.ZERO) THEN
         RATIO = TAU/PNORM
      ELSE
         RATIO = ZERO
      END IF
      IF (IPR.EQ.1) THEN
         WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED,
     +                       RATIO,GN
      ELSE
         J = 1
         K = MIN(3,NP)
         IF (J.EQ.K) THEN
            WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED,
     +                          RATIO,GN,J,BETA(J)
         ELSE
            WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED,
     +                          RATIO,GN,J,K,(BETA(L),L=J,K)
         END IF
         IF (NP.GT.3) THEN
            DO 10 J=4,NP,3
               K = MIN(J+2,NP)
               IF (J.EQ.K) THEN
                  WRITE (LUNRPT,1151) J,BETA(J)
               ELSE
                  WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K)
               END IF
   10       CONTINUE
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

 1121 FORMAT
     +   (//
     +    '         CUM.      PENALTY    ACT. REL.   PRED. REL.'/
     +    '  IT.  NO. FN     FUNCTION   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N'/
     +    ' NUM.   EVALS        VALUE    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----')
 1122 FORMAT
     +   (//
     +    '         CUM.                 ACT. REL.   PRED. REL.'/
     +    '  IT.  NO. FN     WEIGHTED   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N'/
     +    ' NUM.   EVALS   SUM-OF-SQS    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----'/)
 1131 FORMAT
     +   (//
     +    '         CUM.      PENALTY    ACT. REL.   PRED. REL.'/
     +    '  IT.  NO. FN     FUNCTION   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N      BETA -------------->'/
     +    ' NUM.   EVALS        VALUE    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP     INDEX           VALUE'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----     -----           -----')
 1132 FORMAT
     +   (//
     +    '         CUM.                 ACT. REL.   PRED. REL.'/
     +    '  IT.  NO. FN     WEIGHTED   SUM-OF-SQS   SUM-OF-SQS',
     +    '              G-N      BETA -------------->'/
     +    ' NUM.   EVALS   SUM-OF-SQS    REDUCTION    REDUCTION',
     +    '  TAU/PNORM  STEP     INDEX           VALUE'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----     -----           -----'/)
 1133 FORMAT
     +   (/' PENALTY PARAMETER VALUE = ', 1P,E10.1)
 1141 FORMAT
     +   (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8)
 1142 FORMAT
     +   (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8)
 1151 FORMAT
     +   (76X,I3,1P,D16.8)
 1152 FORMAT
     +   (70X,I3,' TO',I3,1P,3D16.8)
      END
*DODPC3
      SUBROUTINE DODPC3
     +   (IPR,LUNRPT,
     +   ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC,
     +   N,M,NP,NQ,NPP,
     +   INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP,
     +   WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF,
     +   BETA,SDBETA,IFIXB2,F,DELTA)
C***BEGIN PROLOGUE  DODPC3
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPPT
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE FINAL SUMMARY REPORT
C***END PROLOGUE  DODPC3

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS
      INTEGER
     +   IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M,
     +   N,NFEV,NITER,NJEV,NP,NPP,NQ
      LOGICAL
     +   ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP)
      INTEGER
     +   IFIXB2(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TVAL
      INTEGER
     +   D1,D2,D3,D4,D5,I,J,K,L,NPLM1
      CHARACTER FMT1*90

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DPPT
      EXTERNAL
     +   DPPT

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MIN,MOD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   D1:      THE FIRST DIGIT OF INFO.
C   D2:      THE SECOND DIGIT OF INFO.
C   D3:      THE THIRD DIGIT OF INFO.
C   D4:      THE FOURTH DIGIT OF INFO.
C   D5:      THE FIFTH DIGIT OF INFO.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   F:       THE ESTIMATED VALUES OF EPSILON.
C   FMT1:    A CHARACTER*90 VARIABLE USED FOR FORMATS.
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB2:  THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE 
C            ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK 
C            DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1,
C            0, AND -1, RESPECTIVELY.  IF IFIXB2 IS -2, THEN NO ATTEMPT
C            WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   IPR:     THE VARIABLE INDICATING WHAT IS TO BE PRINTED.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   L:       AN INDEXING VARIABLE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPLM1:   THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS
C            TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE 
C            MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RVAR:    THE RESIDUAL VARIANCE.
C   SDBETA:  THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS.
C   TVAL:    THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE
C            T DISTRIBUTION.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS.
C   WSSDEL:  THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS.
C   WSSEPS:  THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.


C***FIRST EXECUTABLE STATEMENT  DODPC3


      D1 = INFO/10000
      D2 = MOD(INFO,10000)/1000
      D3 = MOD(INFO,1000)/100
      D4 = MOD(INFO,100)/10
      D5 = MOD(INFO,10)

C  PRINT STOPPING CONDITIONS

      WRITE (LUNRPT,1000)
      IF (INFO.LE.9) THEN
         IF (INFO.EQ.1) THEN
            WRITE (LUNRPT,1011) INFO
         ELSE IF (INFO.EQ.2) THEN
            WRITE (LUNRPT,1012) INFO
         ELSE IF (INFO.EQ.3) THEN
            WRITE (LUNRPT,1013) INFO
         ELSE IF (INFO.EQ.4) THEN
            WRITE (LUNRPT,1014) INFO
         ELSE IF (INFO.LE.9) THEN
            WRITE (LUNRPT,1015) INFO
         END IF
      ELSE IF (INFO.LE.9999) THEN

C  PRINT WARNING DIAGNOSTICS

         WRITE (LUNRPT,1020) INFO
         IF (D2.EQ.1) WRITE (LUNRPT,1021)
         IF (D3.EQ.1) WRITE (LUNRPT,1022)
         IF (D4.EQ.1) WRITE (LUNRPT,1023)
         IF (D4.EQ.2) WRITE (LUNRPT,1024)
         IF (D5.EQ.1) THEN
            WRITE (LUNRPT,1031)
         ELSE IF (D5.EQ.2) THEN
            WRITE (LUNRPT,1032)
         ELSE IF (D5.EQ.3) THEN
            WRITE (LUNRPT,1033)
         ELSE IF (D5.EQ.4) THEN
            WRITE (LUNRPT,1034)
         ELSE IF (D5.LE.9) THEN
            WRITE (LUNRPT,1035) D5
         END IF
      ELSE

C  PRINT ERROR MESSAGES

         WRITE (LUNRPT,1040) INFO
         IF (D1.EQ.5) THEN
            WRITE (LUNRPT,1042)
            IF (D2.NE.0) WRITE (LUNRPT,1043) D2
            IF (D3.EQ.3) THEN
               WRITE (LUNRPT,1044) D3
            ELSE IF (D3.NE.0) THEN
               WRITE (LUNRPT,1045) D3
            END IF
         ELSE IF (D1.EQ.6) THEN
            WRITE (LUNRPT,1050)
         ELSE
            WRITE (LUNRPT,1060) D1
         END IF
      END IF

C  PRINT MISC. STOPPING INFO

      WRITE (LUNRPT,1300) NITER
      WRITE (LUNRPT,1310) NFEV
      IF (ANAJAC) WRITE (LUNRPT,1320) NJEV
      WRITE (LUNRPT,1330) IRANK
      WRITE (LUNRPT,1340) RCOND
      WRITE (LUNRPT,1350) ISTOP

C  PRINT FINAL SUM OF SQUARES

      IF (IMPLCT) THEN
         WRITE (LUNRPT,2000) WSSDEL
         IF (ISODR) THEN
            WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY
         END IF
      ELSE
         WRITE (LUNRPT,2100) WSS
         IF (ISODR) THEN
            WRITE (LUNRPT,2110) WSSDEL,WSSEPS
         END IF
      END IF
      IF (DIDVCV) THEN
         WRITE (LUNRPT,2200) SQRT(RVAR),IDF
      END IF

      NPLM1 = 3

C  PRINT ESTIMATED BETA'S, AND,
C  IF, FULL RANK, THEIR STANDARD ERRORS

      WRITE (LUNRPT,3000)
      IF (DIDVCV) THEN
         WRITE (LUNRPT,7300)
         TVAL = DPPT(0.975D0,IDF)
         DO 10 J=1,NP
            IF (IFIXB2(J).GE.1) THEN
               WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J),
     +                             BETA(J)-TVAL*SDBETA(J),
     +                             BETA(J)+TVAL*SDBETA(J) 
            ELSE IF (IFIXB2(J).EQ.0) THEN
               WRITE (LUNRPT,8600) J,BETA(J)
            ELSE
               WRITE (LUNRPT,8700) J,BETA(J)
            END IF
   10    CONTINUE
         IF (.NOT.REDOJ) WRITE (LUNRPT,7310)
      ELSE
         IF (DOVCV) THEN
            IF (D1.LE.5) THEN
               WRITE (LUNRPT,7410)
            ELSE
               WRITE (LUNRPT,7420)
            END IF
         END IF

         IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR.  NITER.EQ.0) THEN
            IF (NP.EQ.1) THEN
               WRITE (LUNRPT,7100)
            ELSE
               WRITE (LUNRPT,7200)
            END IF
            DO 20 J=1,NP,NPLM1+1
               K = MIN(J+NPLM1,NP)
               IF (K.EQ.J) THEN
                  WRITE (LUNRPT,8100) J,BETA(J)
               ELSE
                  WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K)
               END IF
   20       CONTINUE
            IF (NITER.GE.1) THEN
               WRITE (LUNRPT,8800)
            ELSE
               WRITE (LUNRPT,8900)
            END IF
         ELSE
            WRITE (LUNRPT,7500)
            DO 30 J=1,NP
               IF (IFIXB2(J).GE.1) THEN
                  WRITE (LUNRPT,8500) J,BETA(J)
               ELSE IF (IFIXB2(J).EQ.0) THEN
                  WRITE (LUNRPT,8600) J,BETA(J)
               ELSE
                  WRITE (LUNRPT,8700) J,BETA(J)
               END IF
   30       CONTINUE
         END IF
      END IF

      IF (IPR.EQ.1) RETURN


C  PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF
C  COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE.

      IF (IMPLCT .AND. (M.LE.4)) THEN
         WRITE (LUNRPT,4100)
         WRITE (FMT1,9110) M
         WRITE (LUNRPT,FMT1) (J,J=1,M)
         DO 40 I=1,N
            WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M)
   40    CONTINUE

      ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN
         WRITE (LUNRPT,4110)
         WRITE (FMT1,9120) NQ,M
         WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M)
         DO 50 I=1,N
            WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M)
   50    CONTINUE

      ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN
         WRITE (LUNRPT,4120)
         WRITE (FMT1,9130) NQ
         WRITE (LUNRPT,FMT1) (L,L=1,NQ)
         DO 60 I=1,N
            WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ)
   60    CONTINUE
      ELSE

C  PRINT EPSILON'S AND DELTA'S SEPARATELY

         IF (.NOT.IMPLCT) THEN

C  PRINT EPSILON'S

            DO 80 J=1,NQ
               WRITE (LUNRPT,4200) J
               IF (N.EQ.1) THEN
                  WRITE (LUNRPT,7100)
               ELSE
                  WRITE (LUNRPT,7200)
               END IF
               DO 70 I=1,N,NPLM1+1
                  K = MIN(I+NPLM1,N)
                  IF (I.EQ.K) THEN
                     WRITE (LUNRPT,8100) I,F(I,J)
                  ELSE
                     WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K)
                  END IF
   70          CONTINUE
   80       CONTINUE
         END IF

C  PRINT DELTA'S

         IF (ISODR) THEN
            DO 100 J=1,M
               WRITE (LUNRPT,4300) J
               IF (N.EQ.1) THEN
                  WRITE (LUNRPT,7100)
               ELSE
                  WRITE (LUNRPT,7200)
               END IF
               DO 90 I=1,N,NPLM1+1
                  K = MIN(I+NPLM1,N)
                  IF (I.EQ.K) THEN
                     WRITE (LUNRPT,8100) I,DELTA(I,J)
                  ELSE
                     WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K)
                  END IF
   90          CONTINUE
  100       CONTINUE
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

 1000 FORMAT
     + (/' --- STOPPING CONDITIONS:')
 1011 FORMAT
     +  ('         INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.')
 1012 FORMAT
     +  ('         INFO = ',I5,' ==> PARAMETER CONVERGENCE.')
 1013 FORMAT
     +  ('         INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND',
     +                        ' PARAMETER CONVERGENCE.')
 1014 FORMAT
     +  ('         INFO = ',I5,' ==> ITERATION LIMIT REACHED.')
 1015 FORMAT
     +  ('         INFO = ',I5,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING'/
     +   '                           INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1020 FORMAT
     +  ('         INFO = ',I5.4/
     +   '              =  ABCD, WHERE A NONZERO VALUE FOR DIGIT A,',
     +                         ' B, OR C INDICATES WHY'/
     +   '                       THE RESULTS MIGHT BE QUESTIONABLE,',
     +                         ' AND DIGIT D INDICATES'/
     +   '                       THE ACTUAL STOPPING CONDITION.')
 1021 FORMAT
     +  ('                       A=1 ==> DERIVATIVES ARE',
     +                                 ' QUESTIONABLE.')
 1022 FORMAT
     +  ('                       B=1 ==> USER SET ISTOP TO',
     +                                 ' NONZERO VALUE DURING LAST'/
     +   '                               CALL TO SUBROUTINE FCN.')
 1023 FORMAT
     +  ('                       C=1 ==> DERIVATIVES ARE NOT',
     +                                 ' FULL RANK AT THE SOLUTION.')
 1024 FORMAT
     +  ('                       C=2 ==> DERIVATIVES ARE ZERO',
     +                                 ' RANK AT THE SOLUTION.')
 1031 FORMAT
     +  ('                       D=1 ==> SUM OF SQUARES CONVERGENCE.')
 1032 FORMAT
     +  ('                       D=2 ==> PARAMETER CONVERGENCE.')
 1033 FORMAT
     +  ('                       D=3 ==> SUM OF SQUARES CONVERGENCE',
     +                                 ' AND PARAMETER CONVERGENCE.')
 1034 FORMAT
     +  ('                       D=4 ==> ITERATION LIMIT REACHED.')
 1035 FORMAT
     +  ('                       D=',I1,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING'/
     +   '                               INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1040 FORMAT
     +  ('         INFO = ',I5.5/
     +   '              = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN',
     +                         ' DIGIT INDICATES AN'/
     +   '                       ABNORMAL STOPPING CONDITION.')
 1042 FORMAT
     +  ('                       A=5 ==> USER STOPPED COMPUTATIONS',
     +                                 ' IN SUBROUTINE FCN.')
 1043 FORMAT
     +  ('                       B=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED DURING THE'/
     +   '                                    FUNCTION EVALUATION.')
 1044 FORMAT
     +  ('                       C=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED BECAUSE'/
     +   '                                    DERIVATIVES WITH',
     +                                 ' RESPECT TO DELTA WERE'/
     +   '                                    COMPUTED BY',
     +                                 ' SUBROUTINE FCN WHEN'/
     +   '                                    FIT IS OLS.')
 1045 FORMAT
     +  ('                       C=',I1,' ==> COMPUTATIONS WERE',
     +                                 ' STOPPED DURING THE'/
     +   '                                    JACOBIAN EVALUATION.')
 1050 FORMAT
     +  ('                       A=6 ==> NUMERICAL INSTABILITIES',
     +                                 ' HAVE BEEN DETECTED,'/
     +   '                               POSSIBLY INDICATING',
     +                                 ' A DISCONTINUITY IN THE'/
     +   '                               DERIVATIVES OR A POOR',
     +                                 ' POOR CHOICE OF PROBLEM'/
     +   '                               SCALE OR WEIGHTS.')
 1060 FORMAT
     +  ('                       A=',I1,' ==> UNEXPECTED VALUE,',
     +                                 ' PROBABLY INDICATING'/
     +   '                               INCORRECTLY SPECIFIED',
     +                                 ' USER INPUT.')
 1300 FORMAT
     +  ('        NITER = ',I5,
     +                    '          (NUMBER OF ITERATIONS)')
 1310 FORMAT
     +  ('         NFEV = ',I5,
     +                    '          (NUMBER OF FUNCTION EVALUATIONS)')
 1320 FORMAT
     +  ('         NJEV = ',I5,
     +                    '          (NUMBER OF JACOBIAN EVALUATIONS)')
 1330 FORMAT
     +  ('        IRANK = ',I5,
     +                    '          (RANK DEFICIENCY)')
 1340 FORMAT
     +  ('        RCOND = ',1P,D12.2,
     +                           '   (INVERSE CONDITION NUMBER)')
*1341 FORMAT
*    +  ('                      ==> POSSIBLY FEWER THAN 2 SIGNIFICANT',
*    +                        ' DIGITS IN RESULTS;'/
*    +   '                          SEE ODRPACK REFERENCE',
*    +                        ' GUIDE, SECTION 4.C.')
 1350 FORMAT
     +  ('        ISTOP = ',I5,
     +                    '          (RETURNED BY USER FROM',
     +                        ' SUBROUTINE FCN)')
 2000 FORMAT
     + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ',
     +     17X,1P,D17.8)
 2010 FORMAT
     + ( '         FINAL PENALTY FUNCTION VALUE     = ',1P,D17.8/
     +   '               PENALTY TERM               = ',1P,D17.8/
     +   '               PENALTY PARAMETER          = ',1P,D10.1)
 2100 FORMAT
     + (/' --- FINAL WEIGHTED SUMS OF SQUARES       = ',17X,1P,D17.8)
 2110 FORMAT
     + ( '         SUM OF SQUARED WEIGHTED DELTAS   = ',1P,D17.8/
     +   '         SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8)
 2200 FORMAT
     + (/' --- RESIDUAL STANDARD DEVIATION          = ',
     +     17X,1P,D17.8/
     +   '         DEGREES OF FREEDOM               =',I5)
 3000 FORMAT
     + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:')
 4100 FORMAT
     + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:')
 4110 FORMAT
     + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:')
 4120 FORMAT
     + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:')
 4130 FORMAT(5X,I5,1P,5D16.8)
 4200 FORMAT
     + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:')
 4300 FORMAT
     + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:')
 7100 FORMAT
     + (/'           INDEX           VALUE'/)
 7200 FORMAT
     + (/'           INDEX           VALUE -------------->'/)
 7300 FORMAT
     + (/'                     BETA      S.D. BETA',
     +   '    ---- 95%  CONFIDENCE INTERVAL ----'/)
 7310 FORMAT
     + (/'     N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE',
     +                ' COMPUTED USING'/
     +   '          DERIVATIVES CALCULATED AT THE BEGINNING',
     +                ' OF THE LAST ITERATION,'/
     +   '          AND NOT USING DERIVATIVES RE-EVALUATED AT THE',
     +                ' FINAL SOLUTION.')
 7410 FORMAT
     + (/'     N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE',
     +                ' NOT COMPUTED BECAUSE'/
     +   '          THE DERIVATIVES WERE NOT AVAILABLE.  EITHER MAXIT',
     +                ' IS 0 AND THE THIRD'/
     +   '          DIGIT OF JOB IS GREATER THAN 1, OR THE MOST',
     +                ' RECENTLY TRIED VALUES OF'/
     +   '          BETA AND/OR X+DELTA WERE IDENTIFIED AS',
     +                ' UNACCEPTABLE BY USER SUPPLIED'/
     +   '          SUBROUTINE FCN.')
 7420 FORMAT
     + (/'     N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE',
     +                ' NOT COMPUTED.'/
     +   '          (SEE INFO ABOVE.)')
 7500 FORMAT
     + (/'                     BETA         STATUS')
 8100 FORMAT
     +  (11X,I5,1P,D16.8)
 8200 FORMAT
     +  (3X,I5,' TO',I5,1P,7D16.8)
 8400 FORMAT
     +  (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8)
 8500 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'ESTIMATED')
 8600 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'    FIXED')
 8700 FORMAT
     +  (3X,I5,1X,1P,D16.8,6X,'  DROPPED')
 8800 FORMAT
     + (/'     N.B. NO PARAMETERS WERE FIXED BY THE USER OR',
     +                ' DROPPED AT THE LAST'/
     +   '          ITERATION BECAUSE THEY CAUSED THE MODEL TO BE',
     +                ' RANK DEFICIENT.')
 8900 FORMAT
     + (/'     N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER',
     +                ' VALUES BECAUSE'/
     +   '          MAXIT=0.')
 9110 FORMAT
     +  ('(/''         I'',',
     +   I2,'(''      DELTA(I,'',I1,'')'')/)')
 9120 FORMAT
     +  ('(/''         I'',',
     +   I2,'(''    EPSILON(I,'',I1,'')''),',
     +   I2,'(''      DELTA(I,'',I1,'')'')/)')
 9130 FORMAT
     +  ('(/''         I'',',
     +   I2,'(''    EPSILON(I,'',I1,'')'')/)')

      END
*DODPCR
      SUBROUTINE DODPCR
     +   (IPR,LUNRPT, 
     +   HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG,
     +   N,M,NP,NQ,NPP,NNZW,
     +   MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA,
     +   WE,LDWE,LD2WE,WD,LDWD,LD2WD,
     +   IFIXB,IFIXX,LDIFX,
     +   SSF,TT,LDTT,STPB,STPD,LDSTPD,
     +   JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   WSS,RVAR,IDF,SDBETA,
     +   NITER,NFEV,NJEV,ACTRED,PRERED,
     +   TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP)
C***BEGIN PROLOGUE  DODPCR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE COMPUTATION REPORTS
C***END PROLOGUE  DODPCR

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR,
     +   SSTOL,TAU,TAUFAC
      INTEGER
     +   IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,
     +   LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV,
     +   NITER,NJEV,NNZW,NP,NPP,NQ
      LOGICAL
     +   DIDVCV,FSTITR,HEAD,PRTPEN

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP),
     +   STPB(NP),STPD(LDSTPD,M),TT(LDTT,M),
     +   WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   PNLTY
      LOGICAL
     +   ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT
      CHARACTER TYP*3

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRED:  THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   ANAJAC:  THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE).
C   BETA:    THE FUNCTION PARAMETERS.
C   CDJAC:   THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED
C            BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD
C            DIFFERENCES (CDJAC=FALSE).
C   CHKJAC:  THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 
C            JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT
C            (CHKJAC=FALSE).
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DIDVCV:  THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS
C            COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE).
C   DOVCV:   THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 
C            TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE).
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FSTITR:  THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 
C            ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE).
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE).
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFLAG:   THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED.
C   IMPLCT:  THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 
C            IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   INITD:   THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 
C            ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M
C            ELEMENTS OF ARRAY WORK (INITD=FALSE).
C   IPR:     THE VALUE INDICATING THE REPORT TO BE PRINTED.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   JOB:     THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND 
C            COMPUTATIONAL METHOD.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LUNRPT:  THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MAXIT:   THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS.
C   NITER:   THE NUMBER OF ITERATIONS.
C   NJEV:    THE NUMBER OF JACOBIAN EVALUATIONS.
C   NNZW:    THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   PARTOL:  THE PARAMETER CONVERGENCE STOPPING TOLERANCE.
C   PNLTY:   THE PENALTY PARAMETER FOR AN IMPLICIT MODEL.
C   PNORM:   THE NORM OF THE SCALED ESTIMATED PARAMETERS.
C   PRERED:  THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
C   PRTPEN:  THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS
C            TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT
C            (PRTPEN=FALSE).
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB.
C   REDOJ:   THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO
C            BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX
C            (REDOJ=TRUE) OR NOT (REDOJ=FALSE).
C   RESTRT:  THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 
C            (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C   RVAR:    THE RESIDUAL VARIANCE.
C   SDBETA:  THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S.
C   SSF:     THE SCALING VALUES FOR BETA.
C   SSTOL:   THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE.
C   STPB:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 
C            DERIVATIVES WITH RESPECT TO BETA.
C   STPD:    THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE
C            DERIVATIVES WITH RESPECT TO DELTA.
C   TAU:     THE TRUST REGION DIAMETER.
C   TAUFAC:  THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 
C            DIAMETER.
C   TT:      THE SCALING VALUES FOR DELTA.
C   TYP:     THE CHARACTER*3 STRING "ODR" OR "OLS".
C   WE:      THE EPSILON WEIGHTS.
C   WD:      THE DELTA WEIGHTS.
C   WSS:     THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS,
C            THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND
C            THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS.
C   X:       THE EXPLANATORY VARIABLE.
C   Y:       THE DEPENDENT VARIABLE.  UNUSED WHEN THE MODEL IS IMPLICIT.


C***FIRST EXECUTABLE STATEMENT  DODPCR


      CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
     +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
      PNLTY = ABS(WE(1,1,1))

      IF (HEAD) THEN
         CALL DODPHD(HEAD,LUNRPT)
      END IF
      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF

C  PRINT INITIAL SUMMARY

      IF (IFLAG.EQ.1) THEN
         WRITE (LUNRPT,1200) TYP
         CALL DODPC1
     +      (IPR,LUNRPT,
     +      ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ,
     +      MSGB(1),MSGB(2),MSGD(1),MSGD(2),
     +      N,M,NP,NQ,NPP,NNZW,
     +      X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD,
     +      Y,LDY,WE,LDWE,LD2WE,PNLTY,
     +      BETA,IFIXB,SSF,STPB,
     +      JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT,
     +      WSS(1),WSS(2),WSS(3))

C  PRINT ITERATION REPORTS

      ELSE IF (IFLAG.EQ.2) THEN

         IF (FSTITR) THEN
            WRITE (LUNRPT,1300) TYP
         END IF
         CALL DODPC2
     +      (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 
     +      PNLTY,
     +      NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA)

C  PRINT FINAL SUMMARY

      ELSE IF (IFLAG.EQ.3) THEN

         WRITE (LUNRPT,1400) TYP
         CALL DODPC3
     +      (IPR,LUNRPT,
     +      ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC,
     +      N,M,NP,NQ,NPP,
     +      INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP,
     +      WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF,
     +      BETA,SDBETA,IFIXB,F,DELTA)
      END IF

      RETURN

C  FORMAT STATEMENTS

 1200 FORMAT
     +   (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***')
 1300 FORMAT
     +   (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***')
 1400 FORMAT
     +   (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***')

      END
*DODPE1
      SUBROUTINE DODPE1
     +   (UNIT,D1,D2,D3,D4,D5,
     +   N,M,NQ,
     +   LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LWKMN,LIWKMN)
C***BEGIN PROLOGUE  DODPE1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ERROR REPORTS
C***END PROLOGUE  DODPE1

C...SCALAR ARGUMENTS
      INTEGER
     +   D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,
     +   LIWKMN,LWKMN,M,N,NQ,UNIT

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D1:      THE 1ST DIGIT (FROM THE LEFT) OF INFO.
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   D4:      THE 4TH DIGIT (FROM THE LEFT) OF INFO.
C   D5:      THE 5TH DIGIT (FROM THE LEFT) OF INFO.
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.


C***FIRST EXECUTABLE STATEMENT  DODPE1


C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION
C  PARAMETERS

      IF (D1.EQ.1) THEN
         IF (D2.NE.0) THEN
            WRITE(UNIT,1100)
         END IF
         IF (D3.NE.0) THEN
            WRITE(UNIT,1200)
         END IF
         IF (D4.NE.0) THEN
            WRITE(UNIT,1300)
         END IF
         IF (D5.NE.0) THEN
            WRITE(UNIT,1400)
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION
C  PARAMETERS

      ELSE IF (D1.EQ.2) THEN

         IF (D2.NE.0) THEN
            IF (D2.EQ.1 .OR. D2.EQ.3) THEN
               WRITE(UNIT,2110)
            END IF
            IF (D2.EQ.2 .OR. D2.EQ.3) THEN
               WRITE(UNIT,2120)
            END IF
         END IF

         IF (D3.NE.0) THEN
            IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN
               WRITE(UNIT,2210)
            END IF
            IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN
               WRITE(UNIT,2220)
            END IF
            IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN
               WRITE(UNIT,2230)
            END IF
         END IF

         IF (D4.NE.0) THEN
            IF (D4.EQ.1 .OR. D4.EQ.3) THEN
               WRITE(UNIT,2310)
            END IF
            IF (D4.EQ.2 .OR. D4.EQ.3) THEN
               WRITE(UNIT,2320)
            END IF
         END IF

         IF (D5.NE.0) THEN
            IF (D5.EQ.1 .OR. D5.EQ.3) THEN
               WRITE(UNIT,2410) LWKMN
            END IF
            IF (D5.EQ.2 .OR. D5.EQ.3) THEN
               WRITE(UNIT,2420) LIWKMN
            END IF
         END IF

      ELSE IF (D1.EQ.3) THEN

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES

         IF (D2.NE.0) THEN
            IF (D2.EQ.1 .OR. D2.EQ.3) THEN
               IF (LDSCLD.GE.N) THEN
                  WRITE(UNIT,3110)
               ELSE
                  WRITE(UNIT,3120)
               END IF
            END IF
            IF (D2.EQ.2 .OR. D2.EQ.3) THEN
               WRITE(UNIT,3130)
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES

         IF (D3.NE.0) THEN
            IF (D3.EQ.1 .OR. D3.EQ.3) THEN
               IF (LDSTPD.GE.N) THEN
                  WRITE(UNIT,3210)
               ELSE
                  WRITE(UNIT,3220)
               END IF
            END IF
            IF (D3.EQ.2 .OR. D3.EQ.3) THEN
               WRITE(UNIT,3230)
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS

         IF (D4.NE.0) THEN
            IF (D4.EQ.1) THEN
               IF (LDWE.GE.N) THEN
                  IF (LD2WE.GE.NQ) THEN
                     WRITE(UNIT,3310)
                  ELSE
                     WRITE(UNIT,3320)
                  END IF
               ELSE
                  IF (LD2WE.GE.NQ) THEN
                     WRITE(UNIT,3410)
                  ELSE
                     WRITE(UNIT,3420)
                  END IF
               END IF
            END IF
            IF (D4.EQ.2) THEN
               WRITE(UNIT,3500)
            END IF
         END IF

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS

         IF (D5.NE.0) THEN
            IF (LDWD.GE.N) THEN
               IF (LD2WD.GE.M) THEN
                  WRITE(UNIT,4310)
               ELSE
                  WRITE(UNIT,4320)
               END IF
            ELSE
               IF (LD2WD.GE.M) THEN
                  WRITE(UNIT,4410)
               ELSE
                  WRITE(UNIT,4420)
               END IF
            END IF
         END IF

      END IF

C  FORMAT STATEMENTS

 1100 FORMAT
     +   (/' ERROR :  N IS LESS THAN ONE.')
 1200 FORMAT
     +   (/' ERROR :  M IS LESS THAN ONE.')
 1300 FORMAT
     +   (/' ERROR :  NP IS LESS THAN ONE'/
     +     '          OR NP IS GREATER THAN N.')
 1400 FORMAT
     +   (/' ERROR :  NQ IS LESS THAN ONE.')
 2110 FORMAT
     +   (/' ERROR :  LDX IS LESS THAN N.')
 2120 FORMAT
     +   (/' ERROR :  LDY IS LESS THAN N.')
 2210 FORMAT
     +   (/' ERROR :  LDIFX IS LESS THAN N'/
     +     '          AND LDIFX IS NOT EQUAL TO ONE.')
 2220 FORMAT
     +   (/' ERROR :  LDSCLD IS LESS THAN N'/
     +     '          AND LDSCLD IS NOT EQUAL TO ONE.')
 2230 FORMAT
     +   (/' ERROR :  LDSTPD IS LESS THAN N'/
     +     '          AND LDSTPD IS NOT EQUAL TO ONE.')
 2310 FORMAT
     +   (/' ERROR :  LDWE IS LESS THAN N'/
     +     '          AND LDWE IS NOT EQUAL TO ONE OR'/
     +     '          OR'/
     +     '          LD2WE IS LESS THAN NQ'/
     +     '          AND LD2WE IS NOT EQUAL TO ONE.')
 2320 FORMAT
     +   (/' ERROR :  LDWD IS LESS THAN N'/
     +     '          AND LDWD IS NOT EQUAL TO ONE.')
 2410 FORMAT
     +   (/' ERROR :  LWORK IS LESS THAN ',I7, ','/
     +     '          THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.')
 2420 FORMAT
     +   (/' ERROR :  LIWORK IS LESS THAN ',I7, ','/
     +     '          THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY',
     +              ' IWORK.')
 3110 FORMAT
     +   (/' ERROR :  SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME I = 1, ..., N AND J = 1, ..., M.'//
     +     '          WHEN SCLD(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/
     +     '          EACH OF THE N BY M ELEMENTS OF'/
     +     '          SCLD MUST BE GREATER THAN ZERO.')
 3120 FORMAT
     +   (/' ERROR :  SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME J = 1, ..., M.'//
     +     '          WHEN SCLD(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDSCLD IS EQUAL TO ONE THEN'/
     +     '          EACH OF THE 1 BY M ELEMENTS OF'/
     +     '          SCLD MUST BE GREATER THAN ZERO.')
 3130 FORMAT
     +   (/' ERROR :  SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME K = 1, ..., NP.'//
     +     '          ALL NP ELEMENTS OF',
     +              ' SCLB MUST BE GREATER THAN ZERO.')
 3210 FORMAT
     +   (/' ERROR :  STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME I = 1, ..., N AND J = 1, ..., M.'//
     +     '          WHEN STPD(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/
     +     '          EACH OF THE N BY M ELEMENTS OF'/
     +     '          STPD MUST BE GREATER THAN ZERO.')
 3220 FORMAT
     +   (/' ERROR :  STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME J = 1, ..., M.'//
     +     '          WHEN STPD(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDSTPD IS EQUAL TO ONE THEN'/
     +     '          EACH OF THE 1 BY M ELEMENTS OF'/
     +     '          STPD MUST BE GREATER THAN ZERO.')
 3230 FORMAT
     +   (/' ERROR :  STPB(K) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME K = 1, ..., NP.'//
     +     '          ALL NP ELEMENTS OF',
     +              ' STPB MUST BE GREATER THAN ZERO.')
 3310 FORMAT
     +   (/' ERROR :  AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/
     +     '          IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/
     +     '          SEMIDEFINITE.  WHEN WE(1,1,1) IS GREATER THAN'/
     +     '          OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/
     +     '          EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/
     +     '          TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/
     +     '          MUST BE POSITIVE SEMIDEFINITE.')
 3320 FORMAT
     +   (/' ERROR :  AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/
     +     '          IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/
     +     '          ELEMENT.  WHEN WE(1,1,1) IS GREATER THAN OR'/
     +     '          EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/
     +     '          TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/
     +     '          (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/
     +     '          NEGATIVE ELEMENTS.')
 3410 FORMAT
     +   (/' ERROR :  THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/
     +     '          NOT POSITIVE SEMIDEFINITE.  WHEN WE(1,1,1) IS'/
     +     '          GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/
     +     '          TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/
     +     '          THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/
     +     '          SEMIDEFINITE.')
 3420 FORMAT
     +   (/' ERROR :  THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/
     +     '          A NEGATIVE ELEMENT.  WHEN WE(1,1,1) IS GREATER'/
     +     '          THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/
     +     '          AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/
     +     '          ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.')
 3500 FORMAT
     +   (/' ERROR :  THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/
     +     '          LESS THAN NP.')
 4310 FORMAT
     +   (/' ERROR :  AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/
     +     '          IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/
     +     '          DEFINITE.  WHEN WD(1,1,1) IS GREATER THAN ZERO,'/
     +     '          AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/
     +     '          LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/
     +     '          OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/
     +     '          DEFINITE.')
 4320 FORMAT
     +   (/' ERROR :  AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/
     +     '          IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/
     +     '          ELEMENT.  WHEN WD(1,1,1) IS GREATER THAN ZERO,'/
     +     '          AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/
     +     '          LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/
     +     '          ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.')
 4410 FORMAT
     +   (/' ERROR :  THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/
     +     '          NOT POSITIVE DEFINITE.  WHEN WD(1,1,1) IS'/
     +     '          GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/
     +     '          LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/
     +     '          (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.')
 4420 FORMAT
     +   (/' ERROR :  THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/
     +     '          NONPOSITIVE ELEMENT.  WHEN WD(1,1,1) IS GREATER'/
     +     '          THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/
     +     '          EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/
     +     '          HAVE ONLY POSITIVE ELEMENTS.')
      END
*DODPE2
      SUBROUTINE DODPE2
     +   (UNIT,
     +   N,M,NP,NQ,
     +   FJACB,FJACD,
     +   DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD,
     +   XPLUSD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPE2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  GENERATE THE DERIVATIVE CHECKING REPORT
C***END PROLOGUE  DODPE2

C...SCALAR ARGUMENTS
      INTEGER
     +   M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M)
      INTEGER
     +   MSGB(NQ,NP),MSGD(NQ,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J,K,L
      CHARACTER FLAG*1,TYP*3

C...LOCAL ARRAYS
      LOGICAL
     +   FTNOTE(0:7)

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FLAG:    THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS.
C   FTNOTE:  THE ARRAY CONTROLING FOOTNOTES.
C   I:       AN INDEX VARIABLE.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   J:       AN INDEX VARIABLE.
C   K:       AN INDEX VARIABLE.
C   L:       AN INDEX VARIABLE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGB1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   MSGD1:   THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES.
C   TYP:     THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DODPE2


C  SET UP FOR FOOTNOTES

      DO 10 I=0,7
         FTNOTE(I) = .FALSE.
   10 CONTINUE

      DO 40 L=1,NQ
         IF (MSGB1.GE.1) THEN
            DO 20 I=1,NP
               IF (MSGB(L,I).GE.1) THEN
                  FTNOTE(0) = .TRUE.
                  FTNOTE(MSGB(L,I)) = .TRUE.
               END IF
   20       CONTINUE
         END IF

         IF (MSGD1.GE.1) THEN
            DO 30 I=1,M
               IF (MSGD(L,I).GE.1) THEN
                  FTNOTE(0) = .TRUE.
                  FTNOTE(MSGD(L,I)) = .TRUE.
               END IF
   30       CONTINUE
         END IF
   40 CONTINUE

C     PRINT REPORT 

      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF
      WRITE (UNIT,1000) TYP

      DO 70 L=1,NQ

         WRITE (UNIT,2100) L,NROW
         WRITE (UNIT,2200)

         DO 50 I=1,NP
            K = MSGB(L,I)
            IF (K.GE.7) THEN
               FLAG = '*'
            ELSE
               FLAG = ' '
            END IF
            IF (K.LE.-1) THEN
               WRITE (UNIT,3100) I
            ELSE IF (K.EQ.0) THEN
               WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG
            ELSE IF (K.GE.1) THEN
               WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K
            END IF
   50    CONTINUE
         IF (ISODR) THEN
            DO 60 I=1,M
               K = MSGD(L,I)
               IF (K.GE.7) THEN
                  FLAG = '*'
               ELSE
                  FLAG = ' '
               END IF
               IF (K.LE.-1) THEN
                  WRITE (UNIT,4100) NROW,I
               ELSE IF (K.EQ.0) THEN
                  WRITE (UNIT,4200) NROW,I, 
     +                              FJACD(NROW,I,L),DIFF(L,NP+I),FLAG
               ELSE IF (K.GE.1) THEN
                  WRITE (UNIT,4300) NROW,I, 
     +                              FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K
               END IF
   60       CONTINUE
         END IF
   70 CONTINUE

C     PRINT FOOTNOTES

      IF (FTNOTE(0)) THEN

         WRITE (UNIT,5000)
         IF (FTNOTE(1)) WRITE (UNIT,5100)
         IF (FTNOTE(2)) WRITE (UNIT,5200)
         IF (FTNOTE(3)) WRITE (UNIT,5300)
         IF (FTNOTE(4)) WRITE (UNIT,5400)
         IF (FTNOTE(5)) WRITE (UNIT,5500)
         IF (FTNOTE(6)) WRITE (UNIT,5600)
         IF (FTNOTE(7)) WRITE (UNIT,5700)
      END IF

      IF (NETA.LT.0) THEN
         WRITE (UNIT,6000) -NETA
      ELSE
         WRITE (UNIT,6100) NETA
      END IF
      WRITE (UNIT,7000) NTOL

C  PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED.

      WRITE (UNIT,8100) NROW

      DO 80 J=1,M
         WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J)
   80 CONTINUE

      RETURN

C     FORMAT STATEMENTS

 1000 FORMAT
     +   (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3,
     +     ' ***'/)
 2100 FORMAT (/'     FOR RESPONSE ',I2,' OF OBSERVATION ', I5/)
 2200 FORMAT ('                      ','         USER',
     +           '               ','                '/
     +        '                      ','     SUPPLIED',
     +           '     RELATIVE','    DERIVATIVE '/
     +        '        DERIVATIVE WRT','        VALUE',
     +           '   DIFFERENCE','    ASSESSMENT '/)
 3100 FORMAT ('             BETA(',I3,')', '       ---   ',
     +            '       ---   ','    UNCHECKED')
 3200 FORMAT ('             BETA(',I3,')', 1P,2D13.2,3X,A1,
     +           'VERIFIED')
 3300 FORMAT ('             BETA(',I3,')', 1P,2D13.2,3X,A1,
     +           'QUESTIONABLE (SEE NOTE ',I1,')')
 4100 FORMAT ('          DELTA(',I2,',',I2,')', '       ---   ',
     +            '       ---   ','    UNCHECKED')
 4200 FORMAT ('          DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1,
     +           'VERIFIED')
 4300 FORMAT ('          DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1,
     +           'QUESTIONABLE (SEE NOTE ',I1,')')
 5000 FORMAT
     +   (/'     NOTES:')
 5100 FORMAT
     +   (/'      (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' AGREE, BUT'/
     +     '          RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.')
 5200 FORMAT
     +   (/'      (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' AGREE, BUT'/
     +     '          RESULTS ARE QUESTIONABLE BECAUSE ONE IS',
     +                   ' IDENTICALLY ZERO'/
     +     '          AND THE OTHER IS ONLY APPROXIMATELY ZERO.')
 5300 FORMAT
     +   (/'      (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT'/
     +     '          RESULTS ARE QUESTIONABLE BECAUSE ONE IS',
     +                   ' IDENTICALLY ZERO'/
     +     '          AND THE OTHER IS NOT.')
 5400 FORMAT
     +   (/'      (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT'/
     +     '          FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE',
     +                   ' BECAUSE EITHER'/
     +     '          THE RATIO OF RELATIVE CURVATURE TO RELATIVE',
     +                   ' SLOPE IS TOO HIGH'/
     +     '          OR THE SCALE IS WRONG.')
 5500 FORMAT
     +   (/'      (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT'/
     +     '          FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE',
     +                   ' BECAUSE THE'/
     +     '          RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS',
     +                   ' TOO HIGH.')
 5600 FORMAT
     +   (/'      (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, BUT'/
     +     '          HAVE AT LEAST 2 DIGITS IN COMMON.')
 5700 FORMAT
     +   (/'      (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES',
     +                   ' DISAGREE, AND'/
     +     '          HAVE FEWER THAN 2 DIGITS IN COMMON.  DERIVATIVE',
     +                   ' CHECKING MUST'/
     +     '          BE TURNED OFF IN ORDER TO PROCEED.')
 6000 FORMAT
     +   (/'     NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS       ',
     +        I5/
     +     '        (ESTIMATED BY ODRPACK)')
 6100 FORMAT
     +   (/'     NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS       ',
     +        I5/
     +     '        (SUPPLIED BY USER)')
 7000 FORMAT
     +   (/'     NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN      '/
     +     '     USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR  '/
     +     '     USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED  ',
     +        I5)
 8100 FORMAT
     +   (/'     ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED        ',
     +        I5//
     +     '       -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/)
 8110 FORMAT
     +   (10X,'X(',I2,',',I2,')',1X,1P,3D16.8)
      END
*DODPE3
      SUBROUTINE DODPE3
     +   (UNIT,D2,D3)
C***BEGIN PROLOGUE  DODPE3
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE
C            STOPPED IN USER SUPPLIED SUBROUTINES FCN
C***END PROLOGUE  DODPE3

C...SCALAR ARGUMENTS
      INTEGER
     +   D2,D3,UNIT

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   UNIT:    THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.


C***FIRST EXECUTABLE STATEMENT  DODPE3


C  PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE
C  STOPPED

      IF (D2.EQ.2) THEN
         WRITE(UNIT,1100)
      ELSE IF (D2.EQ.3) THEN
         WRITE(UNIT,1200)
      ELSE IF (D2.EQ.4) THEN
         WRITE(UNIT,1300)
      END IF
      IF (D3.EQ.2) THEN
         WRITE(UNIT,1400)
      END IF

C  FORMAT STATEMENTS

 1100 FORMAT
     +   (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  '/
     +      ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/
     +      ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE     '/
     +      ' USER.  THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW  '/
     +      ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE          '/
     +      ' REGRESSION PROCEDURE CAN CONTINUE.')
 1200 FORMAT
     +   (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  '/
     +      ' FROM USER SUPPLIED SUBROUTINE FCN.  THIS OCCURRED DURING'/
     +      ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/
     +      ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/
     +      ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/
     +      ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION),  '/
     +      ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/
     +      ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT   '/
     +      ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED.  THE      '/
     +      ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER      '/
     +      ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS  '/
     +      ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.')
 1300 FORMAT
     +   (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  '/
     +      ' FROM USER SUPPLIED SUBROUTINE FCN.  THIS OCCURRED DURING'/
     +      ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT      '/
     +      ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/
     +      ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR   '/
     +      ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS             '/
     +      ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA   '/
     +      ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN       '/
     +      ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN,      '/
     +      ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED.   '/
     +      ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER  '/
     +      ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS  '/
     +      ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.')
 1400 FORMAT
     +   (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE  '/
     +      ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/
     +      ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/
     +      ' BETA AND DELTA SUPPLIED BY THE USER.  THE INITIAL '/
     +      ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/
     +      ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/
     +      ' CONTINUE.')
      END
*DODPER
      SUBROUTINE DODPER
     +   (INFO,LUNERR,SHORT,
     +   N,M,NP,NQ,
     +   LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +   LWKMN,LIWKMN,
     +   FJACB,FJACD,
     +   DIFF,MSGB,ISODR,MSGD,
     +   XPLUSD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPER
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DODPE1,DODPE2,DODPE3,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS
C***END PROLOGUE  DODPER

C...SCALAR ARGUMENTS
      INTEGER
     +   INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN,
     +   M,N,NETA,NP,NQ,NROW,NTOL
      LOGICAL
     +   ISODR,SHORT

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M)
      INTEGER
     +   MSGB(NQ*NP+1),MSGD(NQ*M+1)

C...LOCAL SCALARS
      INTEGER
     +   D1,D2,D3,D4,D5,UNIT
      LOGICAL
     +   HEAD

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODPE1,DODPE2,DODPE3,DODPHD

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   MOD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   D1:      THE 1ST DIGIT (FROM THE LEFT) OF INFO.
C   D2:      THE 2ND DIGIT (FROM THE LEFT) OF INFO.
C   D3:      THE 3RD DIGIT (FROM THE LEFT) OF INFO.
C   D4:      THE 4TH DIGIT (FROM THE LEFT) OF INFO.
C   D5:      THE 5TH DIGIT (FROM THE LEFT) OF INFO.
C   DIFF:    THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND
C            FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
C   INFO:    THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
C   LDSCLD:  THE LEADING DIMENSION OF ARRAY SCLD.
C   LDSTPD:  THE LEADING DIMENSION OF ARRAY STPD.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LIWKMN:  THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
C   LUNERR:  THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   MSGB:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
C   MSGD:    THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NETA:    THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   NTOL:    THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C            FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES.
C   SHORT:   THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 
C            ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 
C            (SHORT=.FALSE.).
C   UNIT:    THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES.
C   XPLUSD:  THE VALUES X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DODPER


C  SET LOGICAL UNIT NUMBER FOR ERROR REPORT

      IF (LUNERR.EQ.0) THEN
         RETURN
      ELSE IF (LUNERR.LT.0) THEN
         UNIT = 6
      ELSE
         UNIT = LUNERR
      END IF

C  PRINT HEADING

      HEAD = .TRUE.
      CALL DODPHD(HEAD,UNIT)

C  EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO

      D1 = MOD(INFO,100000)/10000
      D2 = MOD(INFO,10000)/1000
      D3 = MOD(INFO,1000)/100
      D4 = MOD(INFO,100)/10
      D5 = MOD(INFO,10)

C  PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP

      IF (D1.GE.1 .AND. D1.LE.3) THEN

C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN
C     PROBLEM SPECIFICATION PARAMETERS
C     DIMENSION SPECIFICATION PARAMETERS
C     NUMBER OF GOOD DIGITS IN X
C     WEIGHTS

         CALL DODPE1(UNIT,D1,D2,D3,D4,D5,
     +               N,M,NQ,
     +               LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
     +               LWKMN,LIWKMN)

      ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN

C  PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING

         CALL DODPE2(UNIT,
     +                N,M,NP,NQ,
     +                FJACB,FJACD,
     +                DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2),
     +                XPLUSD,NROW,NETA,NTOL)

      ELSE IF (D1.EQ.5) THEN

C  PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN

         CALL DODPE3(UNIT,D2,D3)

      END IF

C  PRINT CORRECT FORM OF CALL STATEMENT

      IF ((D1.GE.1 .AND. D1.LE.3) .OR.
     +    (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. 
     +    (D1.EQ.5)) THEN
         IF (SHORT) THEN
            WRITE (UNIT,1100)
         ELSE
            WRITE (UNIT,1200)
         END IF
      END IF

      RETURN

C  FORMAT STATEMENTS

 1100 FORMAT
     +   (//' THE CORRECT FORM OF THE CALL STATEMENT IS '//
     +      '       CALL DODR'/
     +      '      +     (FCN,'/
     +      '      +     N,M,NP,NQ,'/
     +      '      +     BETA,'/
     +      '      +     Y,LDY,X,LDX,'/
     +      '      +     WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/
     +      '      +     JOB,'/
     +      '      +     IPRINT,LUNERR,LUNRPT,'/
     +      '      +     WORK,LWORK,IWORK,LIWORK,'/
     +      '      +     INFO)')
 1200 FORMAT
     +   (//' THE CORRECT FORM OF THE CALL STATEMENT IS '//
     +      '       CALL DODRC'/
     +      '      +     (FCN,'/
     +      '      +     N,M,NP,NQ,'/
     +      '      +     BETA,'/
     +      '      +     Y,LDY,X,LDX,'/
     +      '      +     WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/
     +      '      +     IFIXB,IFIXX,LDIFX,'/
     +      '      +     JOB,NDIGIT,TAUFAC,'/
     +      '      +     SSTOL,PARTOL,MAXIT,'/
     +      '      +     IPRINT,LUNERR,LUNRPT,'/
     +      '      +     STPB,STPD,LDSTPD,'/
     +      '      +     SCLB,SCLD,LDSCLD,'/
     +      '      +     WORK,LWORK,IWORK,LIWORK,'/
     +      '      +     INFO)')

      END
*DODPHD
      SUBROUTINE DODPHD
     +   (HEAD,UNIT)
C***BEGIN PROLOGUE  DODPHD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  PRINT ODRPACK HEADING
C***END PROLOGUE  DODPHD

C...SCALAR ARGUMENTS
      INTEGER
     +   UNIT
      LOGICAL
     +   HEAD

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   HEAD:    THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 
C            PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
C   UNIT:    THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN.


C***FIRST EXECUTABLE STATEMENT  DODPHD


      IF (HEAD) THEN
         WRITE(UNIT,1000)
         HEAD = .FALSE.
      END IF

      RETURN

C   FORMAT STATEMENTS

 1000 FORMAT (
     +   ' ******************************************************* '/
     +   ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/
     +   ' ******************************************************* '/)
      END
*DODSTP
      SUBROUTINE DODSTP
     +   (N,M,NP,NQ,NPP,
     +   F,FJACB,FJACD,
     +   WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +   ALPHA,EPSFCN,ISODR,
     +   TFJACB,OMEGA,U,QRAUX,KPVT,
     +   S,T,PHI,IRANK,RCOND,FORVCV,
     +   WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODSTP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT,
C                    DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA)
C***END PROLOGUE  DODSTP

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   ALPHA,EPSFCN,PHI,RCOND
      INTEGER
     +   IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP),
     +   T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M),
     +   WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK)
      INTEGER
     +   KPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   CO,ONE,SI,TEMP,ZERO
      INTEGER
     +   I,IMAX,INF,IPVT,J,K,K1,K2,KP,L
      LOGICAL
     +   ELIM,FORVCV

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   DUM(2)

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DNRM2
      INTEGER
     +   IDAMAX
      EXTERNAL
     +   DNRM2,IDAMAX

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG,
     +   DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE
     +   /0.0D0,1.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ALPHA:   THE LEVENBERG-MARQUARDT PARAMETER.
C   CO:      THE COSINE FROM THE PLANE ROTATION.
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   DUM:     A DUMMY ARRAY.
C   ELIM:    THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN 
C            WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT
C            (ELIM=FALSE).
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IMAX:    THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE
C            VALUE.
C   INF:     THE RETURN CODE FROM LINPACK ROUTINES.
C   IPVT:    THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 
C            STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   K1:      AN INDEXING VARIABLE.
C   K2:      AN INDEXING VARIABLE.
C   KP:      THE RANK OF THE JACOBIAN WRT BETA.
C   KPVT:    THE PIVOT VECTOR.
C   L:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   OMEGA:   THE ARRAY DEFINED S.T. 
C            OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD))
C                               = (I-FJACD*INV(P)*TRANS(FJACD)) 
C            WHERE E = D**2 + ALPHA*TT**2
C                  P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   ONE:     THE VALUE 1.0D0.
C   PHI:     THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C            AND THE TRUST REGION DIAMETER.
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB.
C   S:       THE STEP FOR BETA.
C   SI:      THE SINE FROM THE PLANE ROTATION.
C   SS:      THE SCALING VALUES FOR THE UNFIXED BETAS.
C   T:       THE STEP FOR DELTA.
C   TEMP:    A TEMPORARY STORAGE LOCATION.
C   TFJACB:  THE ARRAY OMEGA*FJACB.
C   TT:      THE SCALING VALUES FOR DELTA.
C   U:       THE APPROXIMATE NULL VECTOR FOR TFJACB.
C   WD:      THE (SQUARED) DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS, 
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODSTP


C  COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE

C  SET UP KPVT IF ALPHA = 0

      IF (ALPHA.EQ.ZERO) THEN
         KP = NPP
         DO 10 K=1,NP
            KPVT(K) = K
   10    CONTINUE
      ELSE
         IF (NPP.GE.1) THEN
            KP = NPP-IRANK
         ELSE
            KP = NPP
         END IF
      END IF

      IF (ISODR) THEN

C  T = WD * DELTA = D*G2
         CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N)

         DO 300 I=1,N

C  COMPUTE WRK4, SUCH THAT
C                TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2)
            CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
            CALL DFCTR(.FALSE.,WRK4,M,M,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE OMEGA, SUCH THAT
C                 TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD)
C                 INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD)
            CALL DVEVTR(M,NQ,I,
     +                   FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5)
            DO 110 L=1,NQ
               OMEGA(L,L) = ONE + OMEGA(L,L) 
  110       CONTINUE
            CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD))
C               = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA)
            DO 130 J=1,M
               DO 120 L=1,NQ
                  WRK1(I,L,J) = FJACD(I,J,L)
  120          CONTINUE
               CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4)
               CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2)
  130       CONTINUE

C  COMPUTE WRK5 = INV(E)*D*G2
            DO 140 J=1,M
               WRK5(J) = T(I,J)
  140       CONTINUE
            CALL DSOLVE(M,WRK4,M,WRK5,1,4)
            CALL DSOLVE(M,WRK4,M,WRK5,1,2)

C  COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB
            DO 170 K=1,KP
               DO 150 L=1,NQ
                  TFJACB(I,L,K) = FJACB(I,KPVT(K),L)
  150          CONTINUE
               CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4)
               DO 160 L=1,NQ
                  IF (SS(1).GT.ZERO) THEN
                     TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K))
                  ELSE
                     TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1))
                  END IF
  160          CONTINUE
  170       CONTINUE

C  COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1)
            DO 190 L=1,NQ
               WRK2(I,L) = ZERO
               DO 180 J=1,M
                  WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J)
  180          CONTINUE
               WRK2(I,L) = WRK2(I,L) - F(I,L)
  190       CONTINUE

C  COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1)
            CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4)
  300    CONTINUE

      ELSE
         DO 360 I=1,N
            DO 350 L=1,NQ
               DO 340 K=1,KP
                  TFJACB(I,L,K) = FJACB(I,KPVT(K),L)
                  IF (SS(1).GT.ZERO) THEN
                     TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K))
                  ELSE
                     TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1))
                  END IF
  340          CONTINUE
               WRK2(I,L) = -F(I,L)
  350       CONTINUE
  360    CONTINUE
      END IF

C  COMPUTE S

C  DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0)

      IF (ALPHA.EQ.ZERO) THEN
         IPVT = 1
         DO 410 K=1,NP
            KPVT(K) = 0
  410    CONTINUE
      ELSE
         IPVT = 0
      END IF

      CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT)
      CALL DQRSL(TFJACB,N*NQ,N*NQ,KP,
     +           QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF)
      IF (INF.NE.0) THEN
         ISTOPC = 60000
         RETURN
      END IF

C  ELIMINATE ALPHA PART USING GIVENS ROTATIONS

      IF (ALPHA.NE.ZERO) THEN
         CALL DZERO(NPP,1,S,NPP)
         DO 430 K1=1,KP
            CALL DZERO(KP,1,WRK3,KP)
            WRK3(K1) = SQRT(ALPHA)
            DO 420 K2=K1,KP
               CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI)
               IF (KP-K2.GE.1) THEN
                  CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ,
     +                      WRK3(K2+1),1,CO,SI)
               END IF
               TEMP       =  CO*WRK2(K2,1) + SI*S(KPVT(K1)) 
               S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1))
               WRK2(K2,1)      = TEMP
  420       CONTINUE
  430    CONTINUE
      END IF

C  COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY

      IF (NPP.GE.1) THEN
         IF (ALPHA.EQ.ZERO) THEN
            KP = NPP

C  ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR

  440       CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1)
            IF (RCOND.LE.EPSFCN) THEN
               ELIM = .TRUE.
               IMAX = IDAMAX(KP,U,1)

C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT

               IF (IMAX.NE.KP) THEN
                  CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1,
     +                       QRAUX,WRK3,2)
                  K = KPVT(IMAX)
                  DO 450 I=IMAX,KP-1
                     KPVT(I) = KPVT(I+1)
  450             CONTINUE
                  KPVT(KP) = K
               END IF
               KP = KP-1
            ELSE
               ELIM = .FALSE.
            END IF
            IF (ELIM .AND. KP.GE.1) THEN
               GO TO 440
            ELSE
               IRANK = NPP-KP
            END IF
         END IF
      END IF

      IF (FORVCV) RETURN

C  BACKSOLVE AND UNSCRAMBLE

      IF (NPP.GE.1) THEN
         DO 510 I=KP+1,NPP
            WRK2(I,1) = ZERO
  510    CONTINUE
         IF (KP.GE.1) THEN
            CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF
         END IF
         DO 520 I=1,NPP
            IF (SS(1).GT.ZERO) THEN
               S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I))
            ELSE
               S(KPVT(I)) = WRK2(I,1)/ABS(SS(1))
            END IF
  520    CONTINUE
      END IF

      IF (ISODR) THEN

C  NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE,
C        WHERE T    = WD * DELTA = D*G2
C              WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD))

         DO 670 I=1,N

C  COMPUTE WRK4, SUCH THAT
C                TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2)
            CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
            CALL DFCTR(.FALSE.,WRK4,M,M,INF)
            IF (INF.NE.0) THEN
               ISTOPC = 60000
               RETURN
            END IF

C  COMPUTE WRK5 = INV(E)*D*G2
            DO 610 J=1,M
               WRK5(J) = T(I,J)
  610       CONTINUE
            CALL DSOLVE(M,WRK4,M,WRK5,1,4)
            CALL DSOLVE(M,WRK4,M,WRK5,1,2)

            DO 640 L=1,NQ
               WRK2(I,L) = F(I,L) 
               DO 620 K=1,NPP
                  WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K)
  620          CONTINUE
               DO 630 J=1,M
                  WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J)
  630          CONTINUE
  640       CONTINUE

            DO 660 J=1,M
               WRK5(J) = ZERO
               DO 650 L=1,NQ
                  WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L)
  650          CONTINUE
               T(I,J) = -(WRK5(J) + T(I,J))
  660       CONTINUE
            CALL DSOLVE(M,WRK4,M,T(I,1),N,4)
            CALL DSOLVE(M,WRK4,M,T(I,1),N,2)
  670    CONTINUE

      END IF

C  COMPUTE PHI(ALPHA) FROM SCALED S AND T

      CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
      IF (ISODR) THEN
         CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
         PHI = DNRM2(NPP+N*M,WRK,1)
      ELSE
         PHI = DNRM2(NPP,WRK,1)
      END IF

      RETURN
      END
*DODVCV
      SUBROUTINE DODVCV
     +   (N,M,NP,NQ,NPP,
     +    F,FJACB,FJACD,
     +    WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA,
     +    EPSFCN,ISODR,
     +    VCV,SD,
     +    WRK6,OMEGA,U,QRAUX,JPVT,
     +    S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB,
     +    WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
C***BEGIN PROLOGUE  DODVCV
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPODI,DODSTP
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C***END PROLOGUE  DODVCV

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   EPSFCN,RCOND,RSS,RVAR
      INTEGER
     +   IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
      LOGICAL 
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   DELTA(N,M),F(N,NQ),
     +   FJACB(N,NP,NQ),FJACD(N,M,NQ),
     +   OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP),
     +   T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M),
     +   WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),
     +   WRK6(N*NQ,NP),WRK(LWRK)
      INTEGER
     +   IFIXB(NP),JPVT(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   I,IUNFIX,J,JUNFIX,KP,L
      LOGICAL
     +   FORVCV

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DPODI,DODSTP

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   DELTA:   THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES.
C   EPSFCN:  THE FUNCTION'S PRECISION.
C   F:       THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
C   FJACB:   THE JACOBIAN WITH RESPECT TO BETA.
C   FJACD:   THE JACOBIAN WITH RESPECT TO DELTA.
C   FORVCV:  THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS 
C            CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 
C            (FORVCV=TRUE) OR NOT (FORVCV=FALSE).
C   I:       AN INDEXING VARIABLE.
C   IDF:     THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF
C            OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE
C            NUMBER OF PARAMETERS BEING ESTIMATED.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IMAX:    THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE
C            VALUE.
C   IRANK:   THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   ISTOPC:  THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE
C            STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP.
C   IUNFIX:  THE INDEX OF THE NEXT UNFIXED PARAMETER.
C   J:       AN INDEXING VARIABLE.
C   JPVT:    THE PIVOT VECTOR.
C   JUNFIX:  THE INDEX OF THE NEXT UNFIXED PARAMETER.
C   KP:      THE RANK OF THE JACOBIAN WRT BETA.
C   L:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDWD:    THE LEADING DIMENSION OF ARRAY WD.
C   LD2WD:   THE SECOND DIMENSION OF ARRAY WD.
C   LWRK:    THE LENGTH OF VECTOR WRK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NPP:     THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OMEGA:   THE ARRAY DEFINED S.T.
C            OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD))
C                               = (I-FJACD*INV(P)*TRANS(FJACD))
C            WHERE E = D**2 + ALPHA*TT**2
C                  P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2
C   QRAUX:   THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C            Q-R DECOMPOSITION.
C   RCOND:   THE APPROXIMATE RECIPROCAL CONDITION OF FJACB.
C   RSS:     THE RESIDUAL SUM OF SQUARES.
C   RVAR:    THE RESIDUAL VARIANCE.
C   S:       THE STEP FOR BETA.
C   SD:      THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS.
C   SS:      THE SCALING VALUES FOR THE UNFIXED BETAS.
C   SSF:     THE SCALING VALUES USED FOR BETA.
C   T:       THE STEP FOR DELTA.
C   TEMP:    A TEMPORARY STORAGE LOCATION
C   TT:      THE SCALING VALUES FOR DELTA.
C   U:       THE APPROXIMATE NULL VECTOR FOR FJACB.
C   VCV:     THE COVARIANCE MATRIX OF THE ESTIMATED BETAS.
C   WD:      THE DELTA WEIGHTS.
C   WRK:     A WORK ARRAY OF (LWRK) ELEMENTS,
C            EQUIVALENCED TO WRK1 AND WRK2.
C   WRK1:    A WORK ARRAY OF (N BY NQ BY M) ELEMENTS.
C   WRK2:    A WORK ARRAY OF (N BY NQ) ELEMENTS.
C   WRK3:    A WORK ARRAY OF (NP) ELEMENTS.
C   WRK4:    A WORK ARRAY OF (M BY M) ELEMENTS.
C   WRK5:    A WORK ARRAY OF (M) ELEMENTS.
C   WRK6:    A WORK ARRAY OF (N*NQ BY P) ELEMENTS.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DODVCV


      FORVCV = .TRUE.
      ISTOPC = 0

      CALL DODSTP(N,M,NP,NQ,NPP,
     +            F,FJACB,FJACD,
     +            WD,LDWD,LD2WD,SS,TT,LDTT,DELTA,
     +            ZERO,EPSFCN,ISODR,
     +            WRK6,OMEGA,U,QRAUX,JPVT,
     +            S,T,TEMP,IRANK,RCOND,FORVCV,
     +            WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC)
      IF (ISTOPC.NE.0) THEN
         RETURN
      END IF
      KP = NPP - IRANK
      CALL DPODI (WRK6,N*NQ,KP,WRK3,1)

      IDF = 0
      DO 150 I=1,N
         DO 120 J=1,NPP
            DO 110 L=1,NQ
               IF (FJACB(I,J,L).NE.ZERO) THEN
                  IDF = IDF + 1
                  GO TO 150
               END IF
  110       CONTINUE
  120    CONTINUE
         IF (ISODR) THEN
            DO 140 J=1,M
               DO 130 L=1,NQ
                  IF (FJACD(I,J,L).NE.ZERO) THEN
                     IDF = IDF + 1
                     GO TO 150
                  END IF
  130          CONTINUE
  140       CONTINUE
         END IF
  150 CONTINUE

      IF (IDF.GT.KP) THEN
         IDF = IDF - KP
         RVAR = RSS/IDF
      ELSE
         IDF = 0
         RVAR = RSS
      END IF

C  STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER

      DO 200 I=1,NP
         SD(I) = ZERO
  200 CONTINUE
      DO 210 I=1,KP
         SD(JPVT(I)) = WRK6(I,I)
  210 CONTINUE
      IF (NP.GT.NPP) THEN
         JUNFIX = NPP
         DO 220 J=NP,1,-1
            IF (IFIXB(J).EQ.0) THEN
               SD(J) = ZERO
            ELSE
               SD(J) = SD(JUNFIX)
               JUNFIX = JUNFIX - 1
            END IF
  220    CONTINUE
      END IF

C  STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER

      DO 310 I=1,NP
         DO 300 J=1,I
            VCV(I,J) = ZERO
  300    CONTINUE
  310 CONTINUE
      DO 330 I=1,KP
         DO 320 J=I+1,KP
            IF (JPVT(I).GT.JPVT(J)) THEN
               VCV(JPVT(I),JPVT(J))=WRK6(I,J)
            ELSE
               VCV(JPVT(J),JPVT(I))=WRK6(I,J)
            END IF
  320    CONTINUE
  330 CONTINUE
      IF (NP.GT.NPP) THEN
         IUNFIX = NPP
         DO 360 I=NP,1,-1
            IF (IFIXB(I).EQ.0) THEN
               DO 340 J=I,1,-1
                  VCV(I,J) = ZERO
  340          CONTINUE
            ELSE
               JUNFIX = NPP
               DO 350 J=NP,1,-1
                  IF (IFIXB(J).EQ.0) THEN
                     VCV(I,J) = ZERO
                  ELSE
                     VCV(I,J) = VCV(IUNFIX,JUNFIX)
                     JUNFIX = JUNFIX - 1
                  END IF
  350          CONTINUE
               IUNFIX = IUNFIX - 1
            END IF
  360    CONTINUE
      END IF

      DO 380 I=1,NP
         VCV(I,I) = SD(I)
         SD(I) = SQRT(RVAR*SD(I))
         DO 370 J=1,I
            VCV(J,I) = VCV(I,J)
  370    CONTINUE
  380 CONTINUE

C  UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX
      DO 410 I=1,NP
         IF (SSF(1).GT.ZERO) THEN
            SD(I) = SD(I)/SSF(I)
         ELSE
            SD(I) = SD(I)/ABS(SSF(1))
         END IF
         DO 400 J=1,NP
            IF (SSF(1).GT.ZERO) THEN
               VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J))
            ELSE
               VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1))
            END IF
  400    CONTINUE
  410 CONTINUE

      RETURN
      END
*DPACK
      SUBROUTINE DPACK
     +   (N2,N1,V1,V2,IFIX)
C***BEGIN PROLOGUE  DPACK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DCOPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1
C***END PROLOGUE  DPACK

C...SCALAR ARGUMENTS
      INTEGER
     +   N1,N2

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V1(N2),V2(N2)
      INTEGER
     +   IFIX(N2)

C...LOCAL SCALARS
      INTEGER
     +   I

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   N1:      THE NUMBER OF ITEMS IN V1.
C   N2:      THE NUMBER OF ITEMS IN V2.
C   V1:      THE VECTOR OF THE UNFIXED ITEMS FROM V2.
C   V2:      THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE
C            UNFIXED ELEMENTS ARE TO BE EXTRACTED.


C***FIRST EXECUTABLE STATEMENT  DPACK


      N1 = 0
      IF (IFIX(1).GE.0) THEN
         DO 10 I=1,N2
            IF (IFIX(I).NE.0) THEN
               N1 = N1+1
               V1(N1) = V2(I)
            END IF
   10    CONTINUE
      ELSE
         N1 = N2
         CALL DCOPY(N2,V2,1,V1,1)
      END IF

      RETURN
      END
*DPPNML
      DOUBLE PRECISION FUNCTION DPPNML
     +   (P)
C***BEGIN PROLOGUE  DPPNML
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***AUTHOR  FILLIBEN, JAMES J.,
C             STATISTICAL ENGINEERING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, D. C. 20234
C             (ORIGINAL VERSION--JUNE      1972.
C             (UPDATED         --SEPTEMBER 1975, 
C                                NOVEMBER  1975, AND
C                                OCTOBER   1976.
C***PURPOSE  COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE
C            NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD
C            DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION
C            F(X) = (1/SQRT(2*PI))*EXP(-X*X/2).
C            (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS
C            TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY)
C***DESCRIPTION
C               --THE CODING AS PRESENTED BELOW IS ESSENTIALLY 
C                 IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS
C                 AS ALGORTIHM 70 OF APPLIED STATISTICS.
C               --AS POINTED OUT BY ODEH AND EVANS IN APPLIED 
C                 STATISTICS, THEIR ALGORITHM REPRESENTES A
C                 SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED
C                 HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT 
C                 FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4)
C                 TO 1.5*(10**-8).
C***REFERENCES  ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL 
C                 DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, 
C                 PAGES 96-97.
C               EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND 
C                 RATIONAL APPROXIMATION, M. SC. THESIS, 1972, 
C                 UNIVERSITY OF VICTORIA, B. C., CANADA.
C               HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, 
C                 PAGES 113, 191, 192.
C               NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS
C                 SERIES 55, 1964, PAGE 933, FORMULA 26.2.23.
C               FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE 
C                 LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION 
C                 (UNPUBLISHED PH.D. DISSERTATION, PRINCETON 
C                 UNIVERSITY), 1969, PAGES 21-44, 229-231.
C               FILLIBEN, "THE PERCENT POINT FUNCTION",
C                 (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31.
C               JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS,
C                 VOLUME 1, 1970, PAGES 40-111.
C               KELLEY STATISTICAL TABLES, 1948.
C               OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16.
C               PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR 
C                 STATISTICIANS, VOLUME 1, 1954, PAGES 104-113.
C***END PROLOGUE  DPPNML

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO

C...INTRINSIC FUNCTIONS
      INTRINSIC 
     +   LOG,SQRT

C...DATA STATEMENTS
      DATA 
     +   P0,P1,P2,P3,P4
     +   /-0.322232431088D0,-1.0D0,-0.342242088547D0,
     +    -0.204231210245D-1,-0.453642210148D-4/ 
      DATA 
     +   Q0,Q1,Q2,Q3,Q4
     +   /0.993484626060D-1,0.588581570495D0, 
     +    0.531103462366D0,0.103537752850D0,0.38560700634D-2/ 
      DATA 
     +   ZERO,HALF,ONE,TWO
     +   /0.0D0,0.5D0,1.0D0,2.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ADEN:    A VALUE USED IN THE APPROXIMATION.
C   ANUM:    A VALUE USED IN THE APPROXIMATION.
C   HALF:    THE VALUE 0.5D0.
C   ONE:     THE VALUE 1.0D0.
C   P:       THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE 
C            EVALUATED.  P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. 
C   P0:      A PARAMETER USED IN THE APPROXIMATION.
C   P1:      A PARAMETER USED IN THE APPROXIMATION.
C   P2:      A PARAMETER USED IN THE APPROXIMATION.
C   P3:      A PARAMETER USED IN THE APPROXIMATION.
C   P4:      A PARAMETER USED IN THE APPROXIMATION.
C   Q0:      A PARAMETER USED IN THE APPROXIMATION.
C   Q1:      A PARAMETER USED IN THE APPROXIMATION.
C   Q2:      A PARAMETER USED IN THE APPROXIMATION.
C   Q3:      A PARAMETER USED IN THE APPROXIMATION.
C   Q4:      A PARAMETER USED IN THE APPROXIMATION.
C   R:       THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED.
C   T:       A VALUE USED IN THE APPROXIMATION.
C   TWO:     THE VALUE 2.0D0.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DPPT


      IF (P.EQ.HALF) THEN
         DPPNML = ZERO

      ELSE
         R = P
         IF (P.GT.HALF) R = ONE - R 
         T = SQRT(-TWO*LOG(R)) 
         ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0)
         ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0)
         DPPNML = T + (ANUM/ADEN)

         IF (P.LT.HALF) DPPNML = -DPPNML
      END IF

      RETURN

      END
*DPPT
      DOUBLE PRECISION FUNCTION DPPT
     +   (P, IDF)
C***BEGIN PROLOGUE  DPPT
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPPNML
C***DATE WRITTEN   901207   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***AUTHOR  FILLIBEN, JAMES J.,
C             STATISTICAL ENGINEERING DIVISION
C             NATIONAL BUREAU OF STANDARDS
C             WASHINGTON, D. C. 20234
C             (ORIGINAL VERSION--OCTOBER   1975.)
C             (UPDATED         --NOVEMBER  1975.)
C***PURPOSE  COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE
C            STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM.
C            (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS
C            TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY)
C***DESCRIPTION
C              --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION
C                FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM
C                AND SO THE COMPUTED PERCENT POINTS ARE EXACT.
C              --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION
C                IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO
C                IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1.
C***REFERENCES  NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS
C                 SERIES 55, 1964, PAGE 949, FORMULA 26.7.5.
C               JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS,
C                 VOLUME 2, 1970, PAGE 102, FORMULA 11.
C               FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS
C                 OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN
C                 STATISTICAL ASSOCIATION, 1969, PAGES 683-688.
C               HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A
C                 HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975,
C                 PAGES 120-123.
C***END PROLOGUE  DPPT

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   P
      INTEGER
     +   IDF

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45,
     +   B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN,
     +   HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO,
     +   Z,ZERO
      INTEGER
     +   IPASS,MAXIT

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DPPNML
      EXTERNAL 
     +   DPPNML

C...INTRINSIC FUNCTIONS
      INTRINSIC 
     +   ATAN,COS,SIN,SQRT

C...DATA STATEMENTS
      DATA 
     +   B21 
     +   /4.0D0/
      DATA 
     +   B31, B32, B33, B34 
     +   /96.0D0,5.0D0,16.0D0,3.0D0/
      DATA 
     +   B41, B42, B43, B44, B45
     +  /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ 
      DATA 
     +   B51,B52,B53,B54,B55,B56
     +   /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ 
      DATA 
     +   ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN
     +   /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ARG:    A VALUE USED IN THE APPROXIMATION.
C   B21:    A PARAMETER USED IN THE APPROXIMATION.
C   B31:    A PARAMETER USED IN THE APPROXIMATION.
C   B32:    A PARAMETER USED IN THE APPROXIMATION.
C   B33:    A PARAMETER USED IN THE APPROXIMATION.
C   B34:    A PARAMETER USED IN THE APPROXIMATION.
C   B41:    A PARAMETER USED IN THE APPROXIMATION.
C   B42:    A PARAMETER USED IN THE APPROXIMATION.
C   B43:    A PARAMETER USED IN THE APPROXIMATION.
C   B44:    A PARAMETER USED IN THE APPROXIMATION.
C   B45:    A PARAMETER USED IN THE APPROXIMATION.
C   B51:    A PARAMETER USED IN THE APPROXIMATION.
C   B52:    A PARAMETER USED IN THE APPROXIMATION.
C   B53:    A PARAMETER USED IN THE APPROXIMATION.
C   B54:    A PARAMETER USED IN THE APPROXIMATION.
C   B55:    A PARAMETER USED IN THE APPROXIMATION.
C   B56:    A PARAMETER USED IN THE APPROXIMATION.
C   C:      A VALUE USED IN THE APPROXIMATION.
C   CON:    A VALUE USED IN THE APPROXIMATION.
C   DF:     THE DEGREES OF FREEDOM.
C   D1:     A VALUE USED IN THE APPROXIMATION.
C   D3:     A VALUE USED IN THE APPROXIMATION.
C   D5:     A VALUE USED IN THE APPROXIMATION.
C   D7:     A VALUE USED IN THE APPROXIMATION.
C   D9:     A VALUE USED IN THE APPROXIMATION.
C   EIGHT:  THE VALUE 8.0D0.
C   FIFTN:  THE VALUE 15.0D0.
C   HALF:   THE VALUE 0.5D0.
C   IDF:    THE (POSITIVE INTEGER) DEGREES OF FREEDOM.
C   IPASS:  A VALUE USED IN THE APPROXIMATION.
C   MAXIT:  THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX.
C   ONE:    THE VALUE 1.0D0.
C   P:      THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE
C           EVALUATED.  P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE.
C   PI:     THE VALUE OF PI.
C   PPFN:   THE NORMAL PERCENT POINT VALUE.
C   S:      A VALUE USED IN THE APPROXIMATION.
C   TERM1:  A VALUE USED IN THE APPROXIMATION.
C   TERM2:  A VALUE USED IN THE APPROXIMATION.
C   TERM3:  A VALUE USED IN THE APPROXIMATION.
C   TERM4:  A VALUE USED IN THE APPROXIMATION.
C   TERM5:  A VALUE USED IN THE APPROXIMATION.
C   THREE:  THE VALUE 3.0D0.
C   TWO:    THE VALUE 2.0D0.
C   Z:      A VALUE USED IN THE APPROXIMATION.
C   ZERO:   THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DPPT


      PI = 3.141592653589793238462643383279D0
      DF = IDF
      MAXIT = 5

      IF (IDF.LE.0) THEN

C  TREAT THE IDF < 1 CASE
         DPPT = ZERO

      ELSE IF (IDF.EQ.1) THEN

C  TREAT THE IDF = 1 (CAUCHY) CASE
         ARG = PI*P
         DPPT = -COS(ARG)/SIN(ARG)

      ELSE IF (IDF.EQ.2) THEN

C  TREAT THE IDF = 2 CASE
         TERM1 = SQRT(TWO)/TWO
         TERM2 = TWO*P - ONE
         TERM3 = SQRT(P*(ONE-P)) 
         DPPT = TERM1*TERM2/TERM3

      ELSE IF (IDF.GE.3) THEN

C  TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE
         PPFN = DPPNML(P)
         D1 = PPFN
         D3 = PPFN**3
         D5 = PPFN**5
         D7 = PPFN**7
         D9 = PPFN**9
         TERM1 = D1
         TERM2 = (ONE/B21)*(D3+D1)/DF
         TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2)
         TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) 
         TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4)
         DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5

         IF (IDF.EQ.3) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 3 CASE
            CON = PI*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 70 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - (Z+S*C-CON)/(TWO*C**2)
   70       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.4) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 4 CASE
            CON = TWO*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 90 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3)
   90       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.5) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 5 CASE

            CON = PI*(P-HALF)
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 110 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/
     +                 ((EIGHT/THREE)*C**4) 
  110       CONTINUE
            DPPT = SQRT(DF)*S/C

         ELSE IF (IDF.EQ.6) THEN

C  AUGMENT THE RESULTS FOR THE IDF = 6 CASE
            CON = TWO*(P-HALF) 
            ARG = DPPT/SQRT(DF)
            Z = ATAN(ARG)
            DO 130 IPASS=1,MAXIT
               S = SIN(Z)
               C = COS(Z)
               Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/
     +                 ((FIFTN/EIGHT)*C**5)
  130       CONTINUE
            DPPT = SQRT(DF)*S/C
         END IF
      END IF

      RETURN

      END
*DPVB
      SUBROUTINE DPVB
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,J,LQ,STP,
     +    ISTOP,NFEV,PVB,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DPVB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP
C***END PROLOGUE  DPVB

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PVB,STP
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BETAJ

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BETAJ:   THE CURRENT ESTIMATE OF THE JTH PARAMETER.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   PVB:     THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DPVB


C  COMPUTE PREDICTED VALUES

      BETAJ = BETA(J)
      BETA(J) = BETA(J) + STP
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         003,WRK2,WRK6,WRK1,
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      ELSE
         RETURN
      END IF
      BETA(J) = BETAJ

      PVB = WRK2(NROW,LQ)

      RETURN
      END
*DPVD
      SUBROUTINE DPVD
     +   (FCN,
     +    N,M,NP,NQ,
     +    BETA,XPLUSD,IFIXB,IFIXX,LDIFX,
     +    NROW,J,LQ,STP,
     +    ISTOP,NFEV,PVD,
     +    WRK1,WRK2,WRK6)
C***BEGIN PROLOGUE  DPVD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  FCN
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE NROW-TH FUNCTION VALUE USING
C            X(NROW,J) + DELTA(NROW,J) + STP
C***END PROLOGUE  DPVD

C...SCALAR ARGUMENTS
      DOUBLE PRECISION
     +   PVD,STP
      INTEGER
     +   ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M)
      INTEGER
     +   IFIXB(NP),IFIXX(LDIFX,M)

C...SUBROUTINE ARGUMENTS
      EXTERNAL
     +   FCN

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   XPDJ

C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS
C   FCN:     THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL.

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   IFIXB:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   IFIXX:   THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE
C            FIXED AT THEIR INPUT VALUES OR NOT.
C   ISTOP:   THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 
C            COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA.
C   J:       THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
C   LDIFX:   THE LEADING DIMENSION OF ARRAY IFIXX.
C   LQ:      THE RESPONSE CURRENTLY BEING EXAMINED.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NFEV:    THE NUMBER OF FUNCTION EVALUATIONS. 
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   NROW:    THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT
C            WHICH THE DERIVATIVE IS TO BE CHECKED.
C   PVD:     THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE.
C   STP:     THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C   XPDJ:    THE (NROW,J)TH ELEMENT OF XPLUSD.
C   XPLUSD:  THE VALUES OF X + DELTA.


C***FIRST EXECUTABLE STATEMENT  DPVD


C  COMPUTE PREDICTED VALUES

      XPDJ = XPLUSD(NROW,J)
      XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP
      ISTOP = 0
      CALL FCN(N,M,NP,NQ,
     +         N,M,NP,
     +         BETA,XPLUSD,
     +         IFIXB,IFIXX,LDIFX,
     +         003,WRK2,WRK6,WRK1,
     +         ISTOP)
      IF (ISTOP.EQ.0) THEN
         NFEV = NFEV + 1
      ELSE
         RETURN
      END IF
      XPLUSD(NROW,J) = XPDJ

      PVD = WRK2(NROW,LQ)

      RETURN
      END
*DSCALE
      SUBROUTINE DSCALE
     +   (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT)
C***BEGIN PROLOGUE  DSCALE
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL
C***END PROLOGUE  DSCALE

C...SCALAR ARGUMENTS
      INTEGER
     +   LDT,LDSCL,LDSCLT,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,TEMP,ZERO
      INTEGER
     +   I,J

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ONE,ZERO
     +   /1.0D0,0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDSCL:   THE LEADING DIMENSION OF ARRAY SCL.
C   LDSCLT:  THE LEADING DIMENSION OF ARRAY SCLT.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   M:       THE NUMBER OF COLUMNS OF DATA IN T.
C   N:       THE NUMBER OF ROWS OF DATA IN T.
C   ONE:     THE VALUE 1.0D0.
C   SCL:     THE SCALE VALUES.
C   SCLT:    THE INVERSELY SCALED MATRIX.
C   T:       THE ARRAY TO BE INVERSELY SCALED BY SCL.
C   TEMP:    A TEMPORARY SCALAR.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCALE


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (SCL(1,1).GE.ZERO) THEN
         IF (LDSCL.GE.N) THEN
            DO 80 J=1,M
               DO 70 I=1,N
                  SCLT(I,J) = T(I,J)/SCL(I,J)
   70          CONTINUE
   80       CONTINUE
         ELSE
            DO 100 J=1,M
               TEMP = ONE/SCL(1,J)
               DO 90 I=1,N
                  SCLT(I,J) = T(I,J)*TEMP
   90          CONTINUE
  100       CONTINUE
         END IF
      ELSE
         TEMP = ONE/ABS(SCL(1,1))
         DO 120 J=1,M
            DO 110 I=1,N
               SCLT(I,J) = T(I,J)*TEMP
  110       CONTINUE
  120    CONTINUE
      END IF

      RETURN
      END
*DSCLB
      SUBROUTINE DSCLB
     +   (NP,BETA,SSF)
C***BEGIN PROLOGUE  DSCLB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT SCALING VALUES FOR BETA ACCORDING TO THE
C            ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE
C***END PROLOGUE  DSCLB

C...SCALAR ARGUMENTS
      INTEGER
     +   NP

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),SSF(NP)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   BMAX,BMIN,ONE,TEN,ZERO
      INTEGER
     +   K
      LOGICAL
     +   BIGDIF

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,LOG10,MAX,MIN,SQRT

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TEN
     +   /0.0D0,1.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BETA:    THE FUNCTION PARAMETERS.
C   BIGDIF:  THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 
C            DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF
C            BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
C   BMAX:    THE LARGEST NONZERO MAGNITUDE.
C   BMIN:    THE SMALLEST NONZERO MAGNITUDE.
C   K:       AN INDEXING VARIABLE.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   ONE:     THE VALUE 1.0D0.
C   SSF:     THE SCALING VALUES FOR BETA.
C   TEN:     THE VALUE 10.0D0.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCLB


      BMAX = ABS(BETA(1))
      DO 10 K=2,NP
         BMAX = MAX(BMAX,ABS(BETA(K)))
   10 CONTINUE

      IF (BMAX.EQ.ZERO) THEN

C  ALL INPUT VALUES OF BETA ARE ZERO

         DO 20 K=1,NP
            SSF(K) = ONE
   20    CONTINUE

      ELSE

C  SOME OF THE INPUT VALUES ARE NONZERO

         BMIN = BMAX
         DO 30 K=1,NP
            IF (BETA(K).NE.ZERO) THEN
               BMIN = MIN(BMIN,ABS(BETA(K)))
            END IF
   30    CONTINUE
         BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE
         DO 40 K=1,NP
            IF (BETA(K).EQ.ZERO) THEN
               SSF(K) =  TEN/BMIN
            ELSE
               IF (BIGDIF) THEN
                  SSF(K) = ONE/ABS(BETA(K))
               ELSE
                  SSF(K) = ONE/BMAX
               END IF
            END IF
   40    CONTINUE

      END IF

      RETURN
      END
*DSCLD
      SUBROUTINE DSCLD
     +   (N,M,X,LDX,TT,LDTT)
C***BEGIN PROLOGUE  DSCLD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT SCALING VALUES FOR DELTA ACCORDING TO THE 
C            ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE
C***END PROLOGUE  DSCLD

C...SCALAR ARGUMENTS
      INTEGER
     +   LDTT,LDX,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   TT(LDTT,M),X(LDX,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ONE,TEN,XMAX,XMIN,ZERO
      INTEGER
     +   I,J
      LOGICAL
     +   BIGDIF

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS,LOG10,MAX,MIN

C...DATA STATEMENTS
      DATA
     +   ZERO,ONE,TEN
     +   /0.0D0,1.0D0,10.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   BIGDIF:  THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 
C            DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF
C            X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDTT:    THE LEADING DIMENSION OF ARRAY TT.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   ONE:     THE VALUE 1.0D0.
C   TT:      THE SCALING VALUES FOR DELTA.
C   X:       THE INDEPENDENT VARIABLE.
C   XMAX:    THE LARGEST NONZERO MAGNITUDE.
C   XMIN:    THE SMALLEST NONZERO MAGNITUDE.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSCLD


      DO 50 J=1,M
         XMAX = ABS(X(1,J))
         DO 10 I=2,N
            XMAX = MAX(XMAX,ABS(X(I,J)))
   10    CONTINUE

         IF (XMAX.EQ.ZERO) THEN

C  ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO

            DO 20 I=1,N
               TT(I,J) = ONE
   20       CONTINUE

         ELSE

C  SOME OF THE INPUT VALUES ARE NONZERO

            XMIN = XMAX
            DO 30 I=1,N
               IF (X(I,J).NE.ZERO) THEN
                  XMIN = MIN(XMIN,ABS(X(I,J)))
               END IF
   30       CONTINUE
            BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE
            DO 40 I=1,N
               IF (X(I,J).NE.ZERO) THEN
                  IF (BIGDIF) THEN
                     TT(I,J) = ONE/ABS(X(I,J))
                  ELSE
                     TT(I,J) = ONE/XMAX
                  END IF
               ELSE
                  TT(I,J) = TEN/XMIN
               END IF
   40       CONTINUE
         END IF
   50 CONTINUE

      RETURN
      END
*DSETN
      SUBROUTINE DSETN
     +   (N,M,X,LDX,NROW)
C***BEGIN PROLOGUE  DSETN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED
C***END PROLOGUE  DSETN

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,M,N,NROW

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEX VARIABLE.
C   J:       AN INDEX VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NROW:    THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE.
C   X:       THE INDEPENDENT VARIABLE.


C***FIRST EXECUTABLE STATEMENT  DSETN


      IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN

C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C     IF THERE IS ONE, OTHERWISE FIRST ROW IS USED.

      DO 20 I = 1, N
         DO 10 J = 1, M
            IF (X(I,J).EQ.0.0) GO TO 20
   10    CONTINUE
         NROW = I
         RETURN
   20 CONTINUE

      NROW = 1

      RETURN
      END
*DSOLVE
      SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB)
C***BEGIN PROLOGUE  DSOLVE
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  DAXPY,DDOT
C***DATE WRITTEN   920220   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  SOLVE SYSTEMS OF THE FORM
C                   T * X = B  OR  TRANS(T) * X = B
C            WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N,
C            AND THE SOLUTION X OVERWRITES THE RHS B.
C            (ADAPTED FROM LINPACK SUBROUTINE DTRSL)
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE  DSOLVE

C...SCALAR ARGUMENTS
      INTEGER
     +   JOB,LDB,LDT,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   B(LDB,N),T(LDT,N)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   J1,J,JN

C...EXTERNAL FUNCTIONS
      DOUBLE PRECISION
     +   DDOT
      EXTERNAL
     +   DDOT

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DAXPY

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   B:       ON INPUT:  THE RIGHT HAND SIDE;  ON EXIT:  THE SOLUTION
C   J1:      THE FIRST NONZERO ENTRY IN T.
C   J:       AN INDEXING VARIABLE.
C   JN:      THE LAST NONZERO ENTRY IN T.
C   JOB:     WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS
C            1   SOLVE T*X=B, T LOWER TRIANGULAR,
C            2   SOLVE T*X=B, T UPPER TRIANGULAR,
C            3   SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR,
C            4   SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR.
C   LDB:     THE LEADING DIMENSION OF ARRAY B.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   N:       THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T.
C   T:       THE UPPER OR LOWER TRIDIAGONAL SYSTEM.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DSOLVE


C  FIND FIRST NONZERO DIAGONAL ENTRY IN T
         J1 = 0
         DO 10 J=1,N
            IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN
               J1 = J
            ELSE IF (T(J,J).EQ.ZERO) THEN
               B(1,J) = ZERO
            END IF
   10    CONTINUE
         IF (J1.EQ.0) RETURN

C  FIND LAST NONZERO DIAGONAL ENTRY IN T
         JN = 0
         DO 20 J=N,J1,-1
            IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN
               JN = J
            ELSE IF (T(J,J).EQ.ZERO) THEN
               B(1,J) = ZERO
            END IF
   20    CONTINUE

         IF (JOB.EQ.1) THEN

C  SOLVE T*X=B FOR T LOWER TRIANGULAR
            B(1,J1) = B(1,J1)/T(J1,J1)
            DO 30 J = J1+1, JN
               TEMP = -B(1,J-1)
               CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   30       CONTINUE

         ELSE IF (JOB.EQ.2) THEN

C  SOLVE T*X=B FOR T UPPER TRIANGULAR.
            B(1,JN) = B(1,JN)/T(JN,JN)
            DO 40 J = JN-1,J1,-1
               TEMP = -B(1,J+1)
               CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   40       CONTINUE

         ELSE IF (JOB.EQ.3) THEN

C  SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
            B(1,JN) = B(1,JN)/T(JN,JN)
            DO 50 J = JN-1,J1,-1
               B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   50       CONTINUE

         ELSE IF (JOB.EQ.4) THEN

C  SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
            B(1,J1) = B(1,J1)/T(J1,J1)
            DO 60 J = J1+1,JN
               B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB)
               IF (T(J,J).NE.ZERO) THEN
                  B(1,J) = B(1,J)/T(J,J)
               ELSE
                  B(1,J) = ZERO
               END IF
   60       CONTINUE
         END IF

      RETURN
      END
*DUNPAC
      SUBROUTINE DUNPAC
     +   (N2,V1,V2,IFIX)
C***BEGIN PROLOGUE  DUNPAC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DCOPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE
C            UNFIXED
C***END PROLOGUE  DUNPAC

C...SCALAR ARGUMENTS
      INTEGER
     +   N2

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   V1(N2),V2(N2)
      INTEGER
     +   IFIX(N2)

C...LOCAL SCALARS
      INTEGER
     +   I,N1

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DCOPY

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   IFIX:    THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 
C            FIXED AT THEIR INPUT VALUES OR NOT.
C            ODRPACK REFERENCE GUIDE.)
C   N1:      THE NUMBER OF ITEMS IN V1.
C   N2:      THE NUMBER OF ITEMS IN V2.
C   V1:      THE VECTOR OF THE UNFIXED ITEMS.
C   V2:      THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE
C            ELEMENTS OF V1 ARE TO BE INSERTED.


C***FIRST EXECUTABLE STATEMENT  DUNPAC


      N1 = 0
      IF (IFIX(1).GE.0) THEN
         DO 10 I = 1,N2
            IF (IFIX(I).NE.0) THEN
               N1 = N1 + 1
               V2(I) = V1(N1)
            END IF
   10    CONTINUE
      ELSE
         N1 = N2
         CALL DCOPY(N2,V1,1,V2,1)
      END IF

      RETURN
      END
*DVEVTR
      SUBROUTINE DVEVTR
     +   (M,NQ,INDX, 
     +    V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV,
     +    WRK5)
C***BEGIN PROLOGUE  DVEVTR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DSOLVE
C***DATE WRITTEN   910613   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE  V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V
C***END PROLOGUE  DVEVTR

C...SCALAR ARGUMENTS
      INTEGER
     +   INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   J,L1,L2

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DSOLVE

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   INDX:    THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED.
C   J:       AN INDEXING VARIABLE.
C   LDE:     THE LEADING DIMENSION OF ARRAY E.
C   LDV:     THE LEADING DIMENSION OF ARRAY V.
C   LDVE:    THE LEADING DIMENSION OF ARRAY VE.
C   LDVEV:   THE LEADING DIMENSION OF ARRAY VEV.
C   LD2V:    THE SECOND DIMENSION OF ARRAY V.
C   L1:      AN INDEXING VARIABLE.
C   L2:      AN INDEXING VARIABLE.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   E:       THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2).
C   V:       AN ARRAY OF NQ BY M MATRICES.
C   VE:      THE NQ BY M ARRAY VE = V * INV(E)
C   VEV:     THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V).
C   WRK5:    AN M WORK VECTOR.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DVEVTR


      IF (NQ.EQ.0 .OR. M.EQ.0) RETURN

      DO 140 L1 = 1,NQ
         DO 110 J = 1,M
            WRK5(J) = V(INDX,J,L1)
  110    CONTINUE
         CALL DSOLVE(M,E,LDE,WRK5,1,4)
         DO 120 J = 1,M
            VE(INDX,L1,J) = WRK5(J)
  120    CONTINUE
  140 CONTINUE

      DO 230 L1 = 1,NQ
         DO 220 L2 = 1,L1
            VEV(L1,L2) = ZERO
            DO 210 J = 1,M
               VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J)
  210       CONTINUE
            VEV(L2,L1) = VEV(L1,L2)
  220    CONTINUE
  230 CONTINUE

      RETURN
      END
*DWGHT
      SUBROUTINE DWGHT
     +   (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT)
C***BEGIN PROLOGUE  DWGHT
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T
C***END PROLOGUE  DWGHT

C...SCALAR ARGUMENTS
      INTEGER
     +   LDT,LDWT,LDWTT,LD2WT,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   TEMP,ZERO
      INTEGER
     +   I,J,K

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   ABS

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   K:       AN INDEXING VARIABLE.
C   LDT:     THE LEADING DIMENSION OF ARRAY T.
C   LDWT:    THE LEADING DIMENSION OF ARRAY WT.
C   LDWTT:   THE LEADING DIMENSION OF ARRAY WTT.
C   LD2WT:   THE SECOND DIMENSION OF ARRAY WT.
C   M:       THE NUMBER OF COLUMNS OF DATA IN T.
C   N:       THE NUMBER OF ROWS OF DATA IN T.
C   T:       THE ARRAY BEING SCALED BY WT.
C   TEMP:    A TEMPORARY SCALAR.
C   WT:      THE WEIGHTS.
C   WTT:     THE RESULTS OF WEIGHTING ARRAY T BY WT.
C            ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT 
C            ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DWGHT


      IF (N.EQ.0 .OR. M.EQ.0) RETURN

      IF (WT(1,1,1).GE.ZERO) THEN
         IF (LDWT.GE.N) THEN
            IF (LD2WT.GE.M) THEN
C  WT IS AN N-ARRAY OF M BY M MATRICES
               DO 130 I=1,N
                  DO 120 J=1,M
                     TEMP = ZERO
                     DO 110 K=1,M
                        TEMP = TEMP + WT(I,J,K)*T(I,K)
  110                CONTINUE
                     WTT(I,J) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
C  WT IS AN N-ARRAY OF DIAGONAL MATRICES
               DO 230 I=1,N
                  DO 220 J=1,M
                     WTT(I,J) = WT(I,1,J)*T(I,J)
  220             CONTINUE
  230          CONTINUE
            END IF
         ELSE
            IF (LD2WT.GE.M) THEN
C  WT IS AN M BY M MATRIX
               DO 330 I=1,N
                  DO 320 J=1,M
                     TEMP = ZERO
                     DO 310 K=1,M
                        TEMP = TEMP + WT(1,J,K)*T(I,K)
  310                CONTINUE
                     WTT(I,J) = TEMP
  320             CONTINUE
  330          CONTINUE
            ELSE
C  WT IS A DIAGONAL MATRICE
               DO 430 I=1,N
                  DO 420 J=1,M
                     WTT(I,J) = WT(1,1,J)*T(I,J)
  420             CONTINUE
  430          CONTINUE
            END IF
         END IF
      ELSE
C  WT IS A SCALAR
         DO 520 J=1,M
            DO 510 I=1,N
               WTT(I,J) = ABS(WT(1,1,1))*T(I,J)
  510       CONTINUE
  520    CONTINUE
      END IF

      RETURN
      END
*DWINF
      SUBROUTINE DWINF
     +   (N,M,NP,NQ,LDWE,LD2WE,ISODR,
     +   DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
     +   RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
     +   OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI,
     +   PARTLI,SSTOLI,TAUFCI,EPSMAI,
     +   BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI,
     +   FSI,FJACBI,WE1I,DIFFI,
     +   DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
     +   WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   LWKMN)
C***BEGIN PROLOGUE  DWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920619   (YYMMDD)
C***PURPOSE  SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C***END PROLOGUE  DWINF

C...SCALAR ARGUMENTS
      INTEGER
     +   ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI,
     +   DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN,
     +   M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,
     +   RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,
     +   WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
     +   WSSI,WSSDEI,WSSEPI,XPLUSI
      LOGICAL 
     +   ISODR

C...LOCAL SCALARS
      INTEGER
     +   NEXT

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   ACTRSI:  THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS.
C   ALPHAI:  THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA.
C   BETACI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC.
C   BETANI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN.
C   BETASI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS.
C   BETA0I:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0.
C   DELTAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA.
C   DELTNI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN.
C   DELTSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS.
C   DIFFI:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF.
C   EPSI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS.
C   EPSMAI:  THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC.
C   ETAI:    THE LOCATION IN ARRAY WORK OF VARIABLE ETA.
C   FJACBI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB.
C   FJACDI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD.
C   FNI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN.
C   FSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS.
C   ISODR:   THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 
C            (ISODR=TRUE) OR BY OLS (ISODR=FALSE).
C   LDWE:    THE LEADING DIMENSION OF ARRAY WE.
C   LD2WE:   THE SECOND DIMENSION OF ARRAY WE.
C   LWKMN:   THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK.
C   M:       THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE.
C   N:       THE NUMBER OF OBSERVATIONS.
C   NEXT:    THE NEXT AVAILABLE LOCATION WITH WORK.
C   NP:      THE NUMBER OF FUNCTION PARAMETERS.
C   NQ:      THE NUMBER OF RESPONSES PER OBSERVATION.
C   OLMAVI:  THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG.
C   OMEGAI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA.
C   PARTLI:  THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL.
C   PNORMI:  THE LOCATION IN ARRAY WORK OF VARIABLE PNORM.
C   PRERSI:  THE LOCATION IN ARRAY WORK OF VARIABLE PRERS.
C   QRAUXI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX.
C   RCONDI:  THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI.
C   RNORSI:  THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS.
C   RVARI:   THE LOCATION IN ARRAY WORK OF VARIABLE RVAR.
C   SDI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD.
C   SI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY S.
C   SSFI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF.
C   SSI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS.
C   SSTOLI:  THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL.
C   TAUFCI:  THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC.
C   TAUI:    THE LOCATION IN ARRAY WORK OF VARIABLE TAU.
C   TI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY T.
C   TTI:     THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT.
C   UI:      THE STARTING LOCATION IN ARRAY WORK OF ARRAY U.
C   VCVI:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV.
C   WE1I:    THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1.
C   WRK1I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1.
C   WRK2I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2.
C   WRK3I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3.
C   WRK4I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4.
C   WRK5I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5.
C   WRK6I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6.
C   WRK7I:   THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7.
C   WSSI:    THE LOCATION IN ARRAY WORK OF VARIABLE WSS.
C   WSSDEI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL.
C   WSSEPI:  THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS.
C   XPLUSI:  THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD.


C***FIRST EXECUTABLE STATEMENT  DWINF


      IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. 
     +    LDWE.GE.1 .AND. LD2WE.GE.1) THEN

         DELTAI =          1
         EPSI   = DELTAI + N*M
         XPLUSI = EPSI   + N*NQ
         FNI    = XPLUSI + N*M
         SDI    = FNI    + N*NQ
         VCVI   = SDI    + NP
         RVARI  = VCVI   + NP*NP

         WSSI   = RVARI  + 1
         WSSDEI = WSSI   + 1
         WSSEPI = WSSDEI + 1
         RCONDI = WSSEPI + 1
         ETAI   = RCONDI + 1
         OLMAVI = ETAI   + 1

         TAUI   = OLMAVI + 1
         ALPHAI = TAUI   + 1
         ACTRSI = ALPHAI + 1
         PNORMI = ACTRSI + 1
         RNORSI = PNORMI + 1
         PRERSI = RNORSI + 1
         PARTLI = PRERSI + 1
         SSTOLI = PARTLI + 1
         TAUFCI = SSTOLI + 1
         EPSMAI = TAUFCI + 1
         BETA0I = EPSMAI + 1

         BETACI = BETA0I + NP
         BETASI = BETACI + NP
         BETANI = BETASI + NP
         SI     = BETANI + NP
         SSI    = SI     + NP
         SSFI   = SSI    + NP
         QRAUXI = SSFI   + NP
         UI     = QRAUXI + NP
         FSI    = UI     + NP

         FJACBI = FSI    + N*NQ

         WE1I   = FJACBI + N*NP*NQ

         DIFFI  = WE1I + LDWE*LD2WE*NQ

         NEXT   = DIFFI + NQ*(NP+M)

         IF (ISODR) THEN
            DELTSI = NEXT
            DELTNI = DELTSI + N*M
            TI     = DELTNI + N*M
            TTI    = TI     + N*M
            OMEGAI = TTI    + N*M
            FJACDI = OMEGAI + NQ*NQ
            WRK1I  = FJACDI + N*M*NQ
            NEXT   = WRK1I  + N*M*NQ
         ELSE
            DELTSI = DELTAI
            DELTNI = DELTAI
            TI     = DELTAI
            TTI    = DELTAI
            OMEGAI = DELTAI
            FJACDI = DELTAI
            WRK1I  = DELTAI
         END IF

         WRK2I  = NEXT
         WRK3I  = WRK2I + N*NQ
         WRK4I  = WRK3I + NP
         WRK5I  = WRK4I + M*M
         WRK6I  = WRK5I + M
         WRK7I  = WRK6I + N*NQ*NP
         NEXT   = WRK7I + 5*NQ

         LWKMN  = NEXT
      ELSE
         DELTAI = 1
         EPSI   = 1
         XPLUSI = 1
         FNI    = 1
         SDI    = 1
         VCVI   = 1
         RVARI  = 1
         WSSI   = 1
         WSSDEI = 1
         WSSEPI = 1
         RCONDI = 1
         ETAI   = 1
         OLMAVI = 1
         TAUI   = 1
         ALPHAI = 1
         ACTRSI = 1
         PNORMI = 1
         RNORSI = 1
         PRERSI = 1
         PARTLI = 1
         SSTOLI = 1
         TAUFCI = 1
         EPSMAI = 1
         BETA0I = 1
         BETACI = 1
         BETASI = 1
         BETANI = 1
         SI     = 1
         SSI    = 1
         SSFI   = 1
         QRAUXI = 1
         FSI    = 1
         UI     = 1
         FJACBI = 1
         WE1I   = 1
         DIFFI  = 1
         DELTSI = 1
         DELTNI = 1
         TI     = 1
         TTI    = 1
         FJACDI = 1
         OMEGAI = 1
         WRK1I  = 1
         WRK2I  = 1
         WRK3I  = 1
         WRK4I  = 1
         WRK5I  = 1
         WRK6I  = 1
         WRK7I  = 1
         LWKMN  = 1
      END IF

      RETURN
      END
*DXMY
      SUBROUTINE DXMY
     +   (N,M,X,LDX,Y,LDY,XMY,LDXMY)
C***BEGIN PROLOGUE  DXMY
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE XMY = X - Y
C***END PROLOGUE  DXMY

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,LDXMY,LDY,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M),XMY(LDXMY,M),Y(LDY,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDXMY:   THE LEADING DIMENSION OF ARRAY XMY.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   M:       THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y.
C   N:       THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y.
C   X:       THE FIRST OF THE TWO ARRAYS.
C   XMY:     THE VALUES OF X-Y.
C   Y:       THE SECOND OF THE TWO ARRAYS.


C***FIRST EXECUTABLE STATEMENT  DXMY


      DO 20 J=1,M
         DO 10 I=1,N
            XMY(I,J) = X(I,J) - Y(I,J)
   10    CONTINUE
   20 CONTINUE

      RETURN
      END
*DXPY
      SUBROUTINE DXPY
     +   (N,M,X,LDX,Y,LDY,XPY,LDXPY)
C***BEGIN PROLOGUE  DXPY
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  COMPUTE XPY = X + Y
C***END PROLOGUE  DXPY

C...SCALAR ARGUMENTS
      INTEGER
     +   LDX,LDXPY,LDY,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   X(LDX,M),XPY(LDXPY,M),Y(LDY,M)

C...LOCAL SCALARS
      INTEGER
     +   I,J

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDX:     THE LEADING DIMENSION OF ARRAY X.
C   LDXPY:   THE LEADING DIMENSION OF ARRAY XPY.
C   LDY:     THE LEADING DIMENSION OF ARRAY Y.
C   M:       THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y.
C   N:       THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y.
C   X:       THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER.
C   XPY:     THE VALUES OF X+Y.
C   Y:       THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER.


C***FIRST EXECUTABLE STATEMENT  DXPY


      DO 20 J=1,M
         DO 10 I=1,N
            XPY(I,J) = X(I,J) + Y(I,J)
   10    CONTINUE
   20 CONTINUE

      RETURN
      END
*DZERO
      SUBROUTINE DZERO
     +   (N,M,A,LDA)
C***BEGIN PROLOGUE  DZERO
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  920304   (YYMMDD)
C***PURPOSE  SET A = ZERO
C***END PROLOGUE  DZERO

C...SCALAR ARGUMENTS
      INTEGER
     +   LDA,M,N

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   A(LDA,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   ZERO
      INTEGER
     +   I,J

C...DATA STATEMENTS
      DATA
     +   ZERO
     +   /0.0D0/

C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C   A:       THE ARRAY TO BE SET TO ZERO.
C   I:       AN INDEXING VARIABLE.
C   J:       AN INDEXING VARIABLE.
C   LDA:     THE LEADING DIMENSION OF ARRAY A.
C   M:       THE NUMBER OF COLUMNS TO BE SET TO ZERO.
C   N:       THE NUMBER OF ROWS TO BE SET TO ZERO.
C   ZERO:    THE VALUE 0.0D0.


C***FIRST EXECUTABLE STATEMENT  DZERO


      DO 20 J=1,M
         DO 10 I=1,N
            A(I,J) = ZERO
   10    CONTINUE
   20 CONTINUE

      RETURN
      END