*DODRC
      SUBROUTINE DODRC
     +   (FUN,JAC,
     +   N,M,NP,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +   Y,
     +   BETA,IFIXB,SCLB,
     +   RHO,LDRHO,W,
     +   JOB,TAUFAC,
     +   SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODRC
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  USER-CALLABLE DOUBLE PRECISION CONTROL ROUTINE FOR FINDING
C            THE WEIGHTED ORTHOGONAL DISTANCE REGRESSION (ODR) OR
C            ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) SOLUTION
C            (LONG CALL STATEMENT)
C***DESCRIPTION
C
C   REFERENCE FOR ONLINE DOCUMENTATION IS GIVEN BELOW.
C
C   THE ONLINE DOCUMENTATION CAN BE INSERTED HERE IF REQUIRED BY YOUR
C   DOCUMENTATION RETRIEVAL SYSTEM.  ONLINE DOCUMENTATION DOES NOT
C   EXTEND BEYOND COLUMN 72, AND COLUMN 1 OF ONLINE DOCUMENTATION CAN BE
C   CHANGED TO 'C' WITHOUT LOSS OF INFORMATION.
C
C***REFERENCES  BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND
C                 R. B. SCHNABEL (1987),
C                 "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED
C                 ORTHOGONAL DISTANCE REGRESSION,"
C                 ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS
C***ROUTINES CALLED  DODDRV
C***END PROLOGUE  DODRC
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IPRINT
C        THE PRINT CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERR
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL SHORT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS
C        INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-
C        CALL (SHORT=.FALSE.).
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
C
C
C***FIRST EXECUTABLE STATEMENT  DODRC
C
C
      SHORT = .FALSE.
C
      CALL DODDRV
     +     (SHORT,
     +     FUN,JAC,
     +     N,M,NP,
     +     X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +     Y,
     +     BETA,IFIXB,SCLB,
     +     RHO,LDRHO,W,
     +     JOB,TAUFAC,
     +     SSTOL,PARTOL,MAXIT,
     +     IPRINT,LUNERR,LUNRPT,
     +     WORK,LWORK,IWORK,LIWORK,
     +     INFO)
C
      RETURN
C
      END
*DODDRV
      SUBROUTINE DODDRV
     +   (SHORT,
     +   FUN,JAC,
     +   N,M,NP,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +   Y,
     +   BETA,IFIXB,SCLB,
     +   RHO,LDRHO,W,
     +   JOB,TAUFAC,
     +   SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)
C***BEGIN PROLOGUE  DODDRV
C***REFER TO DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DINIWK,DIWINF,DJCK,DODCHK,
C                    DODMN,DODPER,DPACK,DMPREC,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN
C            PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION
C            (ODR) ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS)
C***END PROLOGUE  DODDRV
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DMPREC
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IPRINT
C        THE PRINT CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LIWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNERR
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS, TO BE
C        COMPUTED BY DJCK.
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      INTEGER NROW
C        THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED,
C        TO BE SET BY DJCK.
      INTEGER NTOL
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES,
C        TO BE SET BY DJCK.
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL SHORT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS
C        INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-
C        CALL (SHORT=.FALSE.).
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER YTI
C        THE STARTING LOCATION IN WORK OF
C        THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODDRV
C
C
C  INITIALIZE NECESSARY VARIABLES
C
      EPSMAC = DMPREC()
C
      CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR)
C
      INFO = 0
C
C  COMPUTE MINIMUM WORK VECTOR LENGTHS
C
      LWKMN = 9 + 8*N + 10*N*M + 2*N*NP + 8*NP
C
      LIWKMN = 2*NP + M + 10
C
C  PERFORM ERROR CHECKING
C
      CALL DODCHK(N,NP,M,
     +            IFIXB,
     +            LDX,LDIFX,LDSCLD,LDRHO,
     +            LWORK,LWKMN,LIWORK,LIWKMN,
     +            SCLD,SCLB,W,RHO,
     +            EPSMAC,INFO)
      IF (INFO.NE.0) THEN
         GO TO 10
      END IF
C
C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
      LDFJB = N
      LDFJX = N
      IF (RESTRT) THEN
C
C  RESET MAXIMUM NUMBER OF ITERATIONS
C
         IF (SCLD(1,1).LE.ZERO) THEN
            LDTT = N
         ELSE
            IF (LDSCLD.EQ.1) THEN
               LDTT = LDSCLD
            ELSE
               LDTT = N
            END IF
         END IF
         IWORK(MAXITI) = IWORK(MAXITI) + 10
C
      ELSE
C
C  INITIALIZE WORK VECTORS AS NECESSARY
C
         CALL DINIWK
     +      (N,M,NP,
     +      X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,LDTT,
     +      BETA,IFIXB,SCLB,
     +      EPSMAC,SSTOL,PARTOL,MAXIT,TAUFAC,
     +      JOB,IPRINT,LUNERR,LUNRPT,
     +      WORK,LWORK,IWORK,LIWORK)
C
C  CHECK DERIVATIVES IF REQUESTED
C
         IF (CHKJAC .AND. ANAJAC) THEN
C
C  CHECK USER-SUPPLIED DERIVATIVES
C
            NETA = -1
            NTOL = -1
            NROW = -1
            CALL DJCK(FUN,JAC,N,NP,M,X,LDX,BETA,WORK(DELTAI),
     +                N,WORK(XPLUSI),N,
     +                NETA,NTOL,WORK(SSFI),WORK(TTI),LDTT,NROW,ISODR,
     +                EPSMAC,
     +                WORK(FI),WORK(FJACBI),LDFJB,WORK(FJACXI),LDFJX,
     +                WORK(BETACI),IWORK(MSGB),IWORK(MSGX),IFLAG)
            IF (IFLAG.LT.0) THEN
               INFO = IFLAG
            ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGX).NE.0) THEN
               INFO = 40000
            END IF
         ELSE
C
C  INDICATE USER-SUPPLIED DERIVATIVES WERE NOT CHECKED
C
            IWORK(MSGB) = -1
            IWORK(MSGX) = -1
         END IF
C
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
C
         IF (IWORK(MSGB).NE.1 .AND. IWORK(MSGX).NE.1) THEN
            CALL DPACK(NP,NPP,WORK(BETACI),BETA,IFIXB)
            IF (WORK(SSFI).GT.ZERO) THEN
               CALL DPACK(NP,NPP,WORK(SSI),WORK(SSFI),IFIXB)
            ELSE
               WORK(SSI) = WORK(SSFI)
            END IF
         END IF
      END IF
C
C  PRINT APPROPRIATE ERROR MESSAGES
C
   10 IF (INFO.NE.0) THEN
         IF (LUNERR.NE.0) THEN
            CALL DODPER
     +         (INFO,LUNERR,SHORT,
     +         N,NP,M,
     +         LDSCLD,LDRHO,
     +         LWKMN,LIWKMN,
     +         SCLD,SCLB,W,RHO,
     +         IWORK(MSGB),ISODR,IWORK(MSGX),
     +         WORK(XPLUSI),N,NROW,NETA,NTOL)
         END IF
C
C  SET INFO FOR ERRORS IN THE USER-SUPPLIED JACOBIANS
C
         IF (INFO.EQ.40000) THEN
            IF (IWORK(MSGB).EQ.1 .OR. IWORK(MSGX).EQ.1) THEN
               IF (IWORK(MSGB).EQ.1) THEN
                  INFO = INFO + 1000
               END IF
               IF (IWORK(MSGX).EQ.1) THEN
                  INFO = INFO + 100
               END IF
            ELSE
               INFO = 0
            END IF
         END IF
         IF (INFO.NE.0) THEN
            RETURN
         END IF
      END IF
C
C  FIND LEAST SQUARES SOLUTION
C
      CALL DODMN(FUN,JAC,
     +            N,NP,NPP,M,JOB,
     +            X,LDX,IFIXX,LDIFX,Y,
     +            WORK(BETACI),IFIXB,BETA,WORK(BETANI),WORK(BETASI),
     +            WORK(SI),WORK(DELTAI),WORK(DELTNI),WORK(DELTSI),
     +            WORK(TI),WORK(FI),WORK(FNI),WORK(FSI),
     +            WORK(FJACBI),LDFJB,IWORK(MSGB),
     +            WORK(FJACXI),LDFJX,IWORK(MSGX),WORK(STPI),
     +            W,RHO,LDRHO,
     +            WORK(SSFI),WORK(SSI),WORK(TTI),LDTT,
     +            WORK(XPLUSI),WORK(DDELTI),WORK(SSSI),
     +            WORK,LWORK,IWORK,LIWORK,INFO)
C
      RETURN
C
      END
*DFLAGS
      SUBROUTINE DFLAGS
     +   (JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR)
C***BEGIN PROLOGUE  DFLAGS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB
C***END PROLOGUE  DFLAGS
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF JOB.
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
C
C
C***FIRST EXECUTABLE STATEMENT  DFLAGS
C
C
      IF (JOB.GE.0) THEN
         RESTRT= MOD(JOB,10000)/1000.NE.0
         INITD = MOD(JOB,1000)/100.EQ.0
         J = MOD(JOB,100)/10
         IF (J.EQ.0) THEN
            ANAJAC = .FALSE.
            CHKJAC = .FALSE.
         ELSE IF (J.EQ.1) THEN
            ANAJAC = .TRUE.
            CHKJAC = .TRUE.
         ELSE
            ANAJAC = .TRUE.
            CHKJAC = .FALSE.
         END IF
         ISODR = MOD(JOB,10).EQ.0
      ELSE
         RESTRT  = .FALSE.
         INITD = .TRUE.
         ANAJAC = .FALSE.
         CHKJAC = .FALSE.
         ISODR = .TRUE.
      END IF
C
      RETURN
      END
*DWINF
      SUBROUTINE DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C***BEGIN PROLOGUE  DWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C***END PROLOGUE  DWINF
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NEXT
C        THE NEXT AVAILABLE LOCATION.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
C
C
C***FIRST EXECUTABLE STATEMENT  DWINF
C
C
      IF (N.GE.1 .AND. NP.GE.1 .AND. M.GE.1) THEN
         DELTAI = 1
         FI = DELTAI + N*M
         RNORMI = FI + N
         PARTLI = RNORMI + 1
         SSTOLI = PARTLI + 1
         TAUFCI = SSTOLI + 1
         EPSMAI = TAUFCI + 1
         OLMAVI = EPSMAI + 1
         FJACBI = OLMAVI + 1
         FJACXI = FJACBI + N*NP
         XPLUSI = FJACXI + N*M
         BETACI = XPLUSI + N*M
         BETASI = BETACI + NP
         BETANI = BETASI + NP
         DELTSI = BETANI + NP
         DELTNI = DELTSI + N*M
         DDELTI = DELTNI + N*M
         FSI = DDELTI + N*M
         FNI = FSI + N
         SI = FNI + N
         SSSI = SI + NP
         SSI = SSSI + N + N*M
         SSFI = SSI + NP
         TI = SSFI + NP
         TTI = TI + N*M
         TAUI = TTI + N*M
         ALPHAI = TAUI + 1
         TFJACI = ALPHAI + 1
         OMEGAI = TFJACI + N*NP
         YTI = OMEGAI + N
         UI = YTI + N
         QRAUXI = UI + N
         WRK1I = QRAUXI + NP
         WRK2I = WRK1I + N*M
         STPI = WRK2I + NP
         RCONDI = STPI + N
         NEXT = RCONDI + 1
      ELSE
         DELTAI = 1
         FI = 1
         RNORMI = 1
         PARTLI = 1
         SSTOLI = 1
         TAUFCI = 1
         EPSMAI = 1
         OLMAVI = 1
         FJACBI = 1
         FJACXI = 1
         XPLUSI = 1
         BETACI = 1
         BETASI = 1
         BETANI = 1
         DELTSI = 1
         DELTNI = 1
         DDELTI = 1
         FSI = 1
         FNI = 1
         SI = 1
         SSSI = 1
         SSI = 1
         SSFI = 1
         TI = 1
         TTI = 1
         TAUI = 1
         ALPHAI = 1
         TFJACI = 1
         OMEGAI = 1
         YTI = 1
         UI = 1
         QRAUXI = 1
         WRK1I = 1
         WRK2I = 1
         STPI = 1
         RCONDI = 1
         NEXT = 1
      END IF
      RETURN
      END
*DMPREC
      DOUBLE PRECISION FUNCTION DMPREC()
C***BEGIN PROLOGUE  DPREC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  DETERMIND MACHINE PRECISION FOR TARGET MACHINE AND COMPILER
C            ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE
C            T-DIGIT, BASE-B FORM
C               SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C            WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T,
C                  0 .LT. X(1), AND EMIN .LE. E .LE. EMAX.
C***END PROLOGUE  DPREC
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION B
C        THE BASE OF THE TARGET MACHINE.
C        (MAY BE DEFINED USING I1MACH(10).)
      INTEGER TD
C        THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
C        (MAY BE DEFINED USING I1MACH(14).)
      INTEGER TS
C        THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
C        (MAY BE DEFINED USING I1MACH(11).)
C
C
C  TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
C  THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY
C  REMOVING THE C FROM COLUMN 1.
C
C
C  MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  60 /
C
C  MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM AND
C                        THE BURROUGHS 6700/7700 SYSTEMS.
C
C     DATA B  /   8 /
C     DATA TS /  13 /
C     DATA TD /  26 /
C
C  MACHINE CONSTANTS FOR THE CDC 6000/7000 AND
C                        THE CYBER 170/180/200 SERIES.
C
C     DATA B  /   2 /
C     DATA TS /  48 /
C     DATA TD /  96 /
C
C  MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA B  /   2 /
C     DATA TS /  47 /
C     DATA TD /  94 /
C
C  MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7
C
C     DATA B  /   2 /
C     DATA TS /  23 /
C     DATA TD /  38 /
C
C  MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  63 /
C
C  MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86.
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE IBM PC USING PROFORT.
C
C     DATA B  /   2 /
C     DATA TS /  23 /
C     DATA TD /  52 /
C
C  MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE INTERDATA 8/32 WITH THE UNIX SYSTEM
C     FORTRAN 77 COMPILER.
C
C     DATA B  /  16 /
C     DATA TS /   6 /
C     DATA TD /  14 /
C
C  MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  54 /
C
C  MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  62 /
C
C  MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING
C     16-BIT INTEGER ARITHMETIC.
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA B  /   2 /
C     DATA TS /  27 /
C     DATA TD /  60 /
C
C  MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS
C     COMPILER AND FOR THE VAX/VMS VERSION 2.2
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE VAX/VMS V4 SYSTEM USING D_FLOATING
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  56 /
C
C  MACHINE CONSTANTS FOR THE VAX/VMS V4 SYSTEM USING G_FLOATING
C
C     DATA B  /   2 /
C     DATA TS /  24 /
C     DATA TD /  53 /
C
C
C***FIRST EXECUTABLE STATEMENT  DPREC
C
C
      B = I1MACH(10)
      TD = I1MACH(14)
      TS = I1MACH(11)
C
      DMPREC = B ** (1-TD)
C
      RETURN
C
      END
*DODCHK
      SUBROUTINE DODCHK
     +   (N,NP,M,
     +   IFIXB,
     +   LDX,LDIFX,LDSCLD,LDRHO,
     +   LWORK,LWKMN,LIWORK,LIWKMN,
     +   SCLD,SCLB,W,RHO,
     +   EPSMAC,INFO)
C***BEGIN PROLOGUE  DODCHK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING
C            NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE
C            PROLOGUES FOR DODR AND DODRC.
C***END PROLOGUE  DODCHK
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER K
C        AN INDEXING VARIABLE.
      INTEGER LAST
C        THE LAST ROW OF THE ARRAY TO BE ACCESSED.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LIWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXGDX
C        THE LARGEST NUMBER OF GOOD DIGITS IT IS REASONABLE TO SPECIFY.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NNZW
C        THE NUMBER OF NON ZERO OBSERVATIONAL ERROR WEIGHTS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO /0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODCHK
C
C
      MAXGDX = -LOG10(EPSMAC)
C
C  FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED
C
      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
C  CHECK PROBLEM SPECIFICATION PARAMETERS
C
      IF (N.LE.0 .OR. M.LE.0 .OR. NPP.LE.0 .OR. NPP.GT.N) 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
         RETURN
      END IF
C
C  CHECK DIMENSION SPECIFICATION PARAMETERS
C
      IF (LDX.LT.N .OR.
     +   (LDIFX.NE.1 .AND. LDIFX.LT.N) .OR.
     +   (LDSCLD.NE.1 .AND. LDSCLD.LT.N) .OR.
     +   (LDRHO.NE.1 .AND. LDRHO.LT.N) .OR.
     +   LWORK.LT.LWKMN .OR. LIWORK.LT.LIWKMN) THEN
         INFO = 20000
         IF (LDX.LT.N) THEN
            INFO = INFO + 1000
         END IF
         IF (LDIFX.NE.1 .AND. LDIFX.LT.N) THEN
            INFO = INFO + 100
         END IF
         IF (LDSCLD.NE.1 .AND. LDSCLD.LT.N) THEN
            INFO = INFO + 200
         END IF
         IF (LDRHO.NE.1 .AND. LDRHO.LT.N) THEN
            INFO = INFO + 400
         END IF
         IF (LWORK.LT.LWKMN) THEN
            INFO = INFO + 10
         END IF
         IF (LIWORK.LT.LIWKMN) THEN
            INFO = INFO + 1
         END IF
         RETURN
      END IF
C
C  CHECK DELTA SCALING
C
      IF (SCLD(1,1).GT.0) THEN
         DO 30 J=1,M
            IF (LDSCLD.GE.N) THEN
               LAST = N
            ELSE
               LAST = 1
            END IF
            DO 20 I=1,LAST
               IF (SCLD(I,J).LE.0) THEN
                  INFO = 31000
                  GO TO 40
               END IF
   20       CONTINUE
   30    CONTINUE
      END IF
C
C  CHECK BETA SCALING
C
   40 IF (SCLB(1).GT.0) THEN
         DO 50 K=1,NP
            IF (SCLB(K).LE.0) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 30100
               ELSE
                  INFO = INFO + 100
               END IF
               GO TO 60
            END IF
   50    CONTINUE
      END IF
C
C  CHECK OBSERVATIONAL ERROR WEIGHTS IF INDIVIDUALLY SPECIFIED
C
   60 IF (W(1).GE.ZERO) THEN
         NNZW = 0
         DO 70 I=2,N
            IF (W(I).LT.ZERO) THEN
               IF (INFO.EQ.0) THEN
                  INFO = 30010
               ELSE
                  INFO = INFO + 10
               END IF
               GO TO 80
            ELSE IF (W(I).GT.ZERO) THEN
               NNZW = NNZW + 1
            END IF
   70    CONTINUE
         IF (NNZW.LT.NPP) THEN
            IF (INFO.EQ.0) THEN
               INFO = 30020
            ELSE
               INFO = INFO + 20
            END IF
         END IF
      END IF
C
C  CHECK DELTA WEIGHTS IF INDIVIDUALLY SPECIFIED
C
   80 IF (RHO(1,1).GE.ZERO) THEN
         DO 100 J=1,M
            IF (LDRHO.GE.N) THEN
               LAST = N
            ELSE
               LAST = 1
            END IF
            DO 90 I=1,LAST
               IF (RHO(I,J).LE.ZERO) THEN
                  IF (INFO.EQ.0) THEN
                     INFO = 30001
                  ELSE
                     INFO = INFO + 1
                  END IF
                  GO TO 110
               END IF
   90       CONTINUE
  100    CONTINUE
      END IF
C
  110 RETURN
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1
C***END PROLOGUE  DPACK
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIX(N2)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF
C        SUBROUTINE DODR OR DODRC.)
      INTEGER N1
C        THE NUMBER OF ITEMS IN V1.
      INTEGER N2
C        THE NUMBER OF ITEMS IN V2.
      DOUBLE PRECISION V1(N2)
C        THE VECTOR OF THE UNFIXED ITEMS FROM V2.
      DOUBLE PRECISION V2(N2)
C        THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE
C        UNFIXED ELEMENTS ARE TO BE EXTRACTED.
C
C
C***FIRST EXECUTABLE STATEMENT  DPACK
C
C
      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
C
      RETURN
      END
*DIWINF
      SUBROUTINE DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C***BEGIN PROLOGUE  DIWINF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE
C***END PROLOGUE  DIWINF
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER NEXT
C        THE LOCATION IN ARRAY IWORK OF
C        THE NEXT AVAILABLE LOCATION.
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
C
C
C***FIRST EXECUTABLE STATEMENT  DIWINF
C
C
      IF (NP.GE.1 .AND. M.GE.1) THEN
         MSGB = 1
         MSGX = MSGB + NP+1
         JPVTI = MSGX + M+1
         MAXITI = JPVTI + NP
         IPRINI = MAXITI + 1
         NFEVI = IPRINI + 1
         NJEVI = NFEVI + 1
         INT2I = NJEVI + 1
         LUNERI = INT2I + 1
         LUNRPI = LUNERI + 1
         IRANKI = LUNRPI + 1
         NEXT = IRANKI + 1
      ELSE
         MSGB = 1
         MSGX = 1
         JPVTI = 1
         MAXITI = 1
         IPRINI = 1
         NFEVI = 1
         NJEVI = 1
         INT2I = 1
         LUNERI = 1
         LUNRPI = 1
         IRANKI = 1
         NEXT = 1
      END IF
C
      RETURN
      END
*DJCK
      SUBROUTINE DJCK
     +   (FUN,JAC,N,NP,M,X,LDX,BETA,DELTA,LDDELT,XPLUSD,LDXPD,
     +   NETA,NTOL,SS,TT,LDTT,NROW,ISODR,EPSMAC,
     +   PVTEMP,FJACB,LDFJB,FJACX,LDFJX,PARTMP,
     +   MSGB,MSGX,IFLAG)
C***BEGIN PROLOGUE  DJCK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DETAF,DJCKM,DSETN,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS
C           (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCNT)
C***END PROLOGUE  DJCK
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION DELTA(LDDELT,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      LOGICAL ISWRTB
C        THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT
C        BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
      INTEGER J
C        AN INDEX VARIABLE.
      INTEGER LDDELT
C        THE LEADING DIMENSION OF ARRAY DELTA.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL, EITHER
C        SET BY THE USER OR COMPUTED BY DETAF.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY
C        AT WHICH THE DERIVATIVE IS CHECKED.
      INTEGER NTOL
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES,
C        EITHER SET BY THE USER OR COMPUTED FROM NETA.
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PARTMP(NP)
C        THE MODIFIED MODEL PARAMETERS
      DOUBLE PRECISION PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
      DOUBLE PRECISION PVTEMP(N)
C        THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TEN
C        THE VALUE 10.0D0.
      DOUBLE PRECISION TOL
C        THE AGREEMENT TOLERANCE.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TYPJ
C        THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE,TEN/0.0D0,1.0D0,10.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJCK
C
C
C  COMPUTE XPLUSD = X + DELTA
C
      CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD)
C
C  SELECT FIRST ROW OF X + DELTA WHICH CONTAINS NO ZEROS
C
      CALL DSETN(N,M,XPLUSD,LDXPD,NROW)
C
C  SET PARAMETERS NECESSARY FOR THE COMPUTATIONS
C
      IF ((NETA.LT.2) .OR. (NETA.GT.INT(-LOG10(EPSMAC)))) THEN
         CALL DETAF(FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,NETA,EPSMAC,
     +              NROW,PARTMP,PVTEMP,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
      ELSE
         ETA = TEN**(-NETA)
      END IF
C
      IF ((NTOL.LT.1) .OR. (NTOL.GT.(NETA+1)/2)) THEN
         NTOL = (NETA+3)/4
      END IF
C
      TOL = TEN**(-NTOL)
C
C  COMPUTE PREDICTED VALUE OF MODEL USING CURRENT PARAMETER
C  ESTIMATES, AND COMPUTE USER-SUPPLIED DERIVATIVE VALUES
C
      IFLAG = 0
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
      PV = PVTEMP(NROW)
      IFLAG = 0
      CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD,FJACB,LDFJB,
     +         ISODR,FJACX,LDFJX,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
C  CHECK DERIVATIVES WRT BETA
C
      ISWRTB = .TRUE.
      MSGB(1) = 0
C
      DO 10 J=1,NP
C
         IF (SS(1).GT.ZERO) THEN
            TYPJ = ONE/SS(J)
         ELSE
            TYPJ = ONE/ABS(SS(1))
         END IF
C
C  CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW
C
         CALL DJCKM(FUN,N,NP,M,XPLUSD,LDXPD,BETA,TYPJ,ETA,TOL,EPSMAC,
     +              J,NROW,PV,FJACB(NROW,J),
     +              PVTEMP,ISWRTB,MSGB,NP+1,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
C
   10 CONTINUE
C
C  CHECK DERIVATIVES WRT X
C
      MSGX(1) = 0
C
      IF (ISODR) THEN
         ISWRTB = .FALSE.
         DO 20 J=1,M
C
            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.EQ.1) THEN
                  TYPJ = ONE/TT(1,J)
               ELSE
                  TYPJ = ONE/TT(NROW,J)
               END IF
            ELSE
               TYPJ = ABS(ONE/TT(1,1))
            END IF
C
C  CHECK DERIVATIVE WRT THE J-TH COLUMN OF X AT ROW NROW
C
            CALL DJCKM(FUN,N,NP,M,XPLUSD,LDXPD,BETA,TYPJ,ETA,TOL,
     +                 EPSMAC,J,NROW,PV,FJACX(NROW,J),
     +                 PVTEMP,ISWRTB,MSGX,M+1,IFLAG)
            IF (IFLAG.LT.0) THEN
               RETURN
            END IF
C
   20    CONTINUE
      END IF
C
C  PRINT RESULTS IF THEY ARE DESIRED
C
      RETURN
C
      END
      SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
C***BEGIN PROLOGUE  DCOPY
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  D.P. vector copy y = x
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DY  copy of vector DX (unchanged if N .LE. 0)
C
C     Copy double precision DX to double precision DY.
C     For I = 0 to N-1, copy DX(LX+I*INCX) to DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DCOPY
C
      DOUBLE PRECISION DX(*),DY(*)
C***FIRST EXECUTABLE STATEMENT  DCOPY
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C        CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7.
C
   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I + 1) = DX(I + 1)
        DY(I + 2) = DX(I + 2)
        DY(I + 3) = DX(I + 3)
        DY(I + 4) = DX(I + 4)
        DY(I + 5) = DX(I + 5)
        DY(I + 6) = DX(I + 6)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS=N*INCX
          DO 70 I=1,NS,INCX
          DY(I) = DX(I)
   70     CONTINUE
      RETURN
      END
      INTEGER FUNCTION I1MACH(I)
C***BEGIN PROLOGUE  I1MACH
C***DATE WRITTEN   750101   (YYMMDD)
C***REVISION DATE  840405   (YYMMDD)
C***CATEGORY NO.  R1
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C***PURPOSE  Returns integer machine dependent constants
C***DESCRIPTION
C
C     This is the CMLIB version of I1MACH, the integer machine
C     constants subroutine originally developed for the PORT library.
C
C     I1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subroutine with one (input) argument, and can be called
C     as follows, for example
C
C          K = I1MACH(I)
C
C     where I=1,...,16.  The (output) value of K above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  I/O unit numbers.
C    I1MACH( 1) = the standard input unit.
C    I1MACH( 2) = the standard output unit.
C    I1MACH( 3) = the standard punch unit.
C    I1MACH( 4) = the standard error message unit.
C
C  Words.
C    I1MACH( 5) = the number of bits per integer storage unit.
C    I1MACH( 6) = the number of characters per integer storage unit.
C
C  Integers.
C    assume integers are represented in the S-digit, base-A form
C
C               sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
C
C               where 0 .LE. X(I) .LT. A for I=0,...,S-1.
C    I1MACH( 7) = A, the base.
C    I1MACH( 8) = S, the number of base-A digits.
C    I1MACH( 9) = A**S - 1, the largest magnitude.
C
C  Floating-Point Numbers.
C    Assume floating-point numbers are represented in the T-digit,
C    base-B form
C               sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C
C               where 0 .LE. X(I) .LT. B for I=1,...,T,
C               0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
C    I1MACH(10) = B, the base.
C
C  Single-Precision
C    I1MACH(11) = T, the number of base-B digits.
C    I1MACH(12) = EMIN, the smallest exponent E.
C    I1MACH(13) = EMAX, the largest exponent E.
C
C  Double-Precision
C    I1MACH(14) = T, the number of base-B digits.
C    I1MACH(15) = EMIN, the smallest exponent E.
C    I1MACH(16) = EMAX, the largest exponent E.
C
C  To alter this function for a particular environment,
C  the desired set of DATA statements should be activated by
C  removing the C from column 1.  Also, the values of
C  I1MACH(1) - I1MACH(4) should be checked for consistency
C  with the local operating system.
C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  I1MACH
C
      INTEGER IMACH(16),OUTPUT
      EQUIVALENCE (IMACH(4),OUTPUT)
C
C     MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T
C     3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T
C     PC 7300), SUN SPARCSTATIONS, SILICON GRAPHCS WORKSTATIONS, HP
C     9000 WORKSTATIONS, IBM RS/6000 WORKSTATIONS, AND 8087 BASED 
C     MICROS (E.G. IBM PC AND AT&T 6300).
C
C === MACHINE = ATT.3B
C === MACHINE = ATT.6300
C === MACHINE = ATT.7300
C === MACHINE = HP.9000
C === MACHINE = IBM.PC
C === MACHINE = IBM.RS6000
C === MACHINE = IEEE.MOST-SIG-BYTE-FIRST
C === MACHINE = IEEE.LEAST-SIG-BYTE-FIRST
C === MACHINE = SGI
C === MACHINE = SUN
C === MACHINE = 68000
C === MACHINE = 8087
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -125 /
C      DATA IMACH(13) /  128 /
C      DATA IMACH(14) /   53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR SUN WORKSTATIONS.  f77 WITH -r8 OPTION.
C
C === MACHINE = SUN.F77-WITH-R8-OPTION
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    6 /
C      DATA IMACH( 4) /    0 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   53 /
C      DATA IMACH(12) / -1021 /
C      DATA IMACH(13) /  1024 /
C      DATA IMACH(14) /   113 /
C      DATA IMACH(15) / -16382 /
C      DATA IMACH(16) /  16384 /
C
C     MACHINE CONSTANTS FOR SGI Origin 2000 with -r8 -d16 options.
C
C === MACHINE = SGI.ORIGIN.F77-WITH-R8-D16-OPTIONS
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    6 /
C      DATA IMACH( 4) /    0 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   53 /
C      DATA IMACH(12) / -1022 /
C      DATA IMACH(13) /  1024 /
C      DATA IMACH(14) /   107 /
C      DATA IMACH(15) /  -916 /
C      DATA IMACH(16) /  1025 /
C
C     MACHINE CONSTANTS FOR IBM RS/6000 WORKSTATIONS WITH -qautodbl=dblpad.
C
C === MACHINE = IBM.RS6000.XLF-WITH-AUTODBL-OPTION
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    6 /
C      DATA IMACH( 4) /    0 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   53 /
C      DATA IMACH(12) / -1021 /
C      DATA IMACH(13) /  1024 /
C      DATA IMACH(14) /   114 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR AMDAHL MACHINES.
C
C === MACHINE = AMDAHL
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  63 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  63 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C === MACHINE = BURROUGHS.1700
C      DATA IMACH( 1) /    7 /
C      DATA IMACH( 2) /    2 /
C      DATA IMACH( 3) /    2 /
C      DATA IMACH( 4) /    2 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   33 /
C      DATA IMACH( 9) / Z1FFFFFFFF /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -256 /
C      DATA IMACH(13) /  255 /
C      DATA IMACH(14) /   60 /
C      DATA IMACH(15) / -256 /
C      DATA IMACH(16) /  255 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM.
C
C === MACHINE = BURROUGHS.5700
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  48 /
C      DATA IMACH( 6) /   6 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  39 /
C      DATA IMACH( 9) / O0007777777777777 /
C      DATA IMACH(10) /   8 /
C      DATA IMACH(11) /  13 /
C      DATA IMACH(12) / -50 /
C      DATA IMACH(13) /  76 /
C      DATA IMACH(14) /  26 /
C      DATA IMACH(15) / -50 /
C      DATA IMACH(16) /  76 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS.
C
C === MACHINE = BURROUGHS.6700
C === MACHINE = BURROUGHS.7700
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  48 /
C      DATA IMACH( 6) /   6 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  39 /
C      DATA IMACH( 9) / O0007777777777777 /
C      DATA IMACH(10) /   8 /
C      DATA IMACH(11) /  13 /
C      DATA IMACH(12) / -50 /
C      DATA IMACH(13) /  76 /
C      DATA IMACH(14) /  26 /
C      DATA IMACH(15) / -32754 /
C      DATA IMACH(16) /  32780 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES
C
C === MACHINE = CONVEX
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    0 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   53 /
C      DATA IMACH(15) / -1023 /
C      DATA IMACH(16) /  1023 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES (NATIVE MODE)
C     WITH -P8 OPTION
C
C === MACHINE = CONVEX.P8
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     0 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    63 /
C      DATA IMACH( 9) / 9223372036854775807 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    53 /
C      DATA IMACH(12) / -1023 /
C      DATA IMACH(13) /  1023 /
C      DATA IMACH(14) /   112 /
C      DATA IMACH(15) / -16383 /
C      DATA IMACH(16) /  16383 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES (IEEE MODE)
C
C === MACHINE = CONVEX.IEEE
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    0 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -125 /
C      DATA IMACH(13) /  128 /
C      DATA IMACH(14) /   53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE CONVEX C1, C2, C3 SERIES(IEEE MODE)
C     WITH -P8 OPTION
C
C === MACHINE = CONVEX.IEEE.P8
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     0 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    53 /
C      DATA IMACH(12) / -1021 /
C      DATA IMACH(13) /  1024 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE CYBER 170/180 SERIES USING NOS (FTN5).
C
C === MACHINE = CYBER.170.NOS
C === MACHINE = CYBER.180.NOS
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   60 /
C      DATA IMACH( 6) /   10 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   48 /
C      DATA IMACH( 9) / O"00007777777777777777" /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   48 /
C      DATA IMACH(12) / -974 /
C      DATA IMACH(13) / 1070 /
C      DATA IMACH(14) /   96 /
C      DATA IMACH(15) / -927 /
C      DATA IMACH(16) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CDC 180 SERIES USING NOS/VE
C
C === MACHINE = CYBER.180.NOS/VE
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     7 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    63 /
C      DATA IMACH( 9) / 9223372036854775807 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -4095 /
C      DATA IMACH(13) /  4094 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -4095 /
C      DATA IMACH(16) /  4094 /
C
C     MACHINE CONSTANTS FOR THE CYBER 205
C
C === MACHINE = CYBER.205
C      DATA IMACH( 1) /      5 /
C      DATA IMACH( 2) /      6 /
C      DATA IMACH( 3) /      7 /
C      DATA IMACH( 4) /      6 /
C      DATA IMACH( 5) /     64 /
C      DATA IMACH( 6) /      8 /
C      DATA IMACH( 7) /      2 /
C      DATA IMACH( 8) /     47 /
C      DATA IMACH( 9) / X'00007FFFFFFFFFFF' /
C      DATA IMACH(10) /      2 /
C      DATA IMACH(11) /     47 /
C      DATA IMACH(12) / -28625 /
C      DATA IMACH(13) /  28718 /
C      DATA IMACH(14) /     94 /
C      DATA IMACH(15) / -28625 /
C      DATA IMACH(16) /  28718 /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C === MACHINE = CDC.6000
C === MACHINE = CDC.7000
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   60 /
C      DATA IMACH( 6) /   10 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   48 /
C      DATA IMACH( 9) / 00007777777777777777B /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   48 /
C      DATA IMACH(12) / -974 /
C      DATA IMACH(13) / 1070 /
C      DATA IMACH(14) /   96 /
C      DATA IMACH(15) / -927 /
C      DATA IMACH(16) / 1070 /
C
C     MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
C     USING THE 46 BIT INTEGER COMPILER OPTION
C
C === MACHINE = CRAY.46-BIT-INTEGER
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /   102 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    46 /
C      DATA IMACH( 9) /  777777777777777777777B /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -8189 /
C      DATA IMACH(13) /  8190 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -8099 /
C      DATA IMACH(16) /  8190 /
C
C     MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3.
C     USING THE 64 BIT INTEGER COMPILER OPTION
C
C === MACHINE = CRAY.64-BIT-INTEGER
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /   102 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    64 /
C      DATA IMACH( 6) /     8 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    63 /
C      DATA IMACH( 9) /  777777777777777777777B /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    47 /
C      DATA IMACH(12) / -8189 /
C      DATA IMACH(13) /  8190 /
C      DATA IMACH(14) /    94 /
C      DATA IMACH(15) / -8099 /
C      DATA IMACH(16) /  8190 /C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C === MACHINE = DATA_GENERAL.ECLIPSE.S/200
C      DATA IMACH( 1) /   11 /
C      DATA IMACH( 2) /   12 /
C      DATA IMACH( 3) /    8 /
C      DATA IMACH( 4) /   10 /
C      DATA IMACH( 5) /   16 /
C      DATA IMACH( 6) /    2 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   15 /
C      DATA IMACH( 9) /32767 /
C      DATA IMACH(10) /   16 /
C      DATA IMACH(11) /    6 /
C      DATA IMACH(12) /  -64 /
C      DATA IMACH(13) /   63 /
C      DATA IMACH(14) /   14 /
C      DATA IMACH(15) /  -64 /
C      DATA IMACH(16) /   63 /
C
C     ELXSI  6400
C
C === MACHINE = ELSXI.6400
C      DATA IMACH( 1) /     5 /
C      DATA IMACH( 2) /     6 /
C      DATA IMACH( 3) /     6 /
C      DATA IMACH( 4) /     6 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     4 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    32 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    24 /
C      DATA IMACH(12) /  -126 /
C      DATA IMACH(13) /   127 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1022 /
C      DATA IMACH(16) /  1023 /
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C     MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7
C
C === MACHINE = HARRIS.220
C === MACHINE = HARRIS.SLASH6
C === MACHINE = HARRIS.SLASH7
C      DATA IMACH( 1) /       5 /
C      DATA IMACH( 2) /       6 /
C      DATA IMACH( 3) /       0 /
C      DATA IMACH( 4) /       6 /
C      DATA IMACH( 5) /      24 /
C      DATA IMACH( 6) /       3 /
C      DATA IMACH( 7) /       2 /
C      DATA IMACH( 8) /      23 /
C      DATA IMACH( 9) / 8388607 /
C      DATA IMACH(10) /       2 /
C      DATA IMACH(11) /      23 /
C      DATA IMACH(12) /    -127 /
C      DATA IMACH(13) /     127 /
C      DATA IMACH(14) /      38 /
C      DATA IMACH(15) /    -127 /
C      DATA IMACH(16) /     127 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
C
C === MACHINE = HONEYWELL.600/6000
C === MACHINE = HONEYWELL.DPS.8/70
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /   43 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / O377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   63 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     3 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C === MACHINE = HP.2100.3_WORD_DP
C      DATA IMACH(1) /      5/
C      DATA IMACH(2) /      6 /
C      DATA IMACH(3) /      4 /
C      DATA IMACH(4) /      1 /
C      DATA IMACH(5) /     16 /
C      DATA IMACH(6) /      2 /
C      DATA IMACH(7) /      2 /
C      DATA IMACH(8) /     15 /
C      DATA IMACH(9) /  32767 /
C      DATA IMACH(10)/      2 /
C      DATA IMACH(11)/     23 /
C      DATA IMACH(12)/   -128 /
C      DATA IMACH(13)/    127 /
C      DATA IMACH(14)/     39 /
C      DATA IMACH(15)/   -128 /
C      DATA IMACH(16)/    127 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     4 WORD DOUBLE PRECISION OPTION WITH FTN4
C
C === MACHINE = HP.2100.4_WORD_DP
C      DATA IMACH(1) /      5 /
C      DATA IMACH(2) /      6 /
C      DATA IMACH(3) /      4 /
C      DATA IMACH(4) /      1 /
C      DATA IMACH(5) /     16 /
C      DATA IMACH(6) /      2 /
C      DATA IMACH(7) /      2 /
C      DATA IMACH(8) /     15 /
C      DATA IMACH(9) /  32767 /
C      DATA IMACH(10)/      2 /
C      DATA IMACH(11)/     23 /
C      DATA IMACH(12)/   -128 /
C      DATA IMACH(13)/    127 /
C      DATA IMACH(14)/     55 /
C      DATA IMACH(15)/   -128 /
C      DATA IMACH(16)/    127 /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86 AND
C     THE INTERDATA 3230 AND INTERDATA 7/32.
C
C === MACHINE = IBM.360
C === MACHINE = IBM.370
C === MACHINE = XEROX.SIGMA.5
C === MACHINE = XEROX.SIGMA.7
C === MACHINE = XEROX.SIGMA.9
C === MACHINE = SEL.85
C === MACHINE = SEL.86
C === MACHINE = INTERDATA.3230
C === MACHINE = INTERDATA.7/32
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   7 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / Z7FFFFFFF /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  63 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  63 /
C
C     MACHINE CONSTANTS FOR THE INTERDATA 8/32
C     WITH THE UNIX SYSTEM FORTRAN 77 COMPILER.
C
C     FOR THE INTERDATA FORTRAN VII COMPILER REPLACE
C     THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S.
C
C === MACHINE = INTERDATA.8/32.UNIX
C      DATA IMACH( 1) /   5 /
C      DATA IMACH( 2) /   6 /
C      DATA IMACH( 3) /   6 /
C      DATA IMACH( 4) /   6 /
C      DATA IMACH( 5) /  32 /
C      DATA IMACH( 6) /   4 /
C      DATA IMACH( 7) /   2 /
C      DATA IMACH( 8) /  31 /
C      DATA IMACH( 9) / Z'7FFFFFFF' /
C      DATA IMACH(10) /  16 /
C      DATA IMACH(11) /   6 /
C      DATA IMACH(12) / -64 /
C      DATA IMACH(13) /  62 /
C      DATA IMACH(14) /  14 /
C      DATA IMACH(15) / -64 /
C      DATA IMACH(16) /  62 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C
C === MACHINE = PDP-10.KA
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    5 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / "377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   54 /
C      DATA IMACH(15) / -101 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C
C === MACHINE = PDP-10.KI
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    5 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / "377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   62 /
C      DATA IMACH(15) / -128 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     32-BIT INTEGER ARITHMETIC.
C
C === MACHINE = PDP-11.32-BIT
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   32 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   31 /
C      DATA IMACH( 9) / 2147483647 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   56 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
C     16-BIT INTEGER ARITHMETIC. 
C
C === MACHINE = PDP-11.16-BIT
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    7 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   16 /
C      DATA IMACH( 6) /    2 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   15 /
C      DATA IMACH( 9) / 32767 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   24 /
C      DATA IMACH(12) / -127 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   56 /
C      DATA IMACH(15) / -127 /
C      DATA IMACH(16) /  127 /
C
C     MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000.
C
C === MACHINE = SEQUENT.BALANCE.8000
C      DATA IMACH( 1) /     0 /
C      DATA IMACH( 2) /     0 /
C      DATA IMACH( 3) /     7 /
C      DATA IMACH( 4) /     0 /
C      DATA IMACH( 5) /    32 /
C      DATA IMACH( 6) /     1 /
C      DATA IMACH( 7) /     2 /
C      DATA IMACH( 8) /    31 /
C      DATA IMACH( 9) /  2147483647 /
C      DATA IMACH(10) /     2 /
C      DATA IMACH(11) /    24 /
C      DATA IMACH(12) /  -125 /
C      DATA IMACH(13) /   128 /
C      DATA IMACH(14) /    53 /
C      DATA IMACH(15) / -1021 /
C      DATA IMACH(16) /  1024 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. FTN COMPILER
C
C === MACHINE = UNIVAC.1100
C      DATA IMACH( 1) /    5 /
C      DATA IMACH( 2) /    6 /
C      DATA IMACH( 3) /    1 /
C      DATA IMACH( 4) /    6 /
C      DATA IMACH( 5) /   36 /
C      DATA IMACH( 6) /    4 /
C      DATA IMACH( 7) /    2 /
C      DATA IMACH( 8) /   35 /
C      DATA IMACH( 9) / O377777777777 /
C      DATA IMACH(10) /    2 /
C      DATA IMACH(11) /   27 /
C      DATA IMACH(12) / -128 /
C      DATA IMACH(13) /  127 /
C      DATA IMACH(14) /   60 /
C      DATA IMACH(15) /-1024 /
C      DATA IMACH(16) / 1023 /
C
C     MACHINE CONSTANTS FOR THE VAX 11/780
C
C === MACHINE = VAX.11/780
C      DATA IMACH(1) /    5 /
C      DATA IMACH(2) /    6 /
C      DATA IMACH(3) /    5 /
C      DATA IMACH(4) /    6 /
C      DATA IMACH(5) /   32 /
C      DATA IMACH(6) /    4 /
C      DATA IMACH(7) /    2 /
C      DATA IMACH(8) /   31 /
C      DATA IMACH(9) /2147483647 /
C      DATA IMACH(10)/    2 /
C      DATA IMACH(11)/   24 /
C      DATA IMACH(12)/ -127 /
C      DATA IMACH(13)/  127 /
C      DATA IMACH(14)/   56 /
C      DATA IMACH(15)/ -127 /
C      DATA IMACH(16)/  127 /
C
C
C***FIRST EXECUTABLE STATEMENT  I1MACH
C
      I1MACH=IMACH(I)
      RETURN
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED
C***END PROLOGUE  DSETN
C
C     VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEX VARIABLE.
      INTEGER J
C        AN INDEX VARIABLE.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT
C        VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
C
C
C***FIRST EXECUTABLE STATEMENT  DSETN
C
C
      IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN
C
C     SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS
C     IF THERE IS ONE, OTHERWISE FIRST ROW IS USED.
C
      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
C
      NROW = 1
C
      RETURN
      END
*DODPER
      SUBROUTINE DODPER
     +   (INFO,LUNERR,SHORT,
     +   N,NP,M,
     +   LDSCLD,LDRHO,
     +   LWKMN,LIWKMN,
     +   SCLD,SCLB,W,RHO,
     +   MSGB,ISODR,MSGX,
     +   XPLUSD,LDXPD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPER
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DODPE1,DODPE2,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS.
C***END PROLOGUE  DODPER
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER D1
C        THE FIRST DIGIT OF INFO.
      INTEGER D2
C        THE SECOND DIGIT OF INFO.
      INTEGER D3
C        THE THIRD DIGIT OF INFO.
      INTEGER D4
C        THE FOURTH DIGIT OF INFO.
      INTEGER D5
C        THE FIFTH DIGIT OF INFO.
      LOGICAL HEAD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE
C        HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER LIWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
      INTEGER LUNERR
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      INTEGER NTOL
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL SHORT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS
C        INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-
C        CALL (SHORT=.FALSE.).
      INTEGER UNIT
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
C
C
C***FIRST EXECUTABLE STATEMENT  DODPER
C
C
C  SET LOGICAL UNIT NUMBER FOR ERROR REPORT
C
      IF (LUNERR.EQ.0) THEN
         RETURN
      ELSE IF (LUNERR.LT.0) THEN
         UNIT = 6
      ELSE
         UNIT = LUNERR
      END IF
C
C  PRINT HEADING
C
      HEAD = .TRUE.
      CALL DODPHD(HEAD,UNIT)
C
      IF (INFO.LT.0) THEN
C
C  PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FUN OR JAC
C
         WRITE (UNIT,1000) INFO
      ELSE
C
C  PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP
C
         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
         IF (D1.GE.1 .AND. D1.LE.3) THEN
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN
C     PROBLEM SPECIFICATION PARAMETERS
C     DIMENSION SPECIFICATION PARAMETERS
C     NUMBER OF GOOD DIGITS IN X
C     OBSERVATIONAL ERROR WEIGHTS
C     DELTA WEIGHTS
C
            CALL DODPE1
     +         (UNIT,D1,D2,D3,D4,D5,
     +         N,M,
     +         LDSCLD,LDRHO,
     +         LWKMN,LIWKMN,
     +         SCLD,SCLB,NP,W,RHO)
         ELSE
            CALL DODPE2
     +         (UNIT,
     +         NP,M,
     +         MSGB,ISODR,MSGX,
     +         XPLUSD,LDXPD,NROW,NETA,NTOL)
         END IF
      END IF
C
C  PRINT CORRECT FORM OF CALL STATEMENT
C
      IF (INFO.LT.0 .OR.
     +    (D1.GE.1 .AND. D1.LE.3) .OR.
     +    (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2))) THEN
         IF (SHORT) THEN
            WRITE (UNIT,2100)
         ELSE
            WRITE (UNIT,2200)
         END IF
      END IF
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1000 FORMAT
     +   (//' THE USER HAS REQUESTED THAT THE COMPUTATIONS BE STOPPED'/
     +      ' IN USER-SUPPLIED SUBROUTINE FUN OR JAC.  THE USER-SET'/
     +      ' VALUE OF IFLAG IS ', I5)
 2100 FORMAT
     +   (//' THE CORRECT FORM OF THE CALL STATEMENT IS '//
     +      '       CALL DODR'/
     +      '      +     (FUN,JAC,'/
     +      '      +     N,M,NP,'/
     +      '      +     X,LDX,'/
     +      '      +     Y,'/
     +      '      +     BETA,'/
     +      '      +     RHO,LDRHO,'/
     +      '      +     JOB,'/
     +      '      +     WORK,LWORK,IWORK,LIWORK,'/
     +      '      +     INFO)')
 2200 FORMAT
     +   (//' THE CORRECT FORM OF THE CALL STATEMENT IS '//
     +      '       CALL DODRC'/
     +      '      +     (FUN,JAC,'/
     +      '      +     N,M,NP,'/
     +      '      +     X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,'/
     +      '      +     Y,'/
     +      '      +     BETA,IFIXB,SCLB,'/
     +      '      +     RHO,LDRHO,W,'/
     +      '      +     JOB,TAUFAC,'/
     +      '      +     SSTOL,PARTOL,MAXIT,'/
     +      '      +     IPRINT,LUNERR,LUNRPT,'/
     +      '      +     WORK,LWORK,IWORK,LIWORK,'/
     +      '      +     INFO)')
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE XPY = X + Y
C***END PROLOGUE  DXPY
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
      INTEGER LDXPY
C        THE LEADING DIMENSION OF ARRAY XPY.
      INTEGER LDY
C        THE LEADING DIMENSION OF ARRAY Y.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y TO BE ADDED
C        TOGETHER.
      INTEGER N
C        THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y TO BE ADDED
C        TOGETHER.
      DOUBLE PRECISION X(LDX,M)
C        THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER.
      DOUBLE PRECISION XPY(LDXPY,M)
C        THE SUM OF THE TWO ARRAYS TO BE ADDED TOGETHER.
      DOUBLE PRECISION Y(LDY,M)
C        THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER.
C
C
C***FIRST EXECUTABLE STATEMENT  DXPY
C
C
      DO 20 J=1,M
         DO 10 I=1,N
            XPY(I,J) = X(I,J) + Y(I,J)
   10    CONTINUE
   20 CONTINUE
C
      RETURN
      END
*DODMN
      SUBROUTINE DODMN
     +   (FUN,JAC,
     +   N,NP,NPP,M,JOB,
     +   X,LDX,IFIXX,LDIFX,Y,
     +   BETAC,IFIXB,BETA,BETAN,BETAS,S,
     +   DELTA,DELTAN,DELTAS,T,
     +   F,FN,FS,
     +   FJACB,LDFJB,MSGB,FJACX,LDFJX,MSGX,STP,
     +   W,RHO,LDRHO,SSF,SS,TT,LDTT,
     +   XPLUSD,DDELT,SSS,
     +   WORK,LWORK,IWORK,LIWORK,INFO)
C***BEGIN PROLOGUE  DODMN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DACCES,DCOPY,DDIAGS,DDIAGW,DDOT,DEVFUN,DEVJAC,
C                    DFLAGS,DGETCP,DNRM2,DODLM,DODLMW,DODPCR,
C                    DSTORE,DUNPAC,DWDS,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  ITERATIVELY COMPUTE LEAST SQUARES SOLUTION
C***END PROLOGUE  DODMN
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DDOT
      DOUBLE PRECISION DNRM2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ACTRED
C        THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES OF THE
C        WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION ACTRS
C        THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION BETAC(NP)
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      DOUBLE PRECISION BETAN(NP)
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      DOUBLE PRECISION BETAS(NP)
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      LOGICAL CNVPAR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER PARAMETER
C        CONVERGENCE HAS BEEN ATTAINED (CNVPAR=.TRUE.) OR NOT
C        (CNVPAR=.FALSE.).
      LOGICAL CNVSS
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER SUM-OF-SQUARES
C        CONVERGENCE HAS BEEN ATTAINED (CNVSS=.TRUE.) OR NOT
C        (CNVSS=.FALSE.).
      DOUBLE PRECISION DDELT(N,M)
C        THE ARRAY (W*D)**2 * DELTA.
      DOUBLE PRECISION DELTA(N,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DELTAN(N,M)
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DELTAS(N,M)
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DIRDER
C        THE DIRECTIONAL DERIVATIVE.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      DOUBLE PRECISION FN(N)
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      DOUBLE PRECISION FS(N)
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      LOGICAL FSTITR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE
C        FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.).
      LOGICAL HEAD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE
C        HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      INTEGER INT2
C        THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN.
      LOGICAL INTDBL
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER INTERNAL
C        DOUBLING IS TO BE USED (INTDBL=.TRUE.) OR NOT (INTDBL=.FALSE.).
      INTEGER IPR1
C        THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE INITIAL SUMMARY REPORT.
      INTEGER IPR2
C        THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE ITERATION REPORTS.
      INTEGER IPR2F
C        THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
      INTEGER IPR3
C        THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE FINAL SUMMARY REPORT.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVT
C        THE PIVOT VECTOR.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL LSTEP
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER A SUCCESSFUL
C        STEP HAS BEEN FOUND (LSTEP=.TRUE.) OR NOT (LSTEP=.FALSE.).
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NLMS
C        THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION OLMAVG
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGA
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION P0001
C        THE VALUE 0.0001D0.
      DOUBLE PRECISION P1
C        THE VALUE 0.1D0.
      DOUBLE PRECISION P25
C        THE VALUE 0.25D0.
      DOUBLE PRECISION P5
C        THE VALUE 0.5D0.
      DOUBLE PRECISION P75
C        THE VALUE 0.75D0.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION PNORM
C        THE NORM OF THE SCALED ESTIMATED PARAMETERS.
      DOUBLE PRECISION PRERED
C        THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION PRERS
C        THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER QRAUX
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      DOUBLE PRECISION RATIO
C        THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED
C        RELATIVE REDUCTION IN THE SUM-OF-SQUARES.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION RNORMN
C        THE NORM OF THE NEW WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION RNORMS
C        THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION S(NP)
C        THE STEP FOR THE ESTIMATED BETA'S.
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSF(NP)
C        THE SCALE USED FOR THE BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSS(N+N*M)
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION STP(N)
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION T(N,M)
C        THE STEP FOR THE ESTIMATED DELTA'S.
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TEMP
C        A TEMPORARY STORAGE LOCATION.
      DOUBLE PRECISION TEMP1
C        A TEMPORARY STORAGE LOCATION.
      DOUBLE PRECISION TEMP2
C        A TEMPORARY STORAGE LOCATION.
      INTEGER TFJACB
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      DOUBLE PRECISION TSNORM
C        THE NORM OF THE SCALED STEP.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER U
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(N,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER YT
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO,P0001,P1,P25,P5,P75,ONE
     +    /0.0D0,0.00010D0,0.10D0,0.250D0,0.50D0,0.750D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODMN
C
C
C  INITIALIZE NECESSARY VARIABLES
C
      CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR)
      CALL DGETCP(N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,
     +   LUNRPT,IPR1,IPR2,IPR2F,IPR3)
      CALL DODLMW(N,M,NP,
     +   JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2)
C
      IRANK = 0
      INTDBL = .FALSE.
      LSTEP = .TRUE.
      HEAD = .TRUE.
C
      FSTITR = .TRUE.
      IF (RESTRT) THEN
C
C  RESTART: ACCESS VALUES STORED FROM PREVIOUS RUNS
C
         CALL DACCES
     +      (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +      RNORM,TAU,ALPHA,NFEV,NJEV,INT2,OLMAVG)
         CALL DCOPY(N,FN,1,F,1)
      ELSE
C
C  NOT A RESTART: INITIALIZE VALUES AS APPROPRIATE
C
         NFEV = 0
         NJEV = 0
         INT2 = 0
         OLMAVG = ZERO
         ALPHA = ZERO
C
C  COMPUTE NORM OF THE INITIAL APPROXIMATION AND
C  INITIALIZE TRUST REGION RADIUS
C
         IF (NPP.GE.1) THEN
            CALL DDIAGS(NPP,1,SS,NPP,BETAC,NPP,SSS,NPP)
         END IF
         CALL DDIAGS(N,M,TT,LDTT,DELTA,N,SSS(NPP+1),N)
         PNORM = DNRM2(NPP+N*M,SSS,1)
C
         TAU = -TAUFAC
C
C  EVALUATE THE WEIGHTED EPSILONS AT THE STARTING POINT
C
         CALL DEVFUN(N,NP,M,BETAC,BETA,IFIXB,FUN,
     +               X,LDX,Y,DELTA,N,XPLUSD,N,
     +               W,F,NFEV,IFLAG)
         IF (IFLAG .LT. 0) THEN
            INFO = IFLAG
            OLMAVG = ZERO
            GO TO 40
         END IF
C
C  COMPUTE NORM OF WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORM)
C
         CALL DCOPY(N,F,1,SSS,1)
         CALL DWDS(N,M,W,RHO,LDRHO,DELTA,N,SSS(N+1),N)
         RNORM = DNRM2(N+N*M,SSS,1)
      END IF
C
C  PRINT INITIAL SUMMARY IF DESIRED
C
      IF (IPR1.NE.0) THEN
         IFLAG = 1
         CALL DODPCR(HEAD,IFLAG,IPR1,FSTITR,LUNRPT,
     +               ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +               MSGB,MSGX,
     +               N,M,NP,NPP,
     +               X,LDX,IFIXX,LDIFX,
     +               DELTA,RHO,LDRHO,TT,LDTT,
     +               Y,W,
     +               BETA,IFIXB,SSF,
     +               JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +               RNORM,SSS(1+N),SSS,
     +               NJEV,NFEV,ACTRED,PRERED,TAU,PNORM,ALPHA,
     +               F,RCOND,IRANK,INFO)
      END IF
C
C  STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION
C
      IF (RNORM .EQ. ZERO) THEN
         INFO = 1
         OLMAVG = ONE
         GO TO 40
      END IF
C
C  MAIN LOOP
C
   10 CONTINUE
C
C  EVALUATE JACOBIAN
C
      CALL DEVJAC(FUN,JAC,ANAJAC,N,NP,NPP,M,BETAC,BETA,
     +            IFIXB,IFIXX,LDIFX,
     +            X,LDX,DELTA,N,XPLUSD,N,
     +            SS,TT,LDTT,EPSMAC,FN,STP,
     +            FJACB,LDFJB,ISODR,FJACX,LDFJX,W,NJEV,NFEV,IFLAG)
      IF (IFLAG .LT. 0) THEN
         INFO = IFLAG
         OLMAVG = OLMAVG/NFEV
         GO TO 40
      END IF
C
C  COMPUTE DDELT = (W*D)**2 * DELTA
C
      CALL DWDS(N,M,W,RHO,LDRHO,DELTA,N,DDELT,N)
      CALL DWDS(N,M,W,RHO,LDRHO,DDELT,N,DDELT,N)
C
C  SUB LOOP FOR
C     INTERNAL DOUBLING OR
C     COMPUTING NEW STEP WHEN OLD FAILED
C
   20 CONTINUE
C
C  COMPUTE STEPS S AND T
C
      CALL DODLM(N,NP,NPP,M,
     +           F,FJACB,LDFJB,FJACX,LDFJX,
     +           W,RHO,LDRHO,SS,TT,LDTT,DDELT,
     +           ALPHA,TAU,EPSMAC,
     +           SSS,WORK(WRK1),WORK(TFJACB),WORK(OMEGA),WORK(YT),
     +           WORK(U),WORK(QRAUX),WORK(WRK2),IWORK(JPVT),
     +           S,T,NLMS,RCOND,IRANK)
      OLMAVG = OLMAVG+NLMS
C
C  COMPUTE BETAN = BETAC + S
C          DELTAN = DELTA + T
C
      CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP)
      CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N)
C
C  COMPUTE NORM OF SCALED STEPS S AND T (TSNORM)
C
      IF (NPP.GE.1) THEN
         CALL DDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP)
      END IF
      CALL DDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N)
      TSNORM = DNRM2(NPP+N*M,SSS,1)
C
C  COMPUTE SCALED PREDICTED REDUCTION
C
      DO 30 I=1,N
        SSS(I) = DDOT(NPP,FJACB(I,1),LDFJB,S,1) +
     +           DDOT(M,FJACX(I,1),LDFJX,T(I,1),N)
   30 CONTINUE
      CALL DWDS(N,M,W,RHO,LDRHO,T,N,SSS(N+1),N)
      TEMP1 = DNRM2(N+N*M,SSS,1)/RNORM
      TEMP2 = SQRT(ALPHA)*TSNORM/RNORM
      PRERED = TEMP1**2+TEMP2**2/P5
C
      DIRDER = -(TEMP1**2+TEMP2**2)
C
C  EVALUATE WEIGHTED EPSILONS AT NEW POINT
C
      CALL DEVFUN(N,NP,M,BETAN,BETA,IFIXB,FUN,
     +            X,LDX,Y,DELTAN,N,XPLUSD,N,
     +            W,FN,NFEV,IFLAG)
      IF (IFLAG .LT. 0) THEN
         INFO = IFLAG
         OLMAVG = OLMAVG/NFEV
         GO TO 40
      END IF
C
C  COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN)
C
      CALL DCOPY(N,FN,1,SSS,1)
      CALL DWDS(N,M,W,RHO,LDRHO,DELTAN,N,SSS(N+1),N)
      RNORMN = DNRM2(N+N*M,SSS,1)
C
C  COMPUTE SCALED ACTUAL REDUCTION
C
      IF (P1*RNORMN.LT.RNORM) THEN
         ACTRED = ONE - (RNORMN/RNORM)**2
      ELSE
         ACTRED = -ONE
      END IF
C
C  COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION
C
      IF(PRERED .EQ. ZERO) THEN
         RATIO = ZERO
      ELSE
         RATIO = ACTRED/PRERED
      END IF
C
C  CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE
C
      IF (INTDBL .AND. RATIO.LT.P0001) THEN
         TAU = TAU*P5
         ALPHA = ALPHA/P5
         CALL DCOPY(NPP,BETAS,1,BETAN,1)
         CALL DCOPY(N*M,DELTAS,1,DELTAN,1)
         CALL DCOPY(N,FS,1,FN,1)
         ACTRED = ACTRS
         PRERED = PRERS
         RNORMN = RNORMS
         RATIO = P5
      END IF
C
C  UPDATE STEP BOUND
C
      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
C
      ELSE IF (ALPHA.EQ.ZERO) THEN
         TAU = TSNORM/P5
C
      ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN
C
C  STEP QUALIFIES FOR INTERNAL DOUBLING
C     - UPDATE TAU AND ALPHA
C     - SAVE INFORMATION FOR CURRENT POINT
C
         INTDBL = .TRUE.
C
         TAU = TSNORM/P5
         ALPHA = ALPHA*P5
C
         CALL DCOPY(NPP,BETAN,1,BETAS,1)
         CALL DCOPY(N*M,DELTAN,1,DELTAS,1)
         CALL DCOPY(N,FN,1,FS,1)
         ACTRS = ACTRED
         PRERS = PRERED
         RNORMS = RNORMN
      END IF
C
C  IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS
C
      IF (INTDBL .AND. TAU.GT.ZERO) THEN
         INT2 = INT2+1
         GO TO 20
      END IF
C
C  CHECK ACCEPTANCE
C
      IF (RATIO.GE.P0001) THEN
         CALL DCOPY(N,FN,1,F,1)
         CALL DCOPY(NPP,BETAN,1,BETAC,1)
         CALL DCOPY(N*M,DELTAN,1,DELTA,1)
         RNORM = RNORMN
         IF (NPP.GE.1) THEN
            CALL DDIAGS(NPP,1,SS,NPP,BETAC,NPP,SSS,NPP)
         END IF
         CALL DDIAGS(N,M,TT,LDTT,DELTA,N,SSS(NPP+1),N)
         PNORM = DNRM2(NPP+N*M,SSS,1)
         LSTEP = .TRUE.
      ELSE
         LSTEP = .FALSE.
      END IF
C
C  TEST CONVERGENCE
C
      INFO = 0
      CNVSS = ABS(ACTRED).LE.SSTOL .AND.
     +        PRERED.LE.SSTOL      .AND.
     +        P5*RATIO.LE.ONE
      CNVPAR = TAU.LE.PARTOL*PNORM
      IF (CNVSS)                            INFO = 1
      IF (CNVPAR)                           INFO = 2
      IF (CNVSS .AND. CNVPAR)               INFO = 3
C
C  PRINT ITERATION REPORT
C
      IF (INFO.NE.0 .OR. LSTEP) THEN
         IF (IPR2.NE.0) THEN
            IF (IPR2F.EQ.1 .OR. MOD(NJEV,IPR2F).EQ.1) THEN
               IFLAG = 2
               CALL DUNPAC(NP,BETAC,BETA,IFIXB)
               CALL DODPCR(HEAD,IFLAG,IPR2,FSTITR,LUNRPT,
     +                     ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +                     MSGB,MSGX,
     +                     N,M,NP,NPP,
     +                     X,LDX,IFIXX,LDIFX,
     +                     DELTA,RHO,LDRHO,TT,LDTT,
     +                     Y,W,
     +                     BETA,IFIXB,SSF,
     +                     JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +                     RNORM,SSS(1+N),SSS,
     +                     NJEV,NFEV,ACTRED,PRERED,TAU,PNORM,ALPHA,
     +                     F,RCOND,IRANK,INFO)
               FSTITR = .FALSE.
            END IF
         END IF
      END IF
C
C  CHECK IF FINISHED
C
      IF (INFO.EQ.0) THEN
         IF (LSTEP) THEN
C
C  BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET
C
            IF (NJEV.GE.MAXIT) THEN
               INFO = 4
            ELSE
               GO TO 10
            END IF
         ELSE
C
C  STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
C
            GO TO 20
         END IF
      END IF
C
   40 CONTINUE
C
C  COMPUTE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
C
      CALL DEVFUN(N,NP,M,BETAC,BETA,IFIXB,FUN,
     +            X,LDX,Y,DELTA,N,XPLUSD,N,
     +            -ONE,F,NFEV,IFLAG)
C
C  STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER
C
      OLMAVG = OLMAVG/(NFEV-1)
      CALL DSTORE
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   RNORM,TAU,ALPHA,NFEV,NJEV,INT2,OLMAVG,RCOND,IRANK)
C
C  ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO
C
      IF (INFO.GE.1) THEN
         IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN
            INFO = INFO + 100
         END IF
         IF (NPP.GE.1 .AND. NPP.EQ.IRANK) THEN
            INFO = INFO + 10
         END IF
      END IF
C
C  PRINT FINAL SUMMARY
C
      IF (IPR3.NE.0) THEN
         IFLAG = 3
C
C  COMPUTE WEIGHTED EPSILONS AND WEIGHTED DELTAS FOR FINAL SUMMARY
C
         CALL DDIAGW(N,1,W,F,N,SSS,N)
         CALL DWDS(N,M,W,RHO,LDRHO,DELTA,N,SSS(N+1),N)
         CALL DODPCR(HEAD,IFLAG,IPR3,FSTITR,LUNRPT,
     +               ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +               MSGB,MSGX,
     +               N,M,NP,NPP,
     +               X,LDX,IFIXX,LDIFX,
     +               DELTA,RHO,LDRHO,TT,LDTT,
     +               Y,W,
     +               BETA,IFIXB,SSF,
     +               JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +               RNORM,SSS(1+N),SSS,
     +               NJEV,NFEV,ACTRED,PRERED,TAU,PNORM,ALPHA,
     +               F,RCOND,IRANK,INFO)
      END IF
C
      RETURN
C
      END
*DINIWK
      SUBROUTINE DINIWK
     +   (N,M,NP,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,LDTT,
     +   BETA,IFIXB,SCLB,
     +   EPSMAC,SSTOL,PARTOL,MAXIT,TAUFAC,
     +   JOB,IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK)
C***BEGIN PROLOGUE  DINIWK
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DFLAGS,DIWINF,DSCLB,DSCLD,DWINF,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  INITIALIZE WORK VECTORS AS NECESSARY
C***END PROLOGUE  DINIWK
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IPRINT
C        THE PRINT CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNERR
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION NEGONE
C        THE VALUE -1.0D0.
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      DOUBLE PRECISION THREE
C          THE VALUE 3.0D0.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      DOUBLE PRECISION TWO
C          THE VALUE 2.0D0.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA NEGONE,ZERO,ONE,TWO,THREE/-1.0D0,0.0D0,1.0D0,2.0D0,3.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DINIWK
C
C
      CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR)
C
C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
C  STORE VALUE OF MACHINE PRECISION IN WORK VECTOR
C
      WORK(EPSMAI) = EPSMAC
C
C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  PARAMETERS
C
      IF (PARTOL.LT.EPSMAC .OR. PARTOL.GE.ONE) THEN
         WORK(PARTLI) = EPSMAC**(TWO/THREE)
      ELSE
         WORK(PARTLI) = PARTOL
      END IF
C
C  SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE
C  SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS
C
      IF (SSTOL.LT.EPSMAC .OR. SSTOL.GE.ONE) THEN
         WORK(SSTOLI) = SQRT(EPSMAC)
      ELSE
         WORK(SSTOLI) = SSTOL
      END IF
C
C  SET FACTOR FOR COMPUTING TRUST RETION DIAMETER AT FIRST ITERATION
C
      IF (TAUFAC.LE.ZERO) THEN
         WORK(TAUFCI) = ONE
      ELSE
         WORK(TAUFCI) = TAUFAC
      END IF
C
C  SET MAXIMUM NUMBER OF ITERATIONS
C
      IF (MAXIT.LE.0) THEN
         IWORK(MAXITI) = 50
      ELSE
         IWORK(MAXITI) = MAXIT
      END IF
C
C  SET PRINT CONTROL
C
      IF (IPRINT.LT.0) THEN
         IWORK(IPRINI) = 2001
      ELSE
         IWORK(IPRINI) = IPRINT
      END IF
C
C  SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES
C
      IF (LUNERR.LT.0) THEN
         IWORK(LUNERI) = 6
      ELSE
         IWORK(LUNERI) = LUNERR
      END IF
C
C  SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS
C
      IF (LUNRPT.LT.0) THEN
         IWORK(LUNRPI) = 6
      ELSE
         IWORK(LUNRPI) = LUNRPT
      END IF
C
C  COMPUTE SCALING FOR BETA'S AND DELTA'S
C
      IF (SCLB(1).LE.ZERO) THEN
         CALL DSCLB(NP,BETA,EPSMAC,WORK(SSFI))
      ELSE
         CALL DCOPY(NP,SCLB,1,WORK(SSFI),1)
      END IF
      IF (SCLD(1,1).LE.ZERO) THEN
         LDTT = N
         CALL DSCLD(N,M,X,LDX,WORK(TTI),LDTT)
      ELSE
         IF (LDSCLD.EQ.1) THEN
            LDTT = 1
            CALL DCOPY(N,SCLD(1,1),1,WORK(TTI),1)
         ELSE
            LDTT = N
            DO 10 J=1,M
               CALL DCOPY(N,SCLD(1,J),1,WORK(TTI+(J-1)*LDTT),1)
   10       CONTINUE
         END IF
      END IF
C
C  INITIALIZE DELTA'S AS NECESSARY
C
      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
C
      RETURN
      END
*DODPE2
      SUBROUTINE DODPE2
     +   (UNIT,
     +   NP,M,
     +   MSGB,ISODR,MSGX,
     +   XPLUSD,LDXPD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE  DODPE2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GENERATE THE DERIVATIVE CHECKING REPORT
C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO)
C***END PROLOGUE  DODPE2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL FTNOTE(6)
C        THE ARRAY WHICH CONTROLS PRINTING OF FOOTNOTES.
      INTEGER I
C        AN INDEX VARIABLE.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        AN INDEX VARIABLE.
      INTEGER K
C        AN INDEX VARIABLE.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER NETA
C        THE NUMBER OF RELIABLE DIGITS IN THE MODEL.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      INTEGER NTOL
C        THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE
C        FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES.
      CHARACTER*3 TYP
C        THE SOLUTION TYPE, ODR OR OLS.
      INTEGER UNIT
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
C
C
C***FIRST EXECUTABLE STATEMENT  DODPE2
C
C
C  SET UP FOR FOOTNOTES
C
      DO 10 I=1,6
         FTNOTE(I) = .FALSE.
   10 CONTINUE
C
      IF (MSGB(1).GE.1) THEN
         DO 20 I=1,NP
            IF (MSGB(I+1).GE.2) THEN
               FTNOTE(1) = .TRUE.
               FTNOTE(MSGB(I+1)) = .TRUE.
            END IF
   20    CONTINUE
      END IF
C
      IF (MSGX(1).GE.1) THEN
         DO 30 I=1,M
            IF (MSGX(I+1).GE.2) THEN
               FTNOTE(1) = .TRUE.
               FTNOTE(MSGX(I+1)) = .TRUE.
            END IF
   30    CONTINUE
      END IF
C
C     PRINT REPORT
C
      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF
      WRITE (UNIT,1000) TYP
      IF (FTNOTE(1)) WRITE (UNIT,2100)
      WRITE (UNIT,2200)
C
C
      DO 40 I=1,NP
         K = MSGB(I+1) - 1
         IF (K.EQ.(-1)) WRITE (UNIT,3100) I
         IF (K.EQ.0) WRITE (UNIT,3200) I
         IF (K.GE.1) WRITE (UNIT,3300) I, K
   40 CONTINUE
      IF (ISODR) THEN
         DO 50 I=1,M
            K = MSGX(I+1) - 1
            IF (K.EQ.(-1)) WRITE (UNIT,4100) NROW,I
            IF (K.EQ.0) WRITE (UNIT,4200) NROW,I
            IF (K.GE.1) WRITE (UNIT,4300) NROW,I,K
   50    CONTINUE
      END IF
C
C     PRINT FOOTNOTES
C
      IF (FTNOTE(1)) THEN
C
         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)
      END IF
C
      WRITE (UNIT,6000) NETA
      WRITE (UNIT,7000) NTOL
C
C  PRINT OUT ROW OF INDEPENDENT VARIABLE WHICH WAS CHECKED.
C
      WRITE (UNIT,8100) NROW
C
      DO 60 J=1,M
         WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J)
   60 CONTINUE
C
      RETURN
C
C     FORMAT STATEMENTS
C
 1000 FORMAT
     +   (//' DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3/
     +     ' ==================================================='/)
 2100 FORMAT ('                                    *')
 2200 FORMAT ('                          DERIVATIVE '/
     +        '       DERIVATIVE WRT     ASSESSMENT '/)
 3100 FORMAT ('            BETA(',I3,')         OK     ')
 3200 FORMAT ('            BETA(',I3,')      INCORRECT  ')
 3300 FORMAT ('            BETA(',I3,')    QUESTIONABLE (',I1,')')
 4100 FORMAT ('             X(',I2,',',I2,')         OK     ')
 4200 FORMAT ('             X(',I2,',',I2,')      INCORRECT  ')
 4300 FORMAT ('             X(',I2,',',I2,')    QUESTIONABLE (',I1,')')
 5100 FORMAT
     +   (/' *'/
     +     '  NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTES.')
 5200 FORMAT
     +   (/'  (1) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/
     +     '      AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE BOTH'/
     +     '      ARE ZERO.')
 5300 FORMAT
     +   (/'  (2) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/
     +     '      AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE USER-'/
     +     '      SUPPLIED DERIVATIVE IS IDENTICALLY ZERO AND FINITE '/
     +     '      DIFFERENCE DERIVATIVE IS ONLY APPROXIMATELY ZERO.')
 5400 FORMAT
     +   (/'  (3) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/
     +     '      DISAGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE'/
     +     '      USER-SUPPLIED DERIVATIVE IS IDENTICALLY ZERO.')
 5500 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.')
 5600 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.')
 6000 FORMAT
     *   (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS       ',I5)
 7000 FORMAT
     +   (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN      '/
     +     ' USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR  '/
     +     ' USER-SUPPLIED DERIVATIVE TO BE CONSIDERED CORRECT   ',I5)
 8100 FORMAT
     +   (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED        ',I5//
     +     '   -VALUES OF THE INDEPENDENT VARIABLES AT THIS ROW'/)
 8110 FORMAT
     +   (6X,'X(',I2,',',I2,')',1X,3D16.8)
      END
*DODPCR
      SUBROUTINE DODPCR
     +   (HEAD,IFLAG,IPR,FSTITR,LUNRPT,
     +   ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +   MSGB,MSGX,
     +   N,M,NP,NPP,
     +   X,LDX,IFIXX,LDIFX,
     +   DELTA,RHO,LDRHO,TT,LDTT,
     +   Y,W,
     +   BETA,IFIXB,SSF,
     +   JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   RNORM,DELWTD,FWTD,
     +   NJEV,NFEV,ACTRED,PRERED,TAU,PNORM,ALPHA,
     +   F,RCOND,IRANK,INFO)
C***BEGIN PROLOGUE  DODPCR
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DODPC1,DODPC2,DODPC3,DODPHD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GENERATE COMPUTATION REPORTS
C***END PROLOGUE  DODPCR
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ACTRED
C        THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      DOUBLE PRECISION DELTA(N,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DELWTD(N,M)
C        THE WEIGHTED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      LOGICAL FSTITR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE
C        FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.).
      DOUBLE PRECISION FWTD(N)
C        THE WEIGHTED ESTIMATED VALUES OF EPSILON.
      LOGICAL HEAD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE
C        HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED HERE TO DESIGNATE WHICH PART OF
C        THE REPORT IS TO BE PRINTED.
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      INTEGER IPR
C        THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION PNORM
C        THE NORM OF THE SCALED ESTIMATED PARAMETERS.
      DOUBLE PRECISION PRERED
C        THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION SSF(NP)
C        THE SCALE USED FOR THE BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      CHARACTER*3 TYP
C        THE CHARACTER STRING ODR OR OLS.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODPCR
C
C
      IF (HEAD) THEN
         CALL DODPHD(HEAD,LUNRPT)
      ELSE IF (IFLAG.NE.2 .OR. FSTITR) THEN
         WRITE (LUNRPT,1000)
      END IF
      IF (ISODR) THEN
         TYP = 'ODR'
      ELSE
         TYP = 'OLS'
      END IF
C
C  PRINT INITIAL SUMMARY
C
      IF (IFLAG.EQ.1) THEN
         IF (RESTRT) THEN
            WRITE (LUNRPT,1100) TYP
         ELSE
            WRITE (LUNRPT,1200) TYP
            CALL DODPC1
     +         (IPR,LUNRPT,
     +         ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +         MSGB,MSGX,
     +         N,M,NP,NPP,
     +         X,LDX,IFIXX,LDIFX,DELTA,RHO,LDRHO,TT,LDTT,
     +         Y,W,
     +         BETA,IFIXB,SSF,
     +         JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +         RNORM,DELWTD,FWTD)
         END IF
C
C  PRINT ITERATION REPORTS
C
      ELSE IF (IFLAG.EQ.2) THEN
C
         IF (FSTITR) THEN
            WRITE (LUNRPT,1300) TYP
         END IF
         CALL DODPC2
     +      (IPR,FSTITR,LUNRPT,NP,
     +      NJEV,NFEV,RNORM,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA)
C
C  PRINT FINAL SUMMARY
C
      ELSE IF (IFLAG.EQ.3) THEN
C
         WRITE (LUNRPT,1400) TYP
         CALL DODPC3
     +      (IPR,LUNRPT,
     +      N,M,NP,
     +      INFO,NJEV,NFEV,RCOND,IRANK,
     +      RNORM,DELWTD,FWTD,
     +      BETA,F,ISODR,DELTA)
      END IF
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1000 FORMAT(//)
 1100 FORMAT
     +   (////' RESTART OF FIT BY METHOD OF ',A3/
     +     ' ===============================')
 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
*DSTORE
      SUBROUTINE DSTORE
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   RNORM,TAU,ALPHA,NFEV,NJEV,INT2,OLMAVG,RCOND,IRANK)
C***BEGIN PROLOGUE  DSTORE
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  STORE COMPUTED SCALARS INTO WORK ARRAYS FOR RETURN TO USER
C***END PROLOGUE  DSTORE
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER INT2
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION OLMAVG
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
C
C
C***FIRST EXECUTABLE STATEMENT  DSTORE
C
C
C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
      WORK(RCONDI) = RCOND
      WORK(RNORMI) = RNORM
      WORK(TAUI) = TAU
      WORK(ALPHAI) = ALPHA
      WORK(OLMAVI) = OLMAVG
C
      IWORK(NFEVI) = NFEV
      IWORK(NJEVI) = NJEV
      IWORK(INT2I) = INT2
      IWORK(IRANKI) = IRANK
C
      RETURN
      END
*DODPC1
      SUBROUTINE DODPC1
     +   (IPR,LUNRPT,
     +   ANAJAC,CHKJAC,INITD,RESTRT,ISODR,
     +   MSGB,MSGX,
     +   N,M,NP,NPP,
     +   X,LDX,IFIXX,LDIFX,DELTA,RHO,LDRHO,TT,LDTT,
     +   Y,W,
     +   BETA,IFIXB,SSF,
     +   JOB,TAUFAC,SSTOL,PARTOL,MAXIT,
     +   RNORM,DELWTD,FWTD)
C***BEGIN PROLOGUE  DODPC1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DNRM2
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GENERATE INITIAL SUMMARY REPORT
C***END PROLOGUE  DODPC1
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DNRM2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL CHKJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER-
C        SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT
C        (CHKJAC=.FALSE.).
      DOUBLE PRECISION DELTA(N,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DELWTD(N,M)
C        THE WEIGHTED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      CHARACTER*90 FMT1
C        A CHARACTER VARIABLE USED FOR FORMATS.
      DOUBLE PRECISION FWTD(N)
C        THE WEIGHTED ESTIMATED VALUES OF EPSILON.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL INITD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S
C        ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY
C        ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M
C        ELEMENTS OF ARRAY WORK (INITD=.FALSE.).
      INTEGER IPR
C        THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JOB
C        THE PROBLEM INITIALIZATION AND COMPUTATIONAL
C        METHOD CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER K
C        AN INDEXING VARIABLE.
      INTEGER L
C        AN INDEXING VARIABLE.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB(NP+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX(M+1)
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPLM1
C        THE NUMBER OF ITEMS TO PRINT PER LINE, MINUS ONE.
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL RESTRT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS
C        A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE).
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION SSF(NP)
C        THE SCALE USED FOR THE BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      CHARACTER*5 TEMPC(10)
C        A TEMPORARY CHARACTER VECTOR.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODPC1
C
C
C  PRINT PROBLEM SIZE SPECIFICATION
C
      WRITE (LUNRPT,1000) N,M,NP,NPP
C
      IF (IPR.GE.2) THEN
C
C  PRINT INDEPENDENT VARIABLE DATA
C
         IF (ISODR) THEN
            WRITE (LUNRPT,2010)
         ELSE
            WRITE (LUNRPT,2020)
         END IF
         NPLM1 = 1
         DO 20 J = 1,M,NPLM1+1
            IF (.NOT.ISODR) THEN
               L = MIN(M,J+NPLM1) - J + 1
               WRITE (FMT1,7000) 6,L
               WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1))
               WRITE (FMT1,8000) 5,L
               WRITE (LUNRPT,FMT1)
               WRITE (LUNRPT,2100) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1))
            ELSE
               L = MIN(M,J+NPLM1) - J + 1
               WRITE (FMT1,7000) 20,L
               WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1))
               WRITE (FMT1,8000) 19,L
               WRITE (LUNRPT,FMT1)
               WRITE (LUNRPT,2200) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1))
               IF (IFIXX(1,1).LT.0) THEN
                  WRITE (LUNRPT,2300) ('   NO',K=1,2*L)
               ELSE
                  L = 0
                  DO 10 K=J,MIN(M,J+NPLM1)
                     L = L + 1
                     IF (IFIXX(1,K).EQ.0) THEN
                        TEMPC(2*L-1) = '  YES'
                     ELSE
                        TEMPC(2*L-1) = '   NO'
                     END IF
                     IF (LDIFX.EQ.1) THEN
                        IF (IFIXX(1,K).EQ.0) THEN
                           TEMPC(2*L) = '  YES'
                        ELSE
                           TEMPC(2*L) = '   NO'
                        END IF
                     ELSE
                        IF (IFIXX(N,K).EQ.0) THEN
                           TEMPC(2*L) = '  YES'
                        ELSE
                           TEMPC(2*L) = '   NO'
                        END IF
                     END IF
   10             CONTINUE
                  WRITE (LUNRPT,2300) (TEMPC(K),K=1,2*L)
               END IF
               WRITE (LUNRPT,2500) (DELTA(1,K),DELTA(N,K),
     +                              K=J,MIN(M,J+NPLM1))
               IF (TT(1,1).LT.0) THEN
                  WRITE (LUNRPT,2600) (ABS(TT(1,1)),ABS(TT(1,1)),
     +                                K=J,MIN(M,J+NPLM1))
               ELSE
                  IF (LDTT.EQ.1) THEN
                     WRITE (LUNRPT,2600) (TT(1,K),TT(1,K),
     +                                    K=J,MIN(M,J+NPLM1))
                  ELSE
                     WRITE (LUNRPT,2600) (TT(1,K),TT(N,K),
     +                                    K=J,MIN(M,J+NPLM1))
                  END IF
               END IF
               IF (RHO(1,1).LT.0) THEN
                  WRITE (LUNRPT,2700) (ABS(RHO(1,1)),ABS(RHO(1,1)),
     +                                K=J,MIN(M,J+NPLM1))
               ELSE
                  IF (LDRHO.EQ.1) THEN
                     WRITE (LUNRPT,2700) (RHO(1,K),RHO(1,K),
     +                                    K=J,MIN(M,J+NPLM1))
                  ELSE
                     WRITE (LUNRPT,2700) (RHO(1,K),RHO(N,K),
     +                                    K=J,MIN(M,J+NPLM1))
                  END IF
               END IF
            END IF
   20    CONTINUE
C
C  PRINT DEPENDENT VARIABLE DATA AND OBSERVATION ERROR WEIGHTS
C
         WRITE (LUNRPT,3000)
         WRITE (FMT1,8000) 19,1
         WRITE (LUNRPT,FMT1)
         WRITE (LUNRPT,3100) Y(1),Y(N)
         IF (W(1).LT.ZERO) THEN
            WRITE (LUNRPT,3200) ONE,ONE
         ELSE
            WRITE (LUNRPT,3200) W(1),W(N)
         END IF
C
C  PRINT FUNCTION PARAMETER DATA
C
         WRITE (LUNRPT,4000)
         NPLM1 = 3
         DO 50 J=1,NP,NPLM1+1
            WRITE (LUNRPT,4100) (K,K=J,MIN(NP,J+NPLM1))
            WRITE (LUNRPT,4200) (BETA(K),K=J,MIN(NP,J+NPLM1))
            L = 0
            IF (IFIXB(1).LT.0) THEN
               DO 30 K=J,MIN(NP,J+NPLM1)
                  L = L + 1
                  TEMPC(L) = '   NO'
   30          CONTINUE
            ELSE
               DO 40 K=J,MIN(NP,J+NPLM1)
                  L = L + 1
                  IF (IFIXB(K).NE.0) THEN
                     TEMPC(L) = '   NO'
                  ELSE
                     TEMPC(L) = '  YES'
                  END IF
   40          CONTINUE
            END IF
            WRITE (LUNRPT,4300) (TEMPC(K),K=1,L)
            IF (SSF(1).LT.ZERO) THEN
               WRITE (LUNRPT,4400) (ABS(SSF(1)),K=J,MIN(NP,J+NPLM1))
            ELSE
               WRITE (LUNRPT,4400) (SSF(K),K=J,MIN(NP,J+NPLM1))
            END IF
   50    CONTINUE
      END IF
C
C  PRINT JOB SPECS AND STOPPING CRITERIA
C
      WRITE (LUNRPT,5000) JOB,TAUFAC,SSTOL,PARTOL,MAXIT
      IF (RESTRT) THEN
         WRITE (LUNRPT,5110)
      ELSE
         WRITE (LUNRPT,5120)
      END IF
      IF (ISODR) THEN
         IF (INITD) THEN
            WRITE (LUNRPT,5311)
         ELSE
            WRITE (LUNRPT,5312)
         END IF
      ELSE
         WRITE (LUNRPT,5320)
      END IF
      IF (ANAJAC) THEN
         WRITE (LUNRPT,5410)
         IF (CHKJAC) THEN
            WRITE (LUNRPT,5411)
            IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN
               WRITE (LUNRPT,5412)
            ELSE
               WRITE (LUNRPT,5413)
            END IF
         ELSE
            WRITE (LUNRPT,5414)
         END IF
      ELSE
         WRITE (LUNRPT,5420)
      END IF
      IF (ISODR) THEN
         WRITE (LUNRPT,5510)
      ELSE
         WRITE (LUNRPT,5520)
      END IF
C
C  PRINT INITIAL SUM OF SQUARES
C
      WRITE (LUNRPT,6000)
      WRITE (LUNRPT,6100) RNORM**2
      IF (ISODR) THEN
         WRITE (LUNRPT,6200) DNRM2(N*M,DELWTD,1)**2
         WRITE (LUNRPT,6300) DNRM2(N,FWTD,1)**2
      END IF
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1000 FORMAT
     +   (///' PROBLEM SIZE:'/
     +       ' -------------'//
     +       ' NUMBER OF OBSERVATIONS                            ',I5/
     +       ' NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE ',I5/
     +       ' NUMBER OF FUNCTION PARAMETERS                     ',I5/
     +       ' NUMBER OF UNFIXED FUNCTION PARAMETERS             ',I5)
 2010 FORMAT
     +   (///' INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY:'/
     +       ' ----------------------------------------------')
 2020 FORMAT
     +   (///' INDEPENDENT VARIABLE SUMMARY:'/
     +       ' -----------------------------')
 2100 FORMAT
     +   (' X - ', 6D13.5)
 2200 FORMAT
     +   ('               X - ', 6D13.5)
 2300 FORMAT
     +   ('           FIXED - ', 6(8X,A5))
 2500 FORMAT
     +   ('   INITIAL DELTA - ', 6D13.5)
 2600 FORMAT
     +   ('     DELTA SCALE - ', 6D13.5)
 2700 FORMAT
     +   ('   DELTA WEIGHTS - ', 6D13.5)
 3000 FORMAT
     +   (///' DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT',
     +   ' SUMMARY:'/
     +       ' -------------------------------------------------',
     +   '---------'/)
 3100 FORMAT
     +   ('               Y - ', 6D13.5)
 3200 FORMAT
     +   (' OBS. ERROR WTS. - ', 6D13.5)
 4000 FORMAT
     +   (///' FUNCTION PARAMETER SUMMARY:'/
     +       ' ---------------------------')
 4100 FORMAT
     +   (/'        INDEX - ', 5I16)
 4200 FORMAT
     +   (' INITIAL BETA - ', 5D16.8)
 4300 FORMAT
     +   ('        FIXED - ', 5(11X,A5))
 4400 FORMAT
     +   ('   BETA SCALE - ', 5D16.8)
 5000 FORMAT
     +   (///' CONTROL VALUES AND STOPPING CRITERIA:'/
     +       ' --------------------------------------'//
     +       '       *                                     '/
     +       '    JOB    TAUFAC     SSTOL    PARTOL  MAXIT'/
     +       1X,I6.4,3D10.2,I7//' *')
 5110 FORMAT
     +   ('  A.  FIT IS A RESTART.')
 5120 FORMAT
     +   ('  A.  FIT IS NOT A RESTART.')
 5311 FORMAT
     +   ('  B.  DELTAS ARE INITIALIZED TO ZERO.')
 5312 FORMAT
     +   ('  B.  DELTAS ARE INITIALIZED BY USER.')
 5320 FORMAT
     +   ('  B.  DELTAS ARE FIXED AT ZERO.')
 5410 FORMAT
     +   ('  C.  DERIVATIVES ARE SUPPLIED BY USER.')
 5411 FORMAT
     +   ('      USER-SUPPLIED DERIVATIVES WERE CHECKED.')
 5412 FORMAT
     +   ('      THE CORRECTNESS OF SOME OF THE DERIVATIVES IS'/
     +    '      QUESTIONABLE.  SEE ERROR MESSAGES FOR DETAILS.')
 5413 FORMAT
     +   ('      THE DERIVATIVES APPEAR TO BE CORRECT.')
 5414 FORMAT
     +   ('      USER-SUPPLIED DERIVATIVES WERE NOT CHECKED.')
 5420 FORMAT
     +   ('  C.  DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES.')
 5510 FORMAT
     +   ('  D.  FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION.')
 5520 FORMAT
     +   ('  D.  FIT IS BY METHOD OF ORDINARY LEAST SQUARES.')
 6000 FORMAT
     +   (///' INITIAL SUMS OF SQUARES:'/
     +       ' ------------------------'/)
 6100 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', D17.8)
 6200 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED DELTAS               ', D17.8)
 6300 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED EPSILONS             ', D17.8)
 7000 FORMAT
     +   ('(/',I2,'X,',I2,'(''           COLUMN '',I3,''     ''))')
 8000 FORMAT
     +   ('(',I2,'X,',I2,'(''        OBS 1        OBS N''))')
      END
*DDIAGS
      SUBROUTINE DDIAGS
     +   (N,M,S,LDS,V,LDV,SV,LDSV)
C***BEGIN PROLOGUE  DDIAGS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SCALE THE VECTOR V BY THE DIAGONAL MATRIX S
C            AND RETURN THE RESULT IN VECTOR SV.
C***END PROLOGUE  DDIAGS
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDS
C        THE LEADING DIMENSION OF ARRAY S.
      INTEGER LDSV
C        THE LEADING DIMENSION OF ARRAY SV.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(LDS,M)
C        THE SCALING ARRAY.
      DOUBLE PRECISION SV(LDSV,M)
C        THE SCALED ARRAY.
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING SCALED.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (S(1,1).LT.ZERO) THEN
         DO 20 J=1,M
            DO 10 I=1,N
               SV(I,J) = ABS(S(1,1))*V(I,J)
   10       CONTINUE
   20    CONTINUE
      ELSE
         IF (LDS.EQ.1) THEN
            DO 40 J=1,M
               DO 30 I=1,N
                  SV(I,J) = S(1,J)*V(I,J)
   30          CONTINUE
   40       CONTINUE
         ELSE
            DO 60 J=1,M
               DO 50 I=1,N
                  SV(I,J) = S(I,J)*V(I,J)
   50          CONTINUE
   60       CONTINUE
         END IF
      END IF
C
      RETURN
      END
*DODPE1
      SUBROUTINE DODPE1
     +   (UNIT,D1,D2,D3,D4,D5,
     +   N,M,
     +   LDSCLD,LDRHO,
     +   LWKMN,LIWKMN,
     +   SCLD,SCLB,NP,W,RHO)
C***BEGIN PROLOGUE  DODPE1
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  PRINT ERROR REPORTS.
C***END PROLOGUE  DODPE1
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER D1
C        THE FIRST DIGIT OF INFO.
      INTEGER D2
C        THE SECOND DIGIT OF INFO.
      INTEGER D3
C        THE THIRD DIGIT OF INFO.
      INTEGER D4
C        THE FOURTH DIGIT OF INFO.
      INTEGER D5
C        THE FIFTH DIGIT OF INFO.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDSCLD
C        THE LEADING DIMENSION OF ARRAY SCLD.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LIWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK.
      INTEGER LWKMN
C        THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLB(NP)
C        THE SCALE OF EACH BETA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SCLD(LDSCLD,M)
C        THE SCALE OF EACH DELTA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER UNIT
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODPE1
C
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION
C  PARAMETERS
C
      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
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION
C  PARAMETERS
C
      ELSE IF (D1.EQ.2) THEN
         IF (D2.NE.0) THEN
            WRITE(UNIT,2100)
         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
            WRITE(UNIT,2300) LWKMN
         END IF
         IF (D5.NE.0) THEN
            WRITE(UNIT,2400) LIWKMN
         END IF
C
      ELSE IF (D1.EQ.3) THEN
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS SCALE VALUES
C
         IF (D2.NE.0) THEN
            IF (LDSCLD.GE.N) THEN
               WRITE(UNIT,3110)
            ELSE
               WRITE(UNIT,3120)
            END IF
         END IF
         IF (D3.NE.0) THEN
            WRITE(UNIT,3130)
         END IF
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS
C
         IF (D4.NE.0) THEN
            IF (D4.EQ.1) THEN
               WRITE(UNIT,3210)
            ELSE
               WRITE(UNIT,3220)
            END IF
         END IF
C
C  PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS
C
         IF (D5.NE.0) THEN
            IF (LDRHO.GE.N) THEN
               WRITE(UNIT,3310)
            ELSE
               WRITE(UNIT,3320)
            END IF
         END IF
C
      END IF
C
C  FORMAT STATEMENTS
C
 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.')
 2100 FORMAT
     +   (/' ERROR :  LDX 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 :  LDRHO IS LESS THAN N'/
     +     '          AND LDRHO IS NOT EQUAL TO ONE.')
 2300 FORMAT
     +   (/' ERROR :  LWORK IS LESS THAN ',I5, ','/
     +     '          THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.')
 2400 FORMAT
     +   (/' ERROR :  LIWORK IS LESS THAN ',I5, ','/
     +     '          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 :  W(I) IS LESS THAN ZERO FOR SOME I = 1, ..., N.'//
     +     '          WHEN W(1) IS GREATER THAN OR EQUAL TO ZERO THEN'/
     +     '          ALL N ELEMENTS OF',
     +              ' W MUST BE GREATER THAN OR EQUAL TO ZERO.')
 3220 FORMAT
     +   (/' ERROR :  THE NUMBER OF NON ZERO VALUES IN ARRAY W) IS'/
     +     '          LESS THAN NP.')
 3310 FORMAT
     +   (/' ERROR :  RHO(I,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME I = 1, ..., N AND J = 1, ..., M.'//
     +     '          WHEN RHO(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDRHO IS GREATER THAN OR EQUAL TO N THEN'/
     +     '          EACH OF THE N BY M ELEMENTS OF'/
     +     '          RHO MUST BE GREATER THAN ZERO.')
 3320 FORMAT
     +   (/' ERROR :  RHO(1,J) IS LESS THAN OR EQUAL TO ZERO'/
     +     '          FOR SOME J = 1, ..., M.'//
     +     '          WHEN RHO(1,1) IS GREATER THAN ZERO'/
     +     '          AND LDRHO IS EQUAL TO ONE THEN'/
     +     '          EACH OF THE 1 BY M ELEMENTS OF'/
     +     '          RHO MUST BE GREATER THAN ZERO.')
      END
*DETAF
      SUBROUTINE DETAF
     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,NETA,EPSMAC,
     +   NROW,PARTMP,PVTEMP,IFLAG)
C***BEGIN PROLOGUE  DETAF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS
C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE ETAFUN)
C***END PROLOGUE  DETAF
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION A
C        PARAMETERS OF THE FIT.
      DOUBLE PRECISION B
C        PARAMETERS OF THE FIT.
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION ETA
C        THE NOISE IN THE MODEL RESULTS.
      DOUBLE PRECISION FAC
C        A FACTOR USED IN THE COMPUTATIONS.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      DOUBLE PRECISION J
C        THE VALUE FLOAT(I-3).
      INTEGER K
C        AN INDEX VARIABLE.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NETA
C        THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION P1
C        THE VALUE 0.1D0.
      DOUBLE PRECISION P2
C        THE VALUE 0.2D0.
      DOUBLE PRECISION PARTMP(NP)
C        MODIFIED MODEL PARAMETERS
      DOUBLE PRECISION PVTEMP(N)
C        PREDICTED VALUES
      DOUBLE PRECISION RSS(5)
C        THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J.
      DOUBLE PRECISION RSSSM
C        THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF
C        PARAMETER VALUES.
      DOUBLE PRECISION RSSSMJ
C        THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH
C        SET OF PARAMETER VALUES.
      DOUBLE PRECISION SQRTMP
C        THE SQUARE ROOT OF MACHINE PRECISION (EPSMAC).
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,P1,P2,ONE/0.0D0,0.1D0,0.2D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DETAF
C
C
      SQRTMP = SQRT(EPSMAC)
      RSSSM = ZERO
      RSSSMJ = ZERO
      DO 20 I=1,5
         J = I-3
         DO 10 K=1,NP
            PARTMP(K) = BETA(K)*(ONE+J*SQRTMP)
   10    CONTINUE
         IFLAG = 0
         CALL FUN(N,NP,M,PARTMP,XPLUSD,LDXPD,PVTEMP,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
C
         RSS(I) = PVTEMP(NROW)
C
         RSSSM = RSSSM + RSS(I)
         RSSSMJ = RSSSMJ + J*RSS(I)
   20 CONTINUE
      A = P2*RSSSM
      B = P1*RSSSMJ
      IF (RSS(3).NE.ZERO) THEN
         FAC = ONE/ABS(RSS(3))
      ELSE
         FAC = ONE
      END IF
      DO 30 I=1,5
         J = I-3
         RSS(I) = ABS((RSS(I)-(A+J*B))*FAC)
   30 CONTINUE
      ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),EPSMAC)
      NETA = INT(-LOG10(ETA))
C
      RETURN
      END
*DGETCP
      SUBROUTINE DGETCP
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,
     +   LUNRPT,IPR1,IPR2,IPR2F,IPR3)
C***BEGIN PROLOGUE  DGETCP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GET VARIOUS CONTROL PARAMETERS FROM WORK ARRAYS
C***END PROLOGUE  DGETCP
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPR1
C        THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE INITIAL SUMMARY REPORT.
      INTEGER IPR2
C        THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE ITERATION REPORTS.
      INTEGER IPR2F
C        THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS.
      INTEGER IPR3
C        THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT,
C        WHICH CONTROLS THE FINAL SUMMARY REPORT.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IPRINT
C        THE PRINT CONTROL VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXIT
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      DOUBLE PRECISION PARTOL
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION SSTOL
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TAUFAC
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
C
C
C***FIRST EXECUTABLE STATEMENT  DGETCP
C
C
C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
C  GET VALUE OF MACHINE PRECISION
C
      EPSMAC = WORK(EPSMAI)
C
C  GET TOLERANCE FOR STOPPING BASED ON PARAMETERS
C
      PARTOL = WORK(PARTLI)
C
C  GET TOLERANCE FOR STOPPING BASED ON FUNCTION VALUE
C
      SSTOL = WORK(SSTOLI)
C
C  GET FACTOR FOR TAU AT FIRST ITERATION
C
      TAUFAC = WORK(TAUFCI)
C
C  GET MAXIMUM NUMBER OF ITERATIONS
C
      MAXIT = IWORK(MAXITI)
C
C  GET PRINT CONTROL
C
      IPRINT = IWORK(IPRINI)
C
C  SET UP PRINT CONTROL VARIABLES
C
      IPR1 = MOD(IPRINT,10000)/1000
      IPR2 = MOD(IPRINT,1000)/100
      IPR2F = MOD(IPRINT,100)/10
      IPR3 = MOD(IPRINT,10)
C
C  GET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS
C
      LUNRPT = IWORK(LUNRPI)
C
      RETURN
      END
*DJCKM
      SUBROUTINE DJCKM
     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,TYPJ,ETA,TOL,EPSMAC,
     +   J,NROW,PV,D,
     +   PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
C***BEGIN PROLOGUE  DJCKM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKC,DJCKZ,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  CHECK USER-SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL
C            DERIVATIVES
C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKMN.)
C***END PROLOGUE  DJCKM
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DPVB, DPVD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL
      DOUBLE PRECISION FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISWRTB
C        THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT
C        BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSG(LMSG)
C        THE ERROR CHECKING RESULTS.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION ONE
C         THE VALUE 1.0D0.
      DOUBLE PRECISION PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
      DOUBLE PRECISION PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
      DOUBLE PRECISION PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
      DOUBLE PRECISION TOL
C        THE AGREEMENT TOLERANCE.
      DOUBLE PRECISION TYPJ
C        THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C         THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJCKM
C
C
C  CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE
C  QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES
C
      MSG(J+1) = 0
C
      IF (ISWRTB) THEN
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
C
         PARMX = MAX(ABS(BETA(J)),ABS(TYPJ))
         STP = (SQRT(ETA)*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         PVPSTP = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                 NROW,J,STP,IFLAG)
      ELSE
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
C
         PARMX = MAX(ABS(XPLUSD(NROW,J)),ABS(TYPJ))
         STP = (SQRT(ETA)*PARMX*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J))
     +         - XPLUSD(NROW,J)
         PVPSTP = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                  NROW,J,STP,IFLAG)
      END IF
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
      FD = (PVPSTP-PV)/STP
C
C  CHECK FOR DISAGREEMENT
C
      IF (ABS(FD-D).LE.TOL*ABS(D)) THEN
C
C  NUMERICAL AND ANALYTIC DERIVATIVES AGREE
C
C  CHECK IF ANALYTIC DERIVATIVE IS IDENTICALLY ZERO, INDICATING
C  THE POSSIBILITY THAT THE DERIVATIVE SHOULD BE RECHECKED AT
C  ANOTHER POINT.
C
         IF (D.EQ.ZERO) THEN
C
C  JTH ANALYTIC AND NUMERICAL DERIVATIVES BOTH ARE ZERO.
C  SET MSG FLAG ACCORDINGLY.
C
            IF (MSG(1).EQ.0) MSG(1) = 2
            MSG(J+1) = 2
         END IF
C
      ELSE
C
C  NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE
C
C  CHECK WHY
C
         IF (D.EQ.ZERO) THEN
            CALL DJCKZ(FUN,N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC,
     +                  J,NROW,PV,FD,PARMX,PVPSTP,STP,
     +                  PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
         ELSE
            CALL DJCKC(FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC,
     +                  J,NROW,PV,D,FD,PARMX,PVPSTP,STP,
     +                  PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
         END IF
      END IF
C
      RETURN
      END
*DACCES
      SUBROUTINE DACCES
     +   (N,M,NP,WORK,LWORK,IWORK,LIWORK,
     +   RNORM,TAU,ALPHA,NFEV,NJEV,INT2,OLMAVG)
C***BEGIN PROLOGUE  DACCES
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  ACCESS COMPUTED SCALARS FROM WORK ARRAYS FOR RESTART
C***END PROLOGUE  DACCES
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER INT2
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER IWORK(LIWORK)
C        THE INTEGER WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LIWORK
C        THE LENGTH OF VECTOR IWORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER LWORK
C        THE LENGTH OF VECTOR WORK.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION OLMAVG
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION WORK(LWORK)
C        THE DOUBLE PRECISION WORK SPACE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
C
C
C***FIRST EXECUTABLE STATEMENT  DACCES
C
C
C  SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
      RNORM = WORK(RNORMI)
      TAU = WORK(TAUI)
      ALPHA = WORK(ALPHAI)
      OLMAVG = WORK(OLMAVI)
C
      NFEV = IWORK(NFEVI)
      NJEV = IWORK(NJEVI)
      INT2 = IWORK(INT2I)
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SET A = ZERO
C***END PROLOGUE  DZERO
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION A(LDA,M)
C        THE ARRAY TO BE SET TO ZERO.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDA
C        THE LEADING DIMENSION OF ARRAY A.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN ARRAY A TO BE SET TO ZERO.
      INTEGER N
C        THE NUMBER OF ROWS OF DATA IN ARRAY A TO BE SET TO ZERO.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO /0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DZERO
C
C
      DO 20 J=1,M
         DO 10 I=1,N
            A(I,J) = ZERO
   10    CONTINUE
   20 CONTINUE
C
      RETURN
      END
*DEVJAC
      SUBROUTINE DEVJAC
     +   (FUN,JAC,ANAJAC,
     +   N,NP,NPP,M,BETAC,BETA,IFIXB,IFIXX,LDIFX,
     +   X,LDX,DELTA,LDDELT,XPLUSD,LDXPD,
     +   SS,TT,LDTT,EPSMAC,PV,STP,
     +   FJACB,LDFJB,ISODR,FJACX,LDFJX,W,NJEV,NFEV,IFLAG)
C***BEGIN PROLOGUE  DEVJAC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDIAGW,DJACFD,DUNPAC,DXPY,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA
C***END PROLOGUE  DEVJAC
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL ANAJAC
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS
C        ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT
C        (ANAJAC=.TRUE.).
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION BETAC(NP)
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      DOUBLE PRECISION DELTA(LDDELT,M)
C        THE ESTIMATED VALUES OF DELTA.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JFX
C        AN INDEXING VARIABLE.
      INTEGER LDDELT
C        THE LEADING DIMENSION OF ARRAY DELTA.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUES OF THE MODEL FUNCTION AT THE CURRENT
C        POINT.
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION STP(N)
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DEVJAC
C
C
C  INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA
C
      CALL DUNPAC(NP,BETAC,BETA,IFIXB)
C
C  COMPUTE XPLUSD = X + DELTA
C
      CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD)
C
C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND
C          THE JACOBIAN WRT DELTA (FJACX)
C
      IFLAG = 1
      IF (ANAJAC) THEN
         CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD,
     +            FJACB,LDFJB,ISODR,FJACX,LDFJX,IFLAG)
      ELSE
         CALL DJACFD(N,NP,M,BETA,
     +               X,LDX,DELTA,XPLUSD,LDXPD,FUN,
     +               SS,TT,LDTT,EPSMAC,PV,STP,
     +               IFIXB,FJACB,LDFJB,ISODR,
     +               IFIXX,LDIFX,FJACX,LDFJX,NFEV,IFLAG)
      END IF
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
C  INCREMENT COUNT OF NUMBER OF JACOBIAN EVALUATIONS
C
      NJEV = NJEV+1
C
C  WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS
C
      IF (ANAJAC) THEN
         JFX = 0
         IF (IFIXB(1).GE.0) THEN
            DO 10 J=1,NP
               IF (IFIXB(J).NE.0) THEN
                  JFX = JFX + 1
                  CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB,
     +                        FJACB(1,JFX),LDFJB)
               END IF
   10       CONTINUE
         ELSE
            DO 20 J=1,NP
               CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB,
     +                     FJACB(1,J),LDFJB)
   20       CONTINUE
         END IF
      ELSE
         DO 30 J=1,NPP
            CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB,
     +                  FJACB(1,J),LDFJB)
   30    CONTINUE
      END IF
C
C  WEIGHT OR ZERO THE JACOBIAN'S WRT X AS APPROPRIATE
C
      IF (ISODR) THEN
         IF (IFIXX(1,1).GE.0) THEN
C
C  CHECK FOR POSSIBLY FIXED COLUMNS OR ELEMENTS OF X
C
            IF (LDIFX.EQ.1) THEN
               DO 40 J=1,M
                  IF (IFIXX(1,J).EQ.0) THEN
C
C  ZERO JACOBIAN WRT X(I,J) FOR I=1,N
C
                     CALL DZERO(N,1,FJACX(1,J),LDFJX)
                  ELSE
C
C  WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N
C
                     CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX,
     +                           FJACX(1,J),LDFJX)
                  END IF
   40          CONTINUE
            ELSE
C
C  WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND
C  THEN ZERO APPROPRIATE ELEMENTS
C
               DO 60 J=1,M
                  CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX,
     +                        FJACX(1,J),LDFJX)
                  DO 50 I=1,N
                     IF (IFIXX(I,J).EQ.0) THEN
                        FJACX(I,J) = ZERO
                     END IF
   50             CONTINUE
   60          CONTINUE
            END IF
         ELSE
C
C  WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND J=1,M
C
            DO 70 J=1,M
               CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX,
     +                     FJACX(1,J),LDFJX)
   70       CONTINUE
         END IF
      ELSE
C
C  ZERO ALL ELEMENTS OF FJACX FOR OLS FIT
C
         CALL DZERO(N,M,FJACX,LDFJX)
      END IF
C
      RETURN
      END
*DWDS
      SUBROUTINE DWDS
     +   (N,M,W,RHO,LDRHO,T,LDT,WDT,LDWDT)
C***BEGIN PROLOGUE  DWDS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SCALE MATRIX T USING W*D, I.E., COMPUTE
C            WDT = W*D*T
C            WHERE W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUES FOR
C            DODR AND DODRC
C***END PROLOGUE  DWDS
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDT
C        THE LEADING DIMENSION OF ARRAY T.
      INTEGER LDWDT
C        THE LEADING DIMENSION OF ARRAY WDT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION T(LDT,M)
C        THE ARRAY BEING SCALED BY W*D.
      DOUBLE PRECISION TEMP
C        A TEMPORARY STORAGE LOCATION.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WDT(LDWDT,M)
C        THE RESULTS OF SCALING ARRAY T BY W*D.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DWDS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (W(1).GE.ZERO) THEN
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               DO 20 J=1,M
                  DO 10 I=1,N
                     WDT(I,J) = W(I)*RHO(I,J)*T(I,J)
   10             CONTINUE
   20          CONTINUE
            ELSE
               DO 40 J=1,M
                  DO 30 I=1,N
                     WDT(I,J) = W(I)*RHO(1,J)*T(I,J)
   30             CONTINUE
   40          CONTINUE
            END IF
         ELSE
            DO 60 J=1,M
               DO 50 I=1,N
                  WDT(I,J) = W(I)*ABS(RHO(1,1))*T(I,J)
   50          CONTINUE
   60       CONTINUE
         END IF
      ELSE
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               DO 80 J=1,M
                  DO 70 I=1,N
                     WDT(I,J) = RHO(I,J)*T(I,J)
   70             CONTINUE
   80          CONTINUE
            ELSE
               DO 100 J=1,M
                  TEMP = RHO(1,J)
                  DO 90 I=1,N
                     WDT(I,J) = TEMP*T(I,J)
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
            TEMP = ABS(RHO(1,1))
            DO 120 J=1,M
               DO 110 I=1,N
                  WDT(I,J) = TEMP*T(I,J)
  110          CONTINUE
  120       CONTINUE
         END IF
      END IF
C
      RETURN
      END
*DODLM
      SUBROUTINE DODLM
     +   (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX,
     +   W,RHO,LDRHO,SS,TT,LDTT,DDELT,
     +   ALPHA2,TAU,EPSMAC,
     +   SSS,WRK1,TFJACB,OMEGA,YT,
     +   U,QRAUX,WRK2,JPVT,
     +   S,T,NLMS,RCOND,IRANK)
C***BEGIN PROLOGUE  DODLM
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DDIAGI,DDOT,DNRM2,DODSTP
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
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
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DDOT
      DOUBLE PRECISION DNRM2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ALPHAN
C        THE NEW LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION ALPHA1
C        THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION ALPHA2
C        THE CURRENT LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION BOT
C        THE LOWER LIMIT FOR SETTING ALPHA.
      DOUBLE PRECISION DDELT(N,M)
C        THE ARRAY (W*D)**2 * DELTA.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JPVT(NP)
C        THE PIVOT VECTOR.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NLMS
C        THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION OMEGA(N)
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      DOUBLE PRECISION P001
C        THE VALUE 0.001D0
      DOUBLE PRECISION P1
C        THE VALUE 0.1D0
      DOUBLE PRECISION PHI1
C        THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C        AND THE TRUST REGION DIAMETER.
      DOUBLE PRECISION PHI2
C        THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C        AND THE TRUST REGION DIAMETER.
      DOUBLE PRECISION QRAUX(N)
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(NP)
C        THE STEP FOR THE ESTIMATED BETA'S.
      DOUBLE PRECISION SA
C        THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2).
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSS(N+N*M)
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION T(N,M)
C        THE STEP FOR THE ESTIMATED DELTA'S.
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      DOUBLE PRECISION TFJACB(N,NP)
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      DOUBLE PRECISION TOP
C        THE UPPER LIMIT FOR SETTING ALPHA.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION U(N)
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WRK1(N,M)
C        A WORK ARRAY.
      DOUBLE PRECISION WRK2(NP)
C        A WORK ARRAY.
      DOUBLE PRECISION YT(N)
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO,P001,P1 /0.0D0,0.001D0,0.1D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODLM
C
C
C  COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0)
C
      ALPHA1 = ZERO
      CALL DODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX,
     +            W,RHO,LDRHO,SS,TT,LDTT,DDELT,
     +            ALPHA1,EPSMAC,
     +            SSS,TFJACB,WRK1,OMEGA,
     +            YT,U,QRAUX,WRK2,
     +            JPVT,S,T,PHI1,IRANK,
     +            RCOND)
C
C  INITIALIZE TAU IF NECESSARY
C
      IF (TAU.LT.ZERO) THEN
         TAU = ABS(TAU)*PHI1
      END IF
C
C  CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL
C
      IF ((PHI1-TAU).LE.P1*TAU) THEN
         NLMS = 1
         ALPHA2 = ZERO
         RETURN
      END IF
C
C  FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION -
C  FIND LOCALLY CONSTRAINED OPTIMAL STEP
C
      PHI1 = PHI1 - TAU
C
C  INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA
C
      BOT = ZERO
C
      IF (NPP.GE.1) THEN
         DO 10 I=1,NPP
            SSS(I) = DDOT(N,FJACB(1,I),1,F,1)
   10    CONTINUE
         CALL DDIAGI(NPP,1,SS,NPP,SSS,NPP,SSS,NPP)
      END IF
      DO 30 J=1,M
         DO 20 I=1,N
            WRK1(I,J) = FJACX(I,J)*F(I) + DDELT(I,J)
   20    CONTINUE
   30 CONTINUE
      CALL DDIAGI(N,M,TT,LDTT,WRK1,N,SSS(1+NPP),N)
      TOP = DNRM2(NPP+N*M,SSS,1)/TAU
      IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN
         ALPHA2 = P001*TOP
      END IF
C
C  MAIN LOOP
C
      DO 40 I=1,10
C
C  COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR
C  CURRENT VALUE OF ALPHA
C
         CALL DODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX,
     +               W,RHO,LDRHO,SS,TT,LDTT,DDELT,
     +               ALPHA2,EPSMAC,
     +               SSS,TFJACB,WRK1,OMEGA,
     +               YT,U,QRAUX,WRK2,
     +               JPVT,S,T,PHI2,IRANK,
     +               RCOND)
         PHI2 = PHI2-TAU
C
C  CHECK WHETHER CURRENT STEP IS OPTIMAL
C
         IF (ABS(PHI2).LE.P1*TAU .OR.
     +      (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN
            NLMS = I+1
            RETURN
         END IF
C
C  CURRENT STEP IS NOT OPTIMAL
C
C  UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA
C
         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
C
         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
C  GET READY FOR NEXT ITERATION
C
         ALPHA1 = ALPHA2
         ALPHA2 = ALPHAN
         PHI1 = PHI2
   40 CONTINUE
C
C  SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS
C
      NLMS = 12
C
      RETURN
      END
*DPVD
      DOUBLE PRECISION FUNCTION DPVD
     +   (FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,IFLAG)
C***BEGIN PROLOGUE  DPVD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE NROW-TH FUNCTION VALUE USING
C            X(NROW,J) + DELTA(NROW,J) + STP
C***END PROLOGUE  DPVD
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUE FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE.
      DOUBLE PRECISION TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE
C        (NROW,J)TH ELEMENT OF XPLUSD IS STORED.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
C
C
C***FIRST EXECUTABLE STATEMENT  DPVD
C
C
C  COMPUTE PREDICTED VALUES
C
      TEMP = XPLUSD(NROW,J)
      XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP
      IFLAG = 0
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
      XPLUSD(NROW,J) = TEMP
C
      DPVD = PVTEMP(NROW)
C
      RETURN
      END
      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
C***BEGIN PROLOGUE  DDOT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A4
C***KEYWORDS  BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  D.P. inner product of d.p. vectors
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C     DDOT  double precision dot product (zero if N .LE. 0)
C
C     Returns the dot product of double precision DX and DY.
C     DDOT = sum for I = 0 to N-1 of  DX(LX+I*INCX) * DY(LY+I*INCY)
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DDOT
C
      DOUBLE PRECISION DX(*),DY(*)
C***FIRST EXECUTABLE STATEMENT  DDOT
      DDOT = 0.D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C         CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
         DDOT = DDOT + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
         DDOT = DDOT + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
         DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
     1   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
      RETURN
C
C         CODE FOR POSITIVE EQUAL INCREMENTS .NE.1.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          DDOT = DDOT + DX(I)*DY(I)
   70     CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DNRM2(N,DX,INCX)
C***BEGIN PROLOGUE  DNRM2
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A3B
C***KEYWORDS  BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA,
C             NORM,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Euclidean length (L2 norm) of d.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C    DNRM2  double precision result (zero if N .LE. 0)
C
C     Euclidean norm of the N-vector stored in DX() with storage
C     increment INCX .
C     If    N .LE. 0 return with result = 0.
C     If N .GE. 1 then INCX must be .GE. 1
C
C           C.L. Lawson, 1978 Jan 08
C
C     Four phase method     using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  DSQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  DSQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief outline of algorithm..
C
C     Phase 1    scans zero components.
C     move to phase 2 when a component is nonzero and .LE. CUTLO
C     move to phase 3 when a component is .GT. CUTLO
C     move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI..
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as followS..
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DNRM2
      INTEGER          NEXT
      DOUBLE PRECISION   DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE
      DATA   ZERO, ONE /0.0D0, 1.0D0/
C
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C***FIRST EXECUTABLE STATEMENT  DNRM2
      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                                                 BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = DABS(DX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = DABS(DX(I))
         GO TO 200
C
  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200
C
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI/FLOAT( N )
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J =I,NN,INCX
      IF(DABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = DSQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      DNRM2 = XMAX * DSQRT(SUM)
  300 CONTINUE
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE APPROPRIATE SCALE VALUES FOR DELTA'S ACCORDING TO
C            THE ALGORITHM GIVEN IN THE PROLOGUES FOR DODR AND DODRC
C***END PROLOGUE  DSCLD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL BIGDIF
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A
C        SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NON ZERO
C        BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION TEN
C        THE VALUE 10.0D0.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TWO
C        THE VALUE 2.0D0.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XMAX
C        THE LARGEST NON ZERO MAGNITUDE.
      DOUBLE PRECISION XMIN
C        THE SMALLEST NON ZERO MAGNITUDE.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE,TWO,TEN/0.0D0,1.0D0,2.0D0,10.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DSCLD
C
C
      DO 50 J=1,M
         XMAX = ABS(X(1,J))
         DO 10 I=2,N
            XMAX = MAX(XMAX,ABS(X(I,J)))
   10    CONTINUE
C
         IF (XMAX.EQ.ZERO) THEN
C
C  ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO
C
            DO 20 I=1,N
               TT(I,J) = ONE
   20       CONTINUE
C
         ELSE
C
C  SOME OF THE INPUT VALUES ARE NONZERO
C
            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.TWO
            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) = ONE
               END IF
   40       CONTINUE
         END IF
   50 CONTINUE
C
      RETURN
      END
*DODLMW
      SUBROUTINE DODLMW
     +   (N,M,NP,
     +   JPVTI,WRK1I,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK2I)
C***BEGIN PROLOGUE  DODLMW
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DIWINF,DWINF
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GET STARTING LOCATIONS OF WORK ARRAYS NEEDED BY SUBROUTINE
C            DODLM
C***END PROLOGUE  DODLMW
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER ALPHAI
C        THE LOCATION IN ARRAY WORK OF
C        THE LEVENBERG-MARQUARDT PARAMETER.
      INTEGER BETACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETANI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER BETASI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S.
      INTEGER DDELTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (W*D)**2 * DELTA.
      INTEGER DELTAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER DELTSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      INTEGER EPSMAI
C        THE LOCATION IN ARRAY WORK OF
C        THE VALUE OF MACHINE PRECISION.
      INTEGER FI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FJACBI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO BETA.
      INTEGER FJACXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER FNI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER FSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER INT2I
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF INTERNAL DOUBLING STEPS.
      INTEGER IPRINI
C        THE LOCATION IN ARRAY IWORK OF
C        THE PRINT CONTROL VARIABLE.
      INTEGER IRANKI
C        THE LOCATION IN ARRAY IWORK OF
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER JPVTI
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE PIVOT VECTOR.
      INTEGER LUNERI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES.
      INTEGER LUNRPI
C        THE LOCATION IN ARRAY IWORK OF
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXITI
C        THE LOCATION IN ARRAY IWORK OF
C        THE MAXIMUM NUMBER OF ITERATIONS ALLOWED.
      INTEGER MSGB
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA.
      INTEGER MSGX
C        THE STARTING LOCATION IN ARRAY IWORK OF
C        THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEVI
C        THE LOCATION IN ARRAY IWORK OF
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER OLMAVI
C        THE LOCATION IN ARRAY WORK OF
C        THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION.
      INTEGER OMEGAI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      INTEGER PARTLI
C        THE LOCATION IN ARRAY WORK OF
C        THE PARAMETER CONVERGENCE STOPPING CRITERIA.
      INTEGER QRAUXI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      INTEGER RCONDI
C        THE LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      INTEGER RNORMI
C        THE LOCATION IN ARRAY WORK OF
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      INTEGER SI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED BETA'S.
      INTEGER SSFI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE BETA'S.
      INTEGER SSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
      INTEGER SSSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      INTEGER SSTOLI
C        THE LOCATION IN ARRAY WORK OF
C        THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA.
      INTEGER STPI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      INTEGER TAUFCI
C        THE LOCATION IN ARRAY WORK OF
C        THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER.
      INTEGER TAUI
C        THE LOCATION IN ARRAY WORK OF
C        THE TRUST REGION DIAMETER.
      INTEGER TFJACI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      INTEGER TI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE STEP FOR THE ESTIMATED DELTA'S.
      INTEGER TTI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE SCALE USED FOR THE DELTA'S.
      INTEGER UI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      INTEGER WRK1I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER WRK2I
C        THE STARTING LOCATION IN ARRAY WORK OF
C        A WORK ARRAY.
      INTEGER XPLUSI
C        THE STARTING LOCATION IN ARRAY WORK OF
C        THE ARRAY X + DELTA.
      INTEGER YTI
C         THE STARTING LOCATION IN WORK OF
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
C
C
C***FIRST EXECUTABLE STATEMENT  DODLMW
C
C
C  GET STARTING LOCATIONS WITHIN INTEGER WORKSPACE
C
      CALL DIWINF
     +   (M,NP,
     +   MSGB,MSGX,JPVTI,MAXITI,IPRINI,NFEVI,NJEVI,INT2I,IRANKI,
     +   LUNERI,LUNRPI)
C
C  GET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
C
      CALL DWINF
     +   (N,M,NP,
     +   DELTAI,FI,RNORMI,PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI,
     +   FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,
     +   DELTSI,DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,
     +   TAUI,ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,STPI,
     +   RCONDI)
C
      RETURN
      END
*DEVFUN
      SUBROUTINE DEVFUN
     +   (N,NP,M,BETAC,BETA,IFIXB,FUN,
     +   X,LDX,Y,DELTA,LDDELT,XPLUSD,LDXPD,
     +   W,F,NFEV,IFLAG)
C***BEGIN PROLOGUE  DEVFUN
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DAXPY,DDIAGW,DUNPAC,DXPY
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE THE WEIGHTED EPSILON'S FOR THE CURRENT POINT
C***END PROLOGUE  DEVFUN
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION BETAC(NP)
C        THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S.
      DOUBLE PRECISION DELTA(LDDELT,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER LDDELT
C        THE LEADING DIMENSION OF ARRAY DELTA.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION NEGONE
C        THE VALUE -1.0D0.
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION Y(N)
C        THE DEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
C
C
      DATA NEGONE/-1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DEVFUN
C
C
C  INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA
C
      CALL DUNPAC(NP,BETAC,BETA,IFIXB)
C
C  COMPUTE XPLUSD = X + DELTA
C
      CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD)
C
C  EVALUATE THE PREDICTED VALUES OF THE FUNCTION FOR THE CURRENT POINT
C
      IFLAG = 1
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
C  INCREMENT COUNT OF NUMBER OF FUNCTION EVALUATIONS
C
      NFEV = NFEV + 1
C
C  COMPUTE WEIGHTED EPSILONS FOR CURRENT POINT AND STORE IN F
C
      CALL DAXPY(N,NEGONE,Y,1,F,1)
      CALL DDIAGW(N,1,W,F,N,F,N)
C
      RETURN
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  PRINT ODRPACK HEADING
C***END PROLOGUE  DODPHD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      LOGICAL HEAD
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE
C        HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.).
      INTEGER UNIT
C        THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN.
C
C
C***FIRST EXECUTABLE STATEMENT  DODPHD
C
C
      IF (HEAD) THEN
         WRITE(UNIT,1000)
         HEAD = .FALSE.
      END IF
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1000 FORMAT (///
     +   ' ****************************************************** '/
     +   ' * ODRPACK VERSION 1.3 OF 02-04-87 (DOUBLE PRECISION) * '/
     +   ' ****************************************************** '/)
      END
*DJCKZ
      SUBROUTINE DJCKZ
     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC,
     +   J,NROW,PV,FD,PARMX,PVPSTP,STP,
     +   PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
C***BEGIN PROLOGUE  DJCKZ
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
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            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO)
C***END PROLOGUE  DJCKZ
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DPVB
      DOUBLE PRECISION DPVD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION CD
C        THE CENTRAL DIFFERENCE QUOTIENT DERIVATIVE WITH
C        RESPECT TO THE JTH PARAMETER.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER.
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISWRTB
C        THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT
C        BETA (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSG(LMSG)
C        THE ERROR CHECKING RESULTS.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE TYPICAL
C        VALUE OF THAT PARAMETER.
      DOUBLE PRECISION PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
      DOUBLE PRECISION PVMSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) - STP.
      DOUBLE PRECISION PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
      DOUBLE PRECISION THREE
C        THE VALUE 3.0D0.
      DOUBLE PRECISION TWO
C        THE VALUE 2.0D0.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE,TWO,THREE/0.0D0,1.0D0,2.0D0,3.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJCKZ
C
C
C  RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP
C  SIZE OF 2*STP
C
      IF (ISWRTB) THEN
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
C
         PVMSTP = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                 NROW,J,-STP,IFLAG)
      ELSE
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
C
         PVMSTP = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                 NROW,J,-STP,IFLAG)
      END IF
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
      CD = (PVPSTP-PVMSTP)/(TWO*STP)
C
C  CHECK FOR DISAGREEMENT
C
      IF (CD.EQ.ZERO) THEN
C
C  NUMERICAL AND ANALYTIC DERIVATIVES NOW AGREE, BUT BOTH EQUAL ZERO,
C  INDICATING THAT DERIVATIVES SHOULD BE RECHECKED AT ANOTHER POINT.
C
         IF (MSG(1).EQ.0) MSG(1) = 2
         MSG(J+1) = 2
      ELSE
C
C  NUMERICAL AND ANALYTIC DERIVATIVE STILL DO NOT AGREE.
C  CHECK IF NUMERICAL DERIVATIVE IS CLOSE TO ZERO.
C
         IF (MIN(ABS(CD),ABS(FD))*PARMX.LE.
     +          ABS(PV*EPSMAC**(ONE/THREE))) THEN
C
C  NUMERICAL DERIVATIVE IS CLOSE TO ZERO
C
            IF (MSG(1).EQ.0) MSG(1) = 2
            MSG(J+1) = 3
         ELSE
C
C  NUMERICAL DERIVATIVE NOT CLOSE TO ZERO
C
            IF (MSG(1).EQ.0) MSG(1) = 2
            MSG(J+1) = 4
         END IF
      END IF
C
      RETURN
      END
*DDIAGW
      SUBROUTINE DDIAGW
     +   (N,M,W,V,LDV,WV,LDWV)
C***BEGIN PROLOGUE  DDIAGW
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SCALE THE N BY M ARRAY V BY THE DIAGONAL OBSERVATIONAL
C            ERROR WEIGHT MATRIX W AND RETURN THE RESULT IN VECTOR WV.
C            N.B.  IF THE FIRST ELEMENT OF W IS NEGATIVE, THE DEFAULT
C            WEIGHTING OF ONE FOR ALL ELEMENTS WILL BE INVOKED, I.E.,
C            THE RESULTS WILL BE "UNWEIGHTED."
C***END PROLOGUE  DDIAGW
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER LDWV
C        THE LEADING DIMENSION OF ARRAY WV.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING WEIGHTED.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
      DOUBLE PRECISION WV(LDWV,M)
C        THE WEIGHTED ARRAY.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGW
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (W(1).LT.ZERO) THEN
         DO 20 J=1,M
            DO 10 I=1,N
               WV(I,J) = V(I,J)
   10       CONTINUE
   20    CONTINUE
      ELSE
         DO 40 J=1,M
            DO 30 I=1,N
               WV(I,J) = W(I)*V(I,J)
   30       CONTINUE
   40    CONTINUE
      END IF
C
      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  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE
C            UNFIXED
C***END PROLOGUE  DUNPAC
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIX(N2)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF
C        SUBROUTINE DODR OR DODRC.)
      INTEGER N1
C        THE NUMBER OF ITEMS IN V1.
      INTEGER N2
C        THE NUMBER OF ITEMS IN V2.
      DOUBLE PRECISION V1(N2)
C        THE VECTOR OF THE UNFIXED ITEMS.
      DOUBLE PRECISION V2(N2)
C        THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE
C        ELEMENTS OF V1 ARE TO BE INSERTED.
C
C
C***FIRST EXECUTABLE STATEMENT  DUNPAC
C
C
      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
C
      RETURN
      END
*DSCLB
      SUBROUTINE DSCLB
     +   (NP,BETA,EPSMAC,SSF)
C***BEGIN PROLOGUE  DSCLB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE APPROPRIATE SCALE VALUES FOR BETA'S ACCORDING TO
C            THE ALGORITHM GIVEN IN THE PROLOGUES FOR DODR AND DODRC
C***END PROLOGUE  DSCLB
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL BIGDIF
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A
C        SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NON ZERO
C        BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.).
      DOUBLE PRECISION BMAX
C        THE LARGEST NON ZERO MAGNITUDE.
      DOUBLE PRECISION BMIN
C        THE SMALLEST NON ZERO MAGNITUDE.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      INTEGER K
C        AN INDEXING VARIABLE.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION SSF(NP)
C        THE SCALE USED FOR THE BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TWO
C        THE VALUE 2.0D0.
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE,TWO/0.0D0,1.0D0,2.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DSCLB
C
C
      BMAX = ABS(BETA(1))
      DO 10 K=2,NP
         BMAX = MAX(BMAX,ABS(BETA(K)))
   10 CONTINUE
C
      IF (BMAX.EQ.ZERO) THEN
C
C  ALL INPUT VALUES OF BETA ARE ZERO
C
         DO 20 K=1,NP
            SSF(K) = ONE
   20    CONTINUE
C
      ELSE
C
C  SOME OF THE INPUT VALUES ARE NONZERO
C
         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.TWO
         DO 40 K=1,NP
            IF (BETA(K).EQ.ZERO) THEN
               SSF(K) =  ONE/(SQRT(EPSMAC)*BMIN)
            ELSE
               IF (BIGDIF) THEN
                  SSF(K) = ONE/ABS(BETA(K))
               ELSE
                  SSF(K) = ONE/BMAX
               END IF
            END IF
   40    CONTINUE
C
      END IF
C
      RETURN
      END
*DODSTP
      SUBROUTINE DODSTP
     +   (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX,
     +   W,RHO,LDRHO,SS,TT,LDTT,DDELT,
     +   ALPHA,EPSMAC,
     +   SSS,TFJACB,VDTD,OMEGA,YT,U,QRAUX,WRK2,JPVT,
     +   S,T,PHI,IRANK,
     +   RCOND)
C***BEGIN PROLOGUE  DODSTP
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  IDAMAX,DCHEX,DDIAGS,DDOT,DIDTS,DNRM2,DQRDC,
C                    DQRSL,DROT,DROTG,DTRCO,DTRSL,DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA)
C***END PROLOGUE  DODSTP
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DDOT
      DOUBLE PRECISION DNRM2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION CO
C        THE COSINE FROM THE PLANE ROTATION.
      DOUBLE PRECISION DDELT(N,M)
C        THE ARRAY (W*D)**2 * DELTA.
      DOUBLE PRECISION DUM
C        AN DUMMY VARIABLE.
      LOGICAL ELIM
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER COLUMNS OF THE
C        JACOBIAN WRT BETA HAVE BEEN ELIMINATED (ELIM=.TRUE.) OR NOT
C        (ELIM=.FALSE.).
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IMAX
C        THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE
C        VALUE.
      INTEGER INF
C        THE RETURN CODE FROM DQRSL AND DTRSL.
      INTEGER IPVT
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER OR NOT
C        PIVOTING IS TO BE DONE.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JPVT(NP)
C        THE PIVOT VECTOR.
      INTEGER KP
C        THE RANK OF THE JACOBIAN WRT BETA.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPP
C        THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED.
      DOUBLE PRECISION OMEGA(N)
C        THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2)  WHERE
C        P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PHI
C        THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP
C        AND THE TRUST REGION DIAMETER.
      DOUBLE PRECISION QRAUX(NP)
C        THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE
C        Q-R DECOMPOSITION.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(NP)
C        THE STEP FOR THE ESTIMATED BETA'S.
      DOUBLE PRECISION SI
C        THE SINE FROM THE PLANE ROTATION.
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION SSS(N+N*M)
C        THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES.
      DOUBLE PRECISION T(N,M)
C        THE STEP FOR THE ESTIMATED DELTA'S.
      DOUBLE PRECISION TEMP
C        A TEMPORARY STORAGE LOCATION.
      DOUBLE PRECISION TFJACB(N,NP)
C        THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION U(N)
C        THE APPROXIMATE NULL VECTOR FOR TFJACB.
      DOUBLE PRECISION VDTD(N,M)
C        THE ARRAY DDELT*INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2.
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION WRK2(NP)
C        A WRK2 ARRAY.
      DOUBLE PRECISION YT(N)
C         THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2).
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODSTP
C
C
C  COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE
C
C  SET UP JPVT IF ALPHA = 0
C
      IF (ALPHA.EQ.ZERO) THEN
         KP = NPP
         DO 10 I=1,NPP
            JPVT(I) = I
   10    CONTINUE
      ELSE
         IF (NPP.GE.1) THEN
            KP = NPP-IRANK
         ELSE
            KP = NPP
         END IF
      END IF
C
C  SET UP OMEGA AND TFJACB
C  (VDTD = FJACX * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2)
C
      CALL DIDTS(N,M,W,RHO,LDRHO,ALPHA,TT,LDTT,FJACX,LDFJX,VDTD,N)
      DO 20 I=1,N
         OMEGA(I) = SQRT(ONE+DDOT(M,VDTD(I,1),N,FJACX(I,1),LDFJX))
   20 CONTINUE
      DO 40 J=1,KP
         DO 30 I=1,N
            TFJACB(I,J) = FJACB(I,JPVT(J))/OMEGA(I)
   30    CONTINUE
   40 CONTINUE
C
C  SET UP VDTD AND YT
C  (VDTD = DDELT * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2)
C
      CALL DIDTS(N,M,W,RHO,LDRHO,ALPHA,TT,LDTT,DDELT,N,VDTD,N)
      DO 50 I=1,N
         VDTD(I,1) = DDOT(M,FJACX(I,1),LDFJX,VDTD(I,1),N)
         YT(I) = -(F(I)-VDTD(I,1))/OMEGA(I)
   50 CONTINUE
C
C  COMPUTE S
C
C  DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0)
C
      IF (ALPHA.EQ.ZERO) THEN
         IPVT = 1
         DO 60 I=1,NPP
            JPVT(I) = 0
   60    CONTINUE
      ELSE
         IPVT = 0
      END IF
C
      CALL DQRDC(TFJACB,N,N,KP,QRAUX,JPVT,WRK2,IPVT)
C
C     GET TR(Q)*YT
C
      CALL DQRSL(TFJACB,N,N,KP,QRAUX,YT,DUM,YT,DUM,DUM,DUM,1000,INF)
C
C  ELIMINATE ALPHA PART USING GIVENS ROTATIONS
C
      IF (ALPHA.NE.ZERO) THEN
         CALL DZERO(NPP,1,S,NPP)
         DO 90 I=1,KP
            CALL DZERO(KP,1,WRK2,KP)
            IF (SS(1).GT.ZERO) THEN
               WRK2(I) = SQRT(ALPHA)*SS(JPVT(I))
            ELSE
               WRK2(I) = SQRT(ALPHA)*ABS(SS(1))
            END IF
            DO 80 J=I,KP
               CALL DROTG(TFJACB(J,J),WRK2(J),CO,SI)
               IF (KP-J.GE.1) THEN
                  CALL DROT(KP-J,TFJACB(J,J+1),N,WRK2(J+1),1,CO,SI)
               END IF
               TEMP = CO*YT(J) + SI*S(JPVT(I))
               S(JPVT(I)) = -SI*YT(J) + CO*S(JPVT(I))
               YT(J) = TEMP
   80       CONTINUE
   90    CONTINUE
      END IF
C
C  COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY
C
      IF (NPP.GE.1) THEN
         IF (ALPHA.EQ.ZERO) THEN
            KP = NPP
C
C  ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR
C
  100       CALL DTRCO(TFJACB,N,KP,RCOND,U,1)
            IF (RCOND.LE.SQRT(EPSMAC)) THEN
               ELIM = .TRUE.
               IMAX = IDAMAX(KP,U,1)
C
C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX JPVT
C
               IF (IMAX.NE.KP) THEN
                  CALL DCHEX(TFJACB,N,KP,IMAX,KP,YT,N,1,QRAUX,WRK2,2)
                  J = JPVT(IMAX)
                  DO 110 I=IMAX,KP-1
                     JPVT(I) = JPVT(I+1)
  110             CONTINUE
                  JPVT(KP) = J
               END IF
               KP = KP-1
            ELSE
               ELIM = .FALSE.
            END IF
            IF (ELIM .AND. KP.GE.1) THEN
               GO TO 100
            ELSE
               IRANK = NPP-KP
            END IF
         END IF
C
C  BACKSOLVE AND UNSCRAMBLE
C
         DO 120 I=KP+1,NPP
            YT(I) = ZERO
  120    CONTINUE
         IF (KP.GE.1) THEN
            CALL DTRSL(TFJACB,N,KP,YT,01,INF)
         END IF
         DO 130 I=1,NPP
            S(JPVT(I)) = YT(I)
  130    CONTINUE
      END IF
C
C  COMPUTE T
C
      DO 140 I=1,N
         TEMP = F(I)+DDOT(NPP,FJACB(I,1),LDFJB,S,1)
         U(I) = (TEMP-VDTD(I,1))/(OMEGA(I)**2)
  140 CONTINUE
      DO 160 J=1,M
         DO 150 I=1,N
            T(I,J) = -(FJACX(I,J)*U(I) + DDELT(I,J))
  150    CONTINUE
  160 CONTINUE
C
C  (T = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2)
C
      CALL DIDTS(N,M,W,RHO,LDRHO,ALPHA,TT,LDTT,T,N,T,N)
C
C  COMPUTE PHI(ALPHA) FROM SCALED S AND T
C
      IF (NPP.GE.1) THEN
         CALL DDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP)
      END IF
      CALL DDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N)
      PHI = DNRM2(NPP+N*M,SSS,1)
C
      RETURN
      END
*DPVB
      DOUBLE PRECISION FUNCTION DPVB
     +   (FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,IFLAG)
C***BEGIN PROLOGUE  DPVB
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP
C***END PROLOGUE  DPVB
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUE FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE.
      DOUBLE PRECISION TEMP
C        A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH
C        PARAMETER IS STORED.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
C
C
C***FIRST EXECUTABLE STATEMENT  DPVB
C
C
C  COMPUTE PREDICTED VALUES
C
      TEMP = BETA(J)
      BETA(J) = BETA(J) + STP
      IFLAG = 0
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
      BETA(J) = TEMP
C
      DPVB = PVTEMP(NROW)
C
      RETURN
      END
*DODPC3
      SUBROUTINE DODPC3
     +   (IPR,LUNRPT,
     +   N,M,NP,
     +   INFO,NJEV,NFEV,RCOND,IRANK,
     +   RNORM,DELWTD,FWTD,
     +   BETA,F,ISODR,DELTA)
C***BEGIN PROLOGUE  DODPC3
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DNRM2
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GENERATE FINAL SUMMARY REPORT
C***END PROLOGUE  DODPC3
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DNRM2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION DELTA(N,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION DELWTD(N,M)
C        THE WEIGHTED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      DOUBLE PRECISION F(N)
C        THE (WEIGHTED) ESTIMATED VALUES OF EPSILON.
      CHARACTER*90 FMT1
C        A CHARACTER VARIABLE USED FOR FORMATS.
      DOUBLE PRECISION FWTD(N)
C        THE WEIGHTED ESTIMATED VALUES OF EPSILON.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER INFO
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE
C        COMPUTATIONS WERE STOPPED.
      INTEGER INFO1
C        THE FIRST DIGIT OF INFO.
      INTEGER INFO2
C        THE SECOND DIGIT OF INFO.
      INTEGER INFO3
C        THE THIRD DIGIT OF INFO.
      INTEGER IPR
C        THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED.
      INTEGER IRANK
C        THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER K
C        AN INDEXING VARIABLE.
      INTEGER L
C        AN INDEXING VARIABLE.
      INTEGER LAST
C        THE LAST ROW OF THE GIVEN ARRAY TO BE PRINTED.
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MAXLST
C        THE MAXIMUM NUMBER OF ITEMS TO BE PRINTED.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NPLM1
C        THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE.
      DOUBLE PRECISION RCOND
C        THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB.
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODPC3
C
C
C  PRINT STOPPING CONDITIONS
C
      WRITE (LUNRPT,1000) INFO
      IF (INFO.LT.0) THEN
         WRITE (LUNRPT,1110)
      ELSE
         INFO1 = MOD(INFO,1000)/100
         INFO2 = MOD(INFO,100)/10
         INFO3 = MOD(INFO,10)
C
         IF (INFO3.EQ.1) THEN
            WRITE (LUNRPT,1120)
         ELSE IF (INFO3.EQ.2) THEN
            WRITE (LUNRPT,1130)
         ELSE IF (INFO3.EQ.3) THEN
            WRITE (LUNRPT,1140)
         ELSE IF (INFO3.EQ.4) THEN
            WRITE (LUNRPT,1150)
         ELSE
            WRITE (LUNRPT,1160)
         END IF
C
C  PRINT WARNING DIAGNOSTICS
C
         IF (INFO1.NE.0 .OR. INFO2.NE.0) THEN
            WRITE (LUNRPT,1210)
            IF (INFO1.NE.0) THEN
               IF (INFO2.NE.0) THEN
                  WRITE (LUNRPT,1220) ', AND'
               ELSE
                  WRITE (LUNRPT,1220) '.    '
               END IF
            END IF
            IF (INFO2.NE.0) THEN
               WRITE (LUNRPT,1230)
            END IF
         END IF
      END IF
C
C  PRINT MISC. STOPPING INFO
C
      WRITE (LUNRPT,1300) NJEV,NFEV,RCOND,IRANK
C
C  PRINT FINAL SUM OF SQUARES
C
      WRITE (LUNRPT,2000)
      WRITE (LUNRPT,2100) RNORM**2
      IF (ISODR) THEN
         WRITE (LUNRPT,2200) DNRM2(N*M,DELWTD,1)**2
         WRITE (LUNRPT,2300) DNRM2(N,FWTD,1)**2
      END IF
C
      NPLM1 = 3
C
C  PRINT ESTIMATED BETA'S
C
      WRITE (LUNRPT,3000)
      IF (NP.EQ.1) THEN
         WRITE (LUNRPT,7100)
      ELSE
         WRITE (LUNRPT,7200)
      END IF
      DO 10 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
   10 CONTINUE
C
C  PRINT ESTIMATED EPSILON'S AND DELTA'S
C
      MAXLST = 32
      IF (IPR.GE.2 .OR. N.LT.MAXLST) THEN
         LAST = N
      ELSE
         LAST = MAXLST
      END IF
C
C  PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF
C  COLUMNS OF DATA IN DELTA IS LESS THAN OR EQUAL TO THREE.
C
      IF (ISODR .AND. M.LE.3) THEN
         WRITE (LUNRPT,4100)
         WRITE (FMT1,9100) M
         WRITE (LUNRPT,FMT1) (J,J=1,M)
         DO 20 I=1,LAST
            WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M)
   20    CONTINUE
         IF (N.GT.LAST) THEN
            IF (N.LE.LAST+4) THEN
               DO 30 I=LAST+1,N
                  WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M)
   30          CONTINUE
            ELSE
               WRITE (FMT1,9200) M+1
               WRITE (LUNRPT,FMT1)
               WRITE (LUNRPT,FMT1)
               WRITE (LUNRPT,FMT1)
               WRITE (LUNRPT,4110) N,F(N),(DELTA(N,J),J=1,M)
            END IF
         END IF
      ELSE
C
C  PRINT EPSILON'S AND DELTA'S SEPARATELY
C
C  PRINT EPSILON'S
C
         WRITE (LUNRPT,4200)
         IF (LAST.EQ.1) THEN
            WRITE (LUNRPT,7100)
         ELSE
            WRITE (LUNRPT,7200)
         END IF
         DO 40 I=1,LAST,NPLM1+1
            K = MIN(I+NPLM1,LAST)
            IF (I.EQ.K) THEN
               WRITE (LUNRPT,8100) I,F(I)
            ELSE
               WRITE (LUNRPT,8200) I,K,(F(L),L=I,K)
            END IF
   40    CONTINUE
         IF (N.GT.LAST) THEN
            IF (N.EQ.LAST+1) THEN
               WRITE (LUNRPT,8100) N,F(N)
            ELSE IF (N.GT.LAST+1) THEN
               WRITE (LUNRPT,8300) N,F(N)
            END IF
         END IF
C
C  PRINT DELTA'S
C
         IF (ISODR) THEN
            DO 60 J=1,M
               WRITE (LUNRPT,4300) J
               IF (LAST.EQ.1) THEN
                  WRITE (LUNRPT,7100)
               ELSE
                  WRITE (LUNRPT,7200)
               END IF
               DO 50 I=1,LAST,NPLM1+1
                  K = MIN(I+NPLM1,LAST)
                  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
   50          CONTINUE
               IF (N.EQ.LAST+1) THEN
                  WRITE (LUNRPT,8100) N,DELTA(N,J)
               ELSE IF (N.GT.LAST+1) THEN
                  WRITE (LUNRPT,8300) N,DELTA(N,J)
               END IF
   60       CONTINUE
         END IF
      END IF
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1000 FORMAT
     +   (///' STOPPING CONDITION (INFO = ',I6,'):'/
     +       ' -----------------------------------'/)
 1110 FORMAT
     +   (   ' THE USER HAS STOPPED THE COMPUTATIONS'/
     +       ' IN USER-SUPPLIED SUBROUTINE FUN OR JAC')
 1120 FORMAT
     +   (   ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/
     +       ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL')
 1130 FORMAT
     +   (   ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/
     +       ' IS LESS THAN PARTOL')
 1140 FORMAT
     +   (   ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/
     +       ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL'/
     +       ' AND'/
     +       ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/
     +       ' IS LESS THAN PARTOL')
 1150 FORMAT
     +   (   ' MAXIMUM NUMBER OF ITERATIONS REACHED')
 1160 FORMAT
     +   (   ' ERROR.  PLEASE CHECK WITH AUTHORS.')
 1210 FORMAT
     +   (/  ' NOTE:'//
     +       ' THE RESULTS FROM ODRPACK ARE QUESTIONABLE BECAUSE'/)
 1220 FORMAT
     +   (   ' THE ODRPACK JACOBIAN MATRIX CHECKING PROCEDURE HAS  '/
     +       ' DETERMINED THAT THE CORRECTNESS OF THE USER-SUPPLIED'/
     +       ' JACOBIAN MATRICES IS QUESTIONABLE',A5/)
 1230 FORMAT
     +   (   ' THE RESULTS OF THE MODEL FUNCTION AND/OR ITS        '/
     +       ' DERIVATIVES ARE UNAFFECTED BY CHANGES IN THE UNFIXED'/
     +       ' FUNCTION PARAMETERS (BETA), INDICATING A PROBABLE   '/
     +       ' ERROR IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC.  ')
 1300 FORMAT
     +  (/'                             CONDITION            '/
     +    '       NUMBER OF  NUMBER OF     NUMBER        RANK'/
     +    '      ITERATIONS   FN EVALS  (INVERSE)  DEFICIENCY'/
     +    6X,I10,I11,D11.4,6X,I6)
 2000 FORMAT
     +   (///' FINAL SUMS OF SQUARES:'/
     +       ' ----------------------'/)
 2100 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', D17.8)
 2200 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED DELTAS               ', D17.8)
 2300 FORMAT
     +   (   ' SUM OF SQUARED WEIGHTED EPSILONS             ', D17.8)
 3000 FORMAT
     +   (///' ESTIMATED BETA(I), I = 1, ..., NP:'/
     +       ' ----------------------------------')
 4100 FORMAT
     +   (///' ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:'/
     +       ' ---------------------------------------------------')
 4110 FORMAT(1X,I5,5D16.8)
 4200 FORMAT
     +   (///' ESTIMATED EPSILON(I), I = 1, ..., N:'/
     +      ' ------------------------------------')
 4300 FORMAT
     +   (///' ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:'/
     +      ' --------------------------------------')
 7100 FORMAT
     +   (/'         INDEX            VALUE')
 7200 FORMAT
     +   (/'         INDEX            VALUE -------------->')
 8100 FORMAT
     +   (9X,I5,1X,D16.8)
 8200 FORMAT
     +   (1X,I5,' TO',I5,1X,7D16.8)
 8300 FORMAT
     +   (1X,'  ... TO',I5,1X,'      ...       ',D16.8)
 9100 FORMAT
     +   ('(/''     I      EPSILON(I)'',',I1,
     +    '(''      DELTA(I,'',I1,'')''))')
 9200 FORMAT('(5X,''.'',',I1,'(3X,''.'',12X))')
      END
*DODPC2
      SUBROUTINE DODPC2
     +   (IPR,FSTITR,LUNRPT,NP,
     +   NJEV,NFEV,RNORM,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA)
C***BEGIN PROLOGUE  DODPC2
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  GENERATE ITERATION REPORTS
C***END PROLOGUE  DODPC2
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION ACTRED
C        THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      LOGICAL FSTITR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE
C        FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.).
      CHARACTER*3 GN
C        THE CHARACTER VARIABLE USED TO INDICATE WHETHER A GAUSS-NEWTON
C        STEP WAS TAKEN.
      INTEGER IPR
C        THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER K
C        AN INDEXING VARIABLE.
      INTEGER L
C        AN INDEXING VARIABLE.
      INTEGER LUNRPT
C        THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NJEV
C        THE NUMBER OF JACOBIAN EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION PNORM
C        THE NORM OF THE SCALED ESTIMATED PARAMETERS.
      DOUBLE PRECISION PRERED
C        THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES
C        OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION RATIO
C        THE RATIO OF TAU TO PNORM.
      DOUBLE PRECISION RNORM
C        THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS.
      DOUBLE PRECISION TAU
C        THE TRUST REGION DIAMETER.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DODPC2
C
C
      IF (FSTITR) THEN
         IF (IPR.EQ.1) THEN
            WRITE (LUNRPT,1120)
         ELSE
            WRITE (LUNRPT,1130)
         END IF
      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) NJEV,NFEV,RNORM**2,ACTRED,PRERED,
     +                       RATIO,GN
      ELSE
         J = 1
         K = MIN(3,NP)
         IF (J.EQ.K) THEN
            WRITE (LUNRPT,1141) NJEV,NFEV,RNORM**2,ACTRED,PRERED,
     +                          RATIO,GN,J,BETA(J)
         ELSE
            WRITE (LUNRPT,1142) NJEV,NFEV,RNORM**2,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
C
      RETURN
C
C  FORMAT STATEMENTS
C
 1120 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'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----'/)
 1130 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'/
     +    ' ----  ------  -----------  -----------  -----------',
     +    '  ---------  ----     -----           -----'/)
 1141 FORMAT
     +   (1X,I4,I8,1X,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8)
 1142 FORMAT
     +   (1X,I4,I8,1X,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8)
 1151 FORMAT
     +   (76X,I3,D16.8)
 1152 FORMAT
     +   (70X,I3,' TO',I3,3D16.8)
      END
*DDIAGI
      SUBROUTINE DDIAGI
     +   (N,M,S,LDS,V,LDV,SV,LDSV)
C***BEGIN PROLOGUE  DDIAGI
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SCALE THE VECTOR V BY THE INVERSE OF THE DIAGONAL MATRIX S
C            AND RETURN THE RESULT IN VECTOR SV
C***END PROLOGUE  DDIAGI
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDS
C        THE LEADING DIMENSION OF ARRAY S.
      INTEGER LDSV
C        THE LEADING DIMENSION OF ARRAY SV.
      INTEGER LDV
C        THE LEADING DIMENSION OF ARRAY V.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION S(LDS,M)
C        THE SCALING ARRAY.
      DOUBLE PRECISION SV(LDSV,M)
C        THE INVERSE SCALED ARRAY.
      DOUBLE PRECISION V(LDV,M)
C        THE ARRAY BEING SCALED.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO/0.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DDIAGI
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (S(1,1).LT.ZERO) THEN
         DO 20 J=1,M
            DO 10 I = 1,N
               SV(I,J) = V(I,J)/ABS(S(1,1))
   10       CONTINUE
   20    CONTINUE
      ELSE
         IF (LDS.EQ.1) THEN
            DO 40 J=1,M
               DO 30 I=1,N
                  SV(I,J) = V(I,J)/S(1,J)
   30          CONTINUE
   40       CONTINUE
         ELSE
            DO 60 J=1,M
               DO 50 I=1,N
                  SV(I,J) = V(I,J)/S(I,J)
   50          CONTINUE
   60       CONTINUE
         END IF
      END IF
C
      RETURN
      END
*DJCKC
      SUBROUTINE DJCKC
     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC,
     +   J,NROW,PV,D,FD,PARMX,PVPSTP,STP,
     +   PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
C***BEGIN PROLOGUE  DJCKC
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DJCKF,DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE
C            DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES
C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCRV)
C***END PROLOGUE  DJCKC
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
      EXTERNAL JAC
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT JAC.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DPVB
      DOUBLE PRECISION DPVD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION CURVE
C        A MEASURE OF THE CURVATURE IN THE MODEL.
      DOUBLE PRECISION D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL.
      DOUBLE PRECISION FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER.
      DOUBLE PRECISION FIVE
C         THE VALUE 5.0D0.
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISWRTB
C        THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT
C        BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSG(LMSG)
C        THE ERROR CHECKING RESULTS.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION ONE
C         THE VALUE 1.0D0.
      DOUBLE PRECISION PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE.
      DOUBLE PRECISION PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
      DOUBLE PRECISION PVMCRV
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV.
      DOUBLE PRECISION PVPCRV
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV.
      DOUBLE PRECISION PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
      DOUBLE PRECISION STPCRV
C        THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL.
      DOUBLE PRECISION THIRD
C        THE VALUE 1.0D0/3.0D0.
      DOUBLE PRECISION THREE
C         THE VALUE 3.0D0.
      DOUBLE PRECISION TOL
C        THE AGREEMENT TOLERANCE.
      DOUBLE PRECISION TWO
C         THE VALUE 2.0D0.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C         THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE,TWO,THREE,FIVE/0.0D0,1.0D0,2.0D0,3.0D0,5.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJCKC
C
C
      THIRD = ONE/THREE
C
      IF (ISWRTB) THEN
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
C
         STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
         PVPCRV = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                  NROW,J,STPCRV,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
         PVMCRV = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                  NROW,J,-STPCRV,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
      ELSE
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
C
         STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,XPLUSD(NROW,J))+
     +             XPLUSD(NROW,J)) - XPLUSD(NROW,J)
         PVPCRV = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                 NROW,J,STPCRV,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
         PVMCRV = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                 NROW,J,-STPCRV,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
      END IF
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
C
C  ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL
C
      CURVE = ((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV)
      CURVE = CURVE + (ETA ** THIRD) * (ABS(PVPCRV) +
     +        ABS(PVMCRV) + TWO * ABS(PV)) / (PARMX * PARMX)
C
C  COMPARE NUMERICAL AND ANALYTICAL DERIVATIVES USING A FUDGE
C  FACTOR OF TEN.
C
      IF (ABS(CURVE*STP)*FIVE.LT.ABS(FD-D)) THEN
C
C  CURVATURE CANNOT ACCOUNT FOR DISCREPANCY.
C
C  CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT.
C
         CALL DJCKF(FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,
     +              J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE,
     +              PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
C
      ELSE
C
C  HIGH CURVATURE COULD BE THE PROBLEM.  TRY A SMALLER STEP SIZE.
C
C  COMPUTE DERIVATIVE WITH SMALLER STEP SIZE
C  IF SMALLER STEP SIZE IS TOO SMALL SET MSG(J+1)=1 ELSE COMPUTE
C  PREDICTED VALUE WITH NEW STEP.
C
         IF (ISWRTB) THEN
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
C
            STP = (TWO*TOL*ABS(D)*SIGN(ONE,BETA(J)) /
     +             ABS(CURVE)+BETA(J)) - BETA(J)
            IF (ABS(STP).LE.EPSMAC*ABS(BETA(J))) THEN
               IF (MSG(1).EQ.0) MSG(1) = 2
               MSG(J+1) = 6
               RETURN
            ELSE
               PVPSTP = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                       NROW,J,STP,IFLAG)
               IF (IFLAG.LT.0) THEN
                  RETURN
               END IF
            END IF
         ELSE
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
C
            STP = (TWO*TOL*ABS(D)*SIGN(ONE,XPLUSD(NROW,J)) /
     +             ABS(CURVE)+XPLUSD(NROW,J)) - XPLUSD(NROW,J)
            IF (ABS(STP).LE.EPSMAC*ABS(XPLUSD(NROW,J))) THEN
               IF (MSG(1).EQ.0) MSG(1) = 2
               MSG(J+1) = 6
               RETURN
            ELSE
               PVPSTP = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                       NROW,J,STP,IFLAG)
               IF (IFLAG.LT.0) THEN
                  RETURN
               END IF
            END IF
         END IF
C
C  COMPUTE THE NEW NUMERICAL DERIVATIVE
C
         FD = (PVPSTP-PV)/STP
C
C  CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK
C
         IF (ABS(FD-D).GT.TWO*TOL*ABS(D)) THEN
C
C  NUMERICAL DERIVATIVE COMPUTED USING NEW STEP SIZE DOES
C  NOT AGREE WITH ANALYTIC DERIVATIVE.
C
C  CHECK IF THE PROBLEM COULD BE THE FORWARD DIFFERENCE QUOTIENT
C  DERIVATIVE.
C
C  (FUDGE FACTOR IS 2)
C
            IF (ABS(STP*(FD-D)).GE.TWO*ETA*ABS(PV+PVPSTP)) THEN
C
C  FINITE PRECISION COULD NOT BE THE CULPRIT
C
               MSG(1) = 1
               MSG(J+1) = 1
            ELSE
C
C  FINITE PRECISION MAY BE THE CULPRIT
C
               IF (MSG(1).EQ.0) MSG(1) = 2
               MSG(J+1) = 6
            END IF
         END IF
      END IF
C
      RETURN
      END
*DJACFD
      SUBROUTINE DJACFD
     +   (N,NP,M,BETA,
     +   X,LDX,DELTA,XPLUSD,LDXPD,FUN,
     +   SS,TT,LDTT,EPSMAC,PV,STP,
     +   IFIXB,FJACB,LDFJB,ISODR,
     +   IFIXX,LDIFX,FJACX,LDFJX,NFEV,IFLAG)
C***BEGIN PROLOGUE  DJACFD
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DZERO
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  COMPUTE FINITE DIFFERENCE APPROXIMATIONS TO THE
C            JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS
C***END PROLOGUE  DJACFD
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
      DOUBLE PRECISION BETAJ
C        THE J-TH FUNCTION PARAMETER.
      DOUBLE PRECISION DELTA(N,M)
C        THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES.
      LOGICAL DOIT
C        THE INDICATOR VARIABLE USED TO SPECIFY WHETHER THE DERIVATIVE
C        WRT A GIVEN BETA OR X NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT
C        (DOIT=FALSE).
      DOUBLE PRECISION EPSMAC
C        THE VALUE OF MACHINE PRECISION.
      DOUBLE PRECISION FJACB(LDFJB,NP)
C        THE JACOBIAN WITH RESPECT TO BETA.
      DOUBLE PRECISION FJACX(LDFJX,M)
C        THE JACOBIAN WITH RESPECT TO X.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER IFIXB(NP)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFIXX(LDIFX,M)
C        THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL
C        ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISODR
C        THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION
C        IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.).
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER JFX
C        AN INDEXING VARIABLE.
      INTEGER LDFJB
C        THE LEADING DIMENSION OF ARRAY FJACB.
      INTEGER LDFJX
C        THE LEADING DIMENSION OF ARRAY FJACX.
      INTEGER LDIFX
C        THE LEADING DIMENSION OF ARRAY IFIXX.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER LDX
C        THE LEADING DIMENSION OF ARRAY X.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NFEV
C        THE NUMBER OF FUNCTION EVALUATIONS.
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PV(N)
C        THE PREDICTED VALUES OF THE MODEL FUNCTION AT THE CURRENT
C        POINT.
      DOUBLE PRECISION SQREPS
C        THE SQUARE ROOT OF MACHINE PRECISION.
      DOUBLE PRECISION SS(NP)
C        THE SCALE USED FOR THE ESTIMATED BETA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION STP(N)
C        THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES.
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION TYPJ
C        THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA.
      DOUBLE PRECISION X(LDX,M)
C        THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
      DOUBLE PRECISION ZERO
C          THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJACFD
C
C
C  SET THE RELATIVE STEP SIZE FOR COMPUTING THE JACOBIANS
C
      SQREPS = SQRT(EPSMAC)
C
C  COMPUTE THE PREDICTED VALUES OF THE FUNCTION AT THE GIVEN POINT
C
      CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PV,IFLAG)
      IF (IFLAG.LT.0) THEN
         RETURN
      END IF
      NFEV = NFEV + 1
C
C  COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS
C
      JFX = 0
      DO 20 J=1,NP
         IF (IFIXB(1).GE.0) THEN
            IF (IFIXB(J).EQ.0) THEN
               DOIT = .FALSE.
            ELSE
               DOIT = .TRUE.
            END IF
         ELSE
            DOIT = .TRUE.
         END IF
         IF (DOIT) THEN
            JFX = JFX + 1
            BETAJ = BETA(J)
            IF (SS(1).GT.ZERO) THEN
               TYPJ = ONE/SS(JFX)
            ELSE
               TYPJ = ONE/ABS(SS(1))
            END IF
            STP(J) = BETAJ + SQREPS*SIGN(ONE,BETAJ)*MAX(ABS(BETAJ),TYPJ)
            STP(J) = STP(J) - BETAJ
            BETA(J) = BETAJ + STP(J)
            CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACB(1,JFX),IFLAG)
            IF (IFLAG.LT.0) THEN
               RETURN
            END IF
            NFEV = NFEV + 1
            DO 10 I=1,N
               FJACB(I,JFX) = (FJACB(I,JFX)-PV(I))/STP(J)
   10       CONTINUE
            BETA(J) = BETAJ
         END IF
   20 CONTINUE
C
C  COMPUTE THE JACOBIAN WRT THE X'S
C
      IF (ISODR) THEN
         DO 50 J=1,M
            IF (IFIXX(1,1).GE.0) THEN
               IF (LDIFX.EQ.1) THEN
                  IF (IFIXX(1,J).EQ.0) THEN
                     DOIT = .FALSE.
                  ELSE
                     DOIT = .TRUE.
                  END IF
               ELSE
                  DOIT = .TRUE.
               END IF
            ELSE
               DOIT = .TRUE.
            END IF
            IF (.NOT.DOIT) THEN
               CALL DZERO(N,1,FJACX(1,J),N)
            ELSE
               DO 30 I=1,N
                  IF (TT(1,1).GT.ZERO) THEN
                     IF (LDTT.EQ.1) THEN
                        TYPJ = ONE/TT(1,J)
                     ELSE
                        TYPJ = ONE/TT(I,J)
                     END IF
                  ELSE
                     TYPJ = ABS(ONE/TT(1,1))
                  END IF
                  STP(I) = XPLUSD(I,J) + SQREPS*SIGN(ONE,XPLUSD(I,J))*
     +                     MAX(ABS(XPLUSD(I,J)),TYPJ)
                  STP(I) = STP(I) - XPLUSD(I,J)
                  XPLUSD(I,J) = XPLUSD(I,J) + STP(I)
   30          CONTINUE
               CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACX(1,J),IFLAG)
               IF (IFLAG.LT.0) THEN
                  RETURN
               END IF
               NFEV = NFEV + 1
               DO 40 I=1,N
                  FJACX(I,J) = (FJACX(I,J)-PV(I))/STP(I)
                  XPLUSD(I,J) = X(I,J) + DELTA(I,J)
   40          CONTINUE
            END IF
   50    CONTINUE
      END IF
C
      RETURN
      END
*DIDTS
      SUBROUTINE DIDTS
     +   (N,M,W,RHO,LDRHO,ALPHA,TT,LDTT,T,LDT,DTT,LDDTT)
C***BEGIN PROLOGUE  DIDTS
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  (NONE)
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  SCALE MATRIX TT BY THE INVERSE OF DT, I.E., COMPUTE
C            DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2,
C            W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUE OF DODR
C            AND DODRC, AND TT IS THE SCALING MATRIX FOR THE DELTA'S,
C            ALSO DEFINED IN THE PROLOGUE OF DODR AND DODRC.
C***END PROLOGUE  DIDTS
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
C  N.B.  THE LOCATIONS OF W, RHO AND TT ACCESSED DEPEND ON THE VALUE
C        OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSION
C        OF THE DOUBLY SUBSCRIPTED ARRAYS.
C
      DOUBLE PRECISION ALPHA
C        THE LEVENBERG-MARQUARDT PARAMETER.
      DOUBLE PRECISION DT
C        THE VALUE OF THE FACTOR DT = INV((W*D)**2+ALPHA*TT**2)
      DOUBLE PRECISION DTT(LDDTT,M)
C        THE ARRAY DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2.
      INTEGER I
C        AN INDEXING VARIABLE.
      INTEGER J
C        AN INDEXING VARIABLE.
      INTEGER LDDTT
C        THE LEADING DIMENSION OF ARRAY DTT.
      INTEGER LDRHO
C        THE LEADING DIMENSION OF ARRAY RHO.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER LDT
C        THE LEADING DIMENSION OF ARRAY T.
      INTEGER LDTT
C        THE LEADING DIMENSION OF ARRAY TT.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION RHO(LDRHO,M)
C        THE DELTA WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION T(LDT,M)
C        THE STEP FOR THE ESTIMATED DELTA'S.
      DOUBLE PRECISION TERM1
C        THE VALUE OF THE TERM (W(I)*RHO(I,J))**2
      DOUBLE PRECISION TERM2
C        THE VALUE OF THE TERM ALPHA*TT(I,J)**2
      DOUBLE PRECISION TT(LDTT,M)
C        THE SCALE USED FOR THE DELTA'S.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION W(N)
C        THE OBSERVATIONAL ERROR WEIGHTS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION ZERO
C        THE VALUE 0.0D0.
C
C
      DATA ZERO,ONE/0.0D0,1.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DIDTS
C
C
      IF (N.EQ.0 .OR. M.EQ.0) RETURN
C
      IF (W(1).GE.ZERO) THEN
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               IF (TT(1,1).GT.ZERO) THEN
                  IF (LDTT.GE.N) THEN
                     DO 1120 J=1,M
                        DO 1110 I=1,N
                           IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                              DTT(I,J) = T(I,J)/
     +                                   ((W(I)*RHO(I,J))**2 +
     +                                   ALPHA*TT(I,J)**2)
                           ELSE
                              DTT(I,J) = ZERO
                           END IF
 1110                   CONTINUE
 1120                CONTINUE
                  ELSE
                     DO 1140 J=1,M
                        TERM2 = ALPHA*TT(1,J)**2
                        DO 1130 I=1,N
                           IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                              DTT(I,J) = T(I,J)/
     +                                   ((W(I)*RHO(I,J))**2+TERM2)
                           ELSE
                              DTT(I,J) = ZERO
                           END IF
 1130                   CONTINUE
 1140                CONTINUE
                  END IF
               ELSE
                  TERM2 = ALPHA*TT(1,1)**2
                  DO 1160 J=1,M
                     DO 1150 I=1,N
                        IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                           DTT(I,J) = T(I,J)/((W(I)*RHO(I,J))**2+TERM2)
                        ELSE
                           DTT(I,J) = ZERO
                        END IF
 1150                CONTINUE
 1160             CONTINUE
               END IF
            ELSE
               IF (TT(1,1).GT.ZERO) THEN
                  IF (LDTT.GE.N) THEN
                     DO 1220 J=1,M
                        DO 1210 I=1,N
                           IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                              DTT(I,J) = T(I,J)/
     +                                   ((W(I)*RHO(1,J))**2 +
     +                                   ALPHA*TT(I,J)**2)
                           ELSE
                              DTT(I,J) = ZERO
                           END IF
 1210                   CONTINUE
 1220                CONTINUE
                  ELSE
                     DO 1240 J=1,M
                        TERM2 = ALPHA*TT(1,J)**2
                        DO 1230 I=1,N
                           IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                              DTT(I,J) = T(I,J)/
     +                                   ((W(I)*RHO(1,J))**2+TERM2)
                           ELSE
                              DTT(I,J) = ZERO
                           END IF
 1230                   CONTINUE
 1240                CONTINUE
                  END IF
               ELSE
                  TERM2 = ALPHA*TT(1,1)**2
                  DO 1260 J=1,M
                     DO 1250 I=1,N
                        IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                           DTT(I,J) = T(I,J)/((W(I)*RHO(1,J))**2+TERM2)
                        ELSE
                           DTT(I,J) = ZERO
                        END IF
 1250                CONTINUE
 1260             CONTINUE
               END IF
            END IF
         ELSE
            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  DO 1320 J=1,M
                     DO 1310 I=1,N
                        IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                           DTT(I,J) = T(I,J)/
     +                                ((W(I)*RHO(1,1))**2 +
     +                                ALPHA*TT(I,J)**2)
                        ELSE
                           DTT(I,J) = ZERO
                        END IF
 1310                CONTINUE
 1320             CONTINUE
               ELSE
                  DO 1340 J=1,M
                     TERM2 = ALPHA*TT(1,J)**2
                     DO 1330 I=1,N
                        IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                           DTT(I,J) = T(I,J)/((W(I)*RHO(1,1))**2+TERM2)
                        ELSE
                           DTT(I,J) = ZERO
                        END IF
 1330                CONTINUE
 1340             CONTINUE
               END IF
            ELSE
               TERM2 = ALPHA*TT(1,1)**2
               DO 1360 J=1,M
                  DO 1350 I=1,N
                     IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN
                        DTT(I,J) = T(I,J)/((W(I)*RHO(1,1))**2+TERM2)
                     ELSE
                        DTT(I,J) = ZERO
                     END IF
 1350             CONTINUE
 1360          CONTINUE
            END IF
         END IF
      ELSE
         IF (RHO(1,1).GT.ZERO) THEN
            IF (LDRHO.GE.N) THEN
               IF (TT(1,1).GT.ZERO) THEN
                  IF (LDTT.GE.N) THEN
                     DO 2120 J=1,M
                        DO 2110 I=1,N
                           DTT(I,J) = T(I,J)/
     +                                (RHO(I,J)**2 + ALPHA*TT(I,J)**2)
 2110                   CONTINUE
 2120                CONTINUE
                  ELSE
                     DO 2140 J=1,M
                        TERM2 = ALPHA*TT(1,J)**2
                        DO 2130 I=1,N
                           DTT(I,J) = T(I,J)/(RHO(I,J)**2+TERM2)
 2130                   CONTINUE
 2140                CONTINUE
                  END IF
               ELSE
                  TERM2 = ALPHA*TT(1,1)**2
                  DO 2160 J=1,M
                     DO 2150 I=1,N
                        DTT(I,J) = T(I,J)/(RHO(I,J)**2+TERM2)
 2150                CONTINUE
 2160             CONTINUE
               END IF
            ELSE
               IF (TT(1,1).GT.ZERO) THEN
                  IF (LDTT.GE.N) THEN
                     DO 2220 J=1,M
                        TERM1 = RHO(1,J)**2
                        DO 2210 I=1,N
                           DTT(I,J) = T(I,J)/(TERM1+ALPHA*TT(I,J)**2)
 2210                   CONTINUE
 2220                CONTINUE
                  ELSE
                     DO 2240 J=1,M
                        DT = ONE/(RHO(1,J)**2+ALPHA*TT(1,J)**2)
                        DO 2230 I=1,N
                           DTT(I,J) = T(I,J)*DT
 2230                   CONTINUE
 2240                CONTINUE
                  END IF
               ELSE
                  TERM2 = ALPHA*TT(1,1)**2
                  DO 2260 J=1,M
                     TERM1 = RHO(1,J)**2
                     DT = ONE/(TERM1+TERM2)
                     DO 2250 I=1,N
                        DTT(I,J) = T(I,J)*DT
 2250                CONTINUE
 2260             CONTINUE
               END IF
            END IF
         ELSE
            IF (TT(1,1).GT.ZERO) THEN
               IF (LDTT.GE.N) THEN
                  TERM1 = RHO(1,1)**2
                  DO 2320 J=1,M
                     DO 2310 I=1,N
                        DTT(I,J) = T(I,J)/(TERM1 + ALPHA*TT(I,J)**2)
 2310                CONTINUE
 2320             CONTINUE
               ELSE
                  TERM1 = RHO(1,1)**2
                  DO 2340 J=1,M
                     TERM2 = ALPHA*TT(1,J)**2
                     DT = ONE/(TERM1+TERM2)
                     DO 2330 I=1,N
                        DTT(I,J) = T(I,J)*DT
 2330                CONTINUE
 2340             CONTINUE
               END IF
            ELSE
               DT = ONE/(RHO(1,1)**2+ALPHA*TT(1,1)**2)
               DO 2360 J=1,M
                  DO 2350 I=1,N
                     DTT(I,J) = T(I,J)*DT
 2350             CONTINUE
 2360          CONTINUE
            END IF
         END IF
      END IF
C
      RETURN
      END
      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
C***BEGIN PROLOGUE  DAXPY
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A7
C***KEYWORDS  BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  D.P computation y = a*x + y
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DA  double precision scalar multiplier
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DY  double precision result (unchanged if N .LE. 0)
C
C     Overwrite double precision DY with double precision DA*DX + DY.
C     For I = 0 to N-1, replace  DY(LY+I*INCY) with DA*DX(LX+I*INCX) +
C       DY(LY+I*INCY), where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N
C       and LY is defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DAXPY
C
      DOUBLE PRECISION DX(*),DY(*),DA
C***FIRST EXECUTABLE STATEMENT  DAXPY
      IF(N.LE.0.OR.DA.EQ.0.D0) RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C        CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DY(IY) + DA*DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C        CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4.
C
   20 M = MOD(N,4)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DY(I) + DA*DX(I)
   30 CONTINUE
      IF( N .LT. 4 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        DY(I) = DY(I) + DA*DX(I)
        DY(I + 1) = DY(I + 1) + DA*DX(I + 1)
        DY(I + 2) = DY(I + 2) + DA*DX(I + 2)
        DY(I + 3) = DY(I + 3) + DA*DX(I + 3)
   50 CONTINUE
      RETURN
C
C        CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
   60 CONTINUE
      NS = N*INCX
          DO 70 I=1,NS,INCX
          DY(I) = DA*DX(I) + DY(I)
   70     CONTINUE
      RETURN
      END
      SUBROUTINE DROTG(DA,DB,DC,DS)
C***BEGIN PROLOGUE  DROTG
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  D1B10
C***KEYWORDS  BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Construct d.p. plane Givens rotation
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C       DA  double precision scalar
C       DB  double precision scalar
C
C     --Output--
C       DA  double precision result R
C       DB  double precision result Z
C       DC  double precision result
C       DS  double precision result
C
C     Designed by C. L. Lawson, JPL, 1977 Sept 08
C
C
C     Construct the Givens transformation
C
C         ( DC  DS )
C     G = (        ) ,    DC**2 + DS**2 = 1 ,
C         (-DS  DC )
C
C     which zeros the second entry of the 2-vector  (DA,DB)**T .
C
C     The quantity R = (+/-)DSQRT(DA**2 + DB**2) overwrites DA in
C     storage.  The value of DB is overwritten by a value Z which
C     allows DC and DS to be recovered by the following algorithm.
C
C           If Z=1  set  DC=0.D0  and  DS=1.D0
C           If DABS(Z) .LT. 1  set  DC=DSQRT(1-Z**2)  and  DS=Z
C           If DABS(Z) .GT. 1  set  DC=1/Z  and  DS=DSQRT(1-DC**2)
C
C     Normally, the subprogram DROT(N,DX,INCX,DY,INCY,DC,DS) will
C     next be called to apply the transformation to a 2 by N matrix.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DROTG
C
      DOUBLE PRECISION  DA, DB, DC, DS, U, V, R
C***FIRST EXECUTABLE STATEMENT  DROTG
      IF (DABS(DA) .LE. DABS(DB)) GO TO 10
C
C *** HERE DABS(DA) .GT. DABS(DB) ***
C
      U = DA + DA
      V = DB / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF DA
C
      R = DSQRT(.25D0 + V**2) * U
C
C     NOTE THAT DC IS POSITIVE
C
      DC = DA / R
      DS = V * (DC + DC)
      DB = DS
      DA = R
      RETURN
C
C *** HERE DABS(DA) .LE. DABS(DB) ***
C
   10 IF (DB .EQ. 0.D0) GO TO 20
      U = DB + DB
      V = DA / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF DB
C     (R IS IMMEDIATELY STORED IN DA)
C
      DA = DSQRT(.25D0 + V**2) * U
C
C     NOTE THAT DS IS POSITIVE
C
      DS = DB / DA
      DC = V * (DS + DS)
      IF (DC .EQ. 0.D0) GO TO 15
      DB = 1.D0 / DC
      RETURN
   15 DB = 1.D0
      RETURN
C
C *** HERE DA = DB = 0.D0 ***
C
   20 DC = 1.D0
      DS = 0.D0
      RETURN
C
      END
      SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS)
C***BEGIN PROLOGUE  DROT
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A8
C***KEYWORDS  BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  APPLY d.p. Givens rotation
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C       DC  D.P. element of rotation matrix
C       DS  D.P. element of rotation matrix
C
C     --Output--
C       DX  rotated vector (unchanged if N .LE. 0)
C       DY  rotated vector (unchanged if N .LE. 0)
C
C     Multiply the 2 X 2 matrix  ( DC DS) times the 2 X N matrix (DX**T)
C                                (-DS DC)                        (DY**T)
C     where **T indicates transpose.  The elements of DX are in
C     DX(LX+I*INCX), I = 0 to N-1, where LX = 1 if INCX .GE. 0, else
C     LX = (-INCX)*N, and similarly for DY using LY and INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DROT
C
      DOUBLE PRECISION DX,DY,DC,DS,ZERO,ONE,W,Z
      DIMENSION DX(*),DY(*)
      DATA ZERO,ONE/0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  DROT
      IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40
      IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20
C
           NSTEPS=INCX*N
           DO 10 I=1,NSTEPS,INCX
                W=DX(I)
                Z=DY(I)
                DX(I)=DC*W+DS*Z
                DY(I)=-DS*W+DC*Z
   10           CONTINUE
           GO TO 40
C
   20 CONTINUE
           KX=1
           KY=1
C
           IF(INCX .LT. 0) KX=1-(N-1)*INCX
           IF(INCY .LT. 0) KY=1-(N-1)*INCY
C
           DO 30 I=1,N
                W=DX(KX)
                Z=DY(KY)
                DX(KX)=DC*W+DS*Z
                DY(KY)=-DS*W+DC*Z
                KX=KX+INCX
                KY=KY+INCY
   30           CONTINUE
   40 CONTINUE
C
      RETURN
      END
      INTEGER FUNCTION IDAMAX(N,DX,INCX)
C***BEGIN PROLOGUE  IDAMAX
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A2
C***KEYWORDS  BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT,
C             VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Find largest component of d.p. vector
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C   IDAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of double precision DX.
C     IDAMAX =  first I, I = 1 to N, to minimize  ABS(DX(1-INCX+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  IDAMAX
C
      DOUBLE PRECISION DX(*),DMAX,XMAG
C***FIRST EXECUTABLE STATEMENT  IDAMAX
      IDAMAX = 0
      IF(N.LE.0) RETURN
      IDAMAX = 1
      IF(N.LE.1)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      DMAX = DABS(DX(1))
      NS = N*INCX
      II = 1
          DO 10 I = 1,NS,INCX
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 5
          IDAMAX = II
          DMAX = XMAG
    5     II = II + 1
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
   20 DMAX = DABS(DX(1))
      DO 30 I = 2,N
          XMAG = DABS(DX(I))
          IF(XMAG.LE.DMAX) GO TO 30
          IDAMAX = I
          DMAX = XMAG
   30 CONTINUE
      RETURN
      END
      SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO)
C***BEGIN PROLOGUE  DTRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  D2A3
C***KEYWORDS  DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,
C             TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Solves systems of the form  T*X=B or  TRANS(T)*X=B  where T
C            is a TRIANGULAR matrix of order N.
C***DESCRIPTION
C
C     DTRSL solves systems of the form
C
C                   T * X = B
C     or
C                   TRANS(T) * X = B
C
C     where T is a triangular matrix of order N.  Here TRANS(T)
C     denotes the transpose of the matrix T.
C
C     On Entry
C
C         T         DOUBLE PRECISION(LDT,N)
C                   T contains the matrix of the system.  The zero
C                   elements of the matrix are not referenced, and
C                   the corresponding elements of the array can be
C                   used to store other information.
C
C         LDT       INTEGER
C                   LDT is the leading dimension of the array T.
C
C         N         INTEGER
C                   N is the order of the system.
C
C         B         DOUBLE PRECISION(N).
C                   B contains the right hand side of the system.
C
C         JOB       INTEGER
C                   JOB specifies what kind of system is to be solved.
C                   If JOB is
C
C                        00   solve T*X=B, T lower triangular,
C                        01   solve T*X=B, T upper triangular,
C                        10   solve TRANS(T)*X=B, T lower triangular,
C                        11   solve TRANS(T)*X=B, T upper triangular.
C
C     On Return
C
C         B         B contains the solution, if INFO .EQ. 0.
C                   Otherwise B is unaltered.
C
C         INFO      INTEGER
C                   INFO contains zero if the system is nonsingular.
C                   Otherwise INFO contains the index of
C                   the first zero diagonal element of T.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS DAXPY,DDOT
C     Fortran MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DDOT
C***END PROLOGUE  DTRSL
      INTEGER LDT,N,JOB,INFO
      DOUBLE PRECISION T(LDT,*),B(*)
C
C
      DOUBLE PRECISION DDOT,TEMP
      INTEGER CASE,J,JJ
C
C     BEGIN BLOCK PERMITTING ...EXITS TO 150
C
C        CHECK FOR ZERO DIAGONAL ELEMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DTRSL
         DO 10 INFO = 1, N
C     ......EXIT
            IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150
   10    CONTINUE
         INFO = 0
C
C        DETERMINE THE TASK AND GO TO IT.
C
         CASE = 1
         IF (MOD(JOB,10) .NE. 0) CASE = 2
         IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2
         GO TO (20,50,80,110), CASE
C
C        SOLVE T*X=B FOR T LOWER TRIANGULAR
C
   20    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 40
            DO 30 J = 2, N
               TEMP = -B(J-1)
               CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1)
               B(J) = B(J)/T(J,J)
   30       CONTINUE
   40       CONTINUE
         GO TO 140
C
C        SOLVE T*X=B FOR T UPPER TRIANGULAR.
C
   50    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 70
            DO 60 JJ = 2, N
               J = N - JJ + 1
               TEMP = -B(J+1)
               CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1)
               B(J) = B(J)/T(J,J)
   60       CONTINUE
   70       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR.
C
   80    CONTINUE
            B(N) = B(N)/T(N,N)
            IF (N .LT. 2) GO TO 100
            DO 90 JJ = 2, N
               J = N - JJ + 1
               B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1)
               B(J) = B(J)/T(J,J)
   90       CONTINUE
  100       CONTINUE
         GO TO 140
C
C        SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR.
C
  110    CONTINUE
            B(1) = B(1)/T(1,1)
            IF (N .LT. 2) GO TO 130
            DO 120 J = 2, N
               B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1)
               B(J) = B(J)/T(J,J)
  120       CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
      RETURN
      END
      SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO)
C***BEGIN PROLOGUE  DQRSL
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  D9,D2A1
C***KEYWORDS  DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,
C             ORTHOGONAL TRIANGULAR,SOLVE
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Applies the output of DQRDC to compute coordinate
C            transformations, projections, and least squares solutions.
C***DESCRIPTION
C
C     DQRSL applies the output of DQRDC to compute coordinate
C     transformations, projections, and least squares solutions.
C     For K .LE. MIN(N,P), let XK be the matrix
C
C            XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K)))
C
C     formed from columnns JPVT(1), ... ,JPVT(K) of the original
C     N X P matrix X that was input to DQRDC (if no pivoting was
C     done, XK consists of the first K columns of X in their
C     original order).  DQRDC produces a factored orthogonal matrix Q
C     and an upper triangular matrix R such that
C
C              XK = Q * (R)
C                       (0)
C
C     This information is contained in coded form in the arrays
C     X and QRAUX.
C
C     On Entry
C
C        X      DOUBLE PRECISION(LDX,P).
C               X contains the output of DQRDC.
C
C        LDX    INTEGER.
C               LDX is the leading dimension of the array X.
C
C        N      INTEGER.
C               N is the number of rows of the matrix XK.  It must
C               have the same value as N in DQRDC.
C
C        K      INTEGER.
C               K is the number of columns of the matrix XK.  K
C               must not be greater than MIN(N,P), where P is the
C               same as in the calling sequence to DQRDC.
C
C        QRAUX  DOUBLE PRECISION(P).
C               QRAUX contains the auxiliary output from DQRDC.
C
C        Y      DOUBLE PRECISION(N)
C               Y contains an N-vector that is to be manipulated
C               by DQRSL.
C
C        JOB    INTEGER.
C               JOB specifies what is to be computed.  JOB has
C               the decimal expansion ABCDE, with the following
C               meaning.
C
C                    If A .NE. 0, compute QY.
C                    If B,C,D, or E .NE. 0, compute QTY.
C                    If C .NE. 0, compute B.
C                    If D .NE. 0, compute RSD.
C                    If E .NE. 0, compute XB.
C
C               Note that a request to compute B, RSD, or XB
C               automatically triggers the computation of QTY, for
C               which an array must be provided in the calling
C               sequence.
C
C     On Return
C
C        QY     DOUBLE PRECISION(N).
C               QY contains Q*Y, if its computation has been
C               requested.
C
C        QTY    DOUBLE PRECISION(N).
C               QTY contains TRANS(Q)*Y, if its computation has
C               been requested.  Here TRANS(Q) is the
C               transpose of the matrix Q.
C
C        B      DOUBLE PRECISION(K)
C               B contains the solution of the least squares problem
C
C                    minimize norm2(Y - XK*B),
C
C               if its computation has been requested.  (Note that
C               if pivoting was requested in DQRDC, the J-th
C               component of B will be associated with column JPVT(J)
C               of the original matrix X that was input into DQRDC.)
C
C        RSD    DOUBLE PRECISION(N).
C               RSD contains the least squares residual Y - XK*B,
C               if its computation has been requested.  RSD is
C               also the orthogonal projection of Y onto the
C               orthogonal complement of the column space of XK.
C
C        XB     DOUBLE PRECISION(N).
C               XB contains the least squares approximation XK*B,
C               if its computation has been requested.  XB is also
C               the orthogonal projection of Y onto the column space
C               of X.
C
C        INFO   INTEGER.
C               INFO is zero unless the computation of B has
C               been requested and R is exactly singular.  In
C               this case, INFO is the index of the first zero
C               diagonal element of R and B is left unaltered.
C
C     The parameters QY, QTY, B, RSD, and XB are not referenced
C     if their computation is not requested and in this case
C     can be replaced by dummy variables in the calling program.
C     To save storage, the user may in some cases use the same
C     array for different parameters in the calling sequence.  A
C     frequently occuring example is when one wishes to compute
C     any of B, RSD, or XB and does not need Y or QTY.  In this
C     case one may identify Y, QTY, and one of B, RSD, or XB, while
C     providing separate arrays for anything else that is to be
C     computed.  Thus the calling sequence
C
C          CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
C     will result in the computation of B and RSD, with RSD
C     overwriting Y.  More generally, each item in the following
C     list contains groups of permissible identifications for
C     a single calling sequence.
C
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C
C     In any group the value returned in the array allocated to
C     the group corresponds to the last member of the group.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DQRSL uses the following functions and subprograms.
C
C     BLAS DAXPY,DCOPY,DDOT
C     Fortran DABS,MIN0,MOD
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DCOPY,DDOT
C***END PROLOGUE  DQRSL
      INTEGER LDX,N,K,JOB,INFO
      DOUBLE PRECISION X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),
     1                 XB(*)
C
      INTEGER I,J,JJ,JU,KP1
      DOUBLE PRECISION DDOT,T,TEMP
      LOGICAL CB,CQY,CQTY,CR,CXB
C
C     SET INFO FLAG.
C
C***FIRST EXECUTABLE STATEMENT  DQRSL
      INFO = 0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      CQY = JOB/10000 .NE. 0
      CQTY = MOD(JOB,10000) .NE. 0
      CB = MOD(JOB,1000)/100 .NE. 0
      CR = MOD(JOB,100)/10 .NE. 0
      CXB = MOD(JOB,10) .NE. 0
      JU = MIN0(K,N-1)
C
C     SPECIAL ACTION WHEN N=1.
C
      IF (JU .NE. 0) GO TO 40
         IF (CQY) QY(1) = Y(1)
         IF (CQTY) QTY(1) = Y(1)
         IF (CXB) XB(1) = Y(1)
         IF (.NOT.CB) GO TO 30
            IF (X(1,1) .NE. 0.0D0) GO TO 10
               INFO = 1
            GO TO 20
   10       CONTINUE
               B(1) = Y(1)/X(1,1)
   20       CONTINUE
   30    CONTINUE
         IF (CR) RSD(1) = 0.0D0
      GO TO 250
   40 CONTINUE
C
C        SET UP TO COMPUTE QY OR QTY.
C
         IF (CQY) CALL DCOPY(N,Y,1,QY,1)
         IF (CQTY) CALL DCOPY(N,Y,1,QTY,1)
         IF (.NOT.CQY) GO TO 70
C
C           COMPUTE QY.
C
            DO 60 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 50
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J)
                  CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1)
                  X(J,J) = TEMP
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
         IF (.NOT.CQTY) GO TO 100
C
C           COMPUTE TRANS(Q)*Y.
C
            DO 90 J = 1, JU
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 80
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J)
                  CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1)
                  X(J,J) = TEMP
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        SET UP TO COMPUTE B, RSD, OR XB.
C
         IF (CB) CALL DCOPY(K,QTY,1,B,1)
         KP1 = K + 1
         IF (CXB) CALL DCOPY(K,QTY,1,XB,1)
         IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1)
         IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120
            DO 110 I = KP1, N
               XB(I) = 0.0D0
  110       CONTINUE
  120    CONTINUE
         IF (.NOT.CR) GO TO 140
            DO 130 I = 1, K
               RSD(I) = 0.0D0
  130       CONTINUE
  140    CONTINUE
         IF (.NOT.CB) GO TO 190
C
C           COMPUTE B.
C
            DO 170 JJ = 1, K
               J = K - JJ + 1
               IF (X(J,J) .NE. 0.0D0) GO TO 150
                  INFO = J
C           ......EXIT
                  GO TO 180
  150          CONTINUE
               B(J) = B(J)/X(J,J)
               IF (J .EQ. 1) GO TO 160
                  T = -B(J)
                  CALL DAXPY(J-1,T,X(1,J),1,B,1)
  160          CONTINUE
  170       CONTINUE
  180       CONTINUE
  190    CONTINUE
         IF (.NOT.CR .AND. .NOT.CXB) GO TO 240
C
C           COMPUTE RSD OR XB AS REQUIRED.
C
            DO 230 JJ = 1, JU
               J = JU - JJ + 1
               IF (QRAUX(J) .EQ. 0.0D0) GO TO 220
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  IF (.NOT.CR) GO TO 200
                     T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J)
                     CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1)
  200             CONTINUE
                  IF (.NOT.CXB) GO TO 210
                     T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J)
                     CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1)
  210             CONTINUE
                  X(J,J) = TEMP
  220          CONTINUE
  230       CONTINUE
  240    CONTINUE
  250 CONTINUE
      RETURN
      END
      SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB)
C***BEGIN PROLOGUE  DTRCO
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  D2A3
C***KEYWORDS  CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK,
C             MATRIX,TRIANGULAR
C***AUTHOR  MOLER, C. B., (U. OF NEW MEXICO)
C***PURPOSE  Estimates the condition of a double precision TRIANGULAR
C            matrix.
C***DESCRIPTION
C
C     DTRCO estimates the condition of a double precision triangular
C     matrix.
C
C     On Entry
C
C        T       DOUBLE PRECISION(LDT,N)
C                T contains the triangular matrix.  The zero
C                elements of the matrix are not referenced, and
C                the corresponding elements of the array can be
C                used to store other information.
C
C        LDT     INTEGER
C                LDT is the leading dimension of the array T.
C
C        N       INTEGER
C                N is the order of the system.
C
C        JOB     INTEGER
C                = 0         T  is lower triangular.
C                = nonzero   T  is upper triangular.
C
C     On Return
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  T .
C                For the system  T*X = B , relative perturbations
C                in  T  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  T  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  T  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK.  This version dated 08/14/78 .
C     Cleve Moler, University of New Mexico, Argonne National Lab.
C
C     Subroutines and Functions
C
C     BLAS DAXPY,DSCAL,DASUM
C     Fortran DABS,DMAX1,DSIGN
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DASUM,DAXPY,DSCAL
C***END PROLOGUE  DTRCO
      INTEGER LDT,N,JOB
      DOUBLE PRECISION T(LDT,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION W,WK,WKM,EK
      DOUBLE PRECISION TNORM,YNORM,S,SM,DASUM
      INTEGER I1,J,J1,J2,K,KK,L
      LOGICAL LOWER
C***FIRST EXECUTABLE STATEMENT  DTRCO
      LOWER = JOB .EQ. 0
C
C     COMPUTE 1-NORM OF T
C
      TNORM = 0.0D0
      DO 10 J = 1, N
         L = J
         IF (LOWER) L = N + 1 - J
         I1 = 1
         IF (LOWER) I1 = J
         TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1))
   10 CONTINUE
C
C     RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  T*Z = Y  AND  TRANS(T)*Y = E .
C     TRANS(T)  IS THE TRANSPOSE OF T .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF Y .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE TRANS(T)*Y = E
C
      EK = 1.0D0
      DO 20 J = 1, N
         Z(J) = 0.0D0
   20 CONTINUE
      DO 100 KK = 1, N
         K = KK
         IF (LOWER) K = N + 1 - KK
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))
         IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30
            S = DABS(T(K,K))/DABS(EK-Z(K))
            CALL DSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = DABS(WK)
         SM = DABS(WKM)
         IF (T(K,K) .EQ. 0.0D0) GO TO 40
            WK = WK/T(K,K)
            WKM = WKM/T(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0D0
            WKM = 1.0D0
   50    CONTINUE
         IF (KK .EQ. N) GO TO 90
            J1 = K + 1
            IF (LOWER) J1 = 1
            J2 = N
            IF (LOWER) J2 = K - 1
            DO 60 J = J1, J2
               SM = SM + DABS(Z(J)+WKM*T(K,J))
               Z(J) = Z(J) + WK*T(K,J)
               S = S + DABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               W = WKM - WK
               WK = WKM
               DO 70 J = J1, J2
                  Z(J) = Z(J) + W*T(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE T*Z = Y
C
      DO 130 KK = 1, N
         K = N + 1 - KK
         IF (LOWER) K = KK
         IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110
            S = DABS(T(K,K))/DABS(Z(K))
            CALL DSCAL(N,S,Z,1)
            YNORM = S*YNORM
  110    CONTINUE
         IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K)
         IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0
         I1 = 1
         IF (LOWER) I1 = K + 1
         IF (KK .GE. N) GO TO 120
            W = -Z(K)
            CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1)
  120    CONTINUE
  130 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END
      SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
C***BEGIN PROLOGUE  DQRDC
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  D5
C***KEYWORDS  DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,
C             MATRIX,ORTHOGONAL TRIANGULAR
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Uses Householder transformations to compute the Qr factori-
C            zation of N by P matrix X.  Column pivoting is optional.
C***DESCRIPTION
C
C     DQRDC uses Householder transformations to compute the QR
C     factorization of an N by P matrix X.  Column pivoting
C     based on the 2-norms of the reduced columns may be
C     performed at the user's option.
C
C     On Entry
C
C        X       DOUBLE PRECISION(LDX,P), where LDX .GE. N.
C                X contains the matrix whose decomposition is to be
C                computed.
C
C        LDX     INTEGER.
C                LDX is the leading dimension of the array X.
C
C        N       INTEGER.
C                N is the number of rows of the matrix X.
C
C        P       INTEGER.
C                P is the number of columns of the matrix X.
C
C        JPVT    INTEGER(P).
C                JPVT contains integers that control the selection
C                of the pivot columns.  The K-th column X(K) of X
C                is placed in one of three classes according to the
C                value of JPVT(K).
C
C                   If JPVT(K) .GT. 0, then X(K) is an initial
C                                      column.
C
C                   If JPVT(K) .EQ. 0, then X(K) is a free column.
C
C                   If JPVT(K) .LT. 0, then X(K) is a final column.
C
C                Before the decomposition is computed, initial columns
C                are moved to the beginning of the array X and final
C                columns to the end.  Both initial and final columns
C                are frozen in place during the computation and only
C                free columns are moved.  At the K-th stage of the
C                reduction, if X(K) is occupied by a free column
C                it is interchanged with the free column of largest
C                reduced norm.  JPVT is not referenced if
C                JOB .EQ. 0.
C
C        WORK    DOUBLE PRECISION(P).
C                WORK is a work array.  WORK is not referenced if
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB is an integer that initiates column pivoting.
C                If JOB .EQ. 0, no pivoting is done.
C                If JOB .NE. 0, pivoting is done.
C
C     On Return
C
C        X       X contains in its upper triangle the upper
C                triangular matrix R of the QR factorization.
C                Below its diagonal X contains information from
C                which the orthogonal part of the decomposition
C                can be recovered.  Note that if pivoting has
C                been requested, the decomposition is not that
C                of the original matrix X but that of X
C                with its columns permuted as described by JPVT.
C
C        QRAUX   DOUBLE PRECISION(P).
C                QRAUX contains further information required to recover
C                the orthogonal part of the decomposition.
C
C        JPVT    JPVT(K) contains the index of the column of the
C                original matrix that has been interchanged into
C                the K-th column, if pivoting was requested.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DQRDC uses the following functions and subprograms.
C
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2
C     Fortran DABS,DMAX1,MIN0,DSQRT
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DAXPY,DDOT,DNRM2,DSCAL,DSWAP
C***END PROLOGUE  DQRDC
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(*)
      DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*)
C
      INTEGER J,JP,L,LP1,LUP,MAXJ,PL,PU
      DOUBLE PRECISION MAXNRM,DNRM2,TT
      DOUBLE PRECISION DDOT,NRMXL,T
      LOGICAL NEGJ,SWAPJ
C
C***FIRST EXECUTABLE STATEMENT  DQRDC
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL DSWAP(N,X(1,PU),1,X(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
C
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUX(J) = DNRM2(N,X(1,J),1)
         WORK(J) = QRAUX(J)
   70 CONTINUE
   80 CONTINUE
C
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN0(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            MAXNRM = 0.0D0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUX(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUX(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1)
               QRAUX(MAXJ) = QRAUX(L)
               WORK(MAXJ) = WORK(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUX(L) = 0.0D0
         IF (L .EQ. N) GO TO 190
C
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            NRMXL = DNRM2(N-L+1,X(L,L),1)
            IF (NRMXL .EQ. 0.0D0) GO TO 180
               IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L))
               CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
C
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               LP1 = L + 1
               IF (P .LT. LP1) GO TO 170
               DO 160 J = LP1, P
                  T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
                  CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 150
                  IF (QRAUX(J) .EQ. 0.0D0) GO TO 150
                     TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2
                     TT = DMAX1(TT,0.0D0)
                     T = TT
                     TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2
                     IF (TT .EQ. 1.0D0) GO TO 130
                        QRAUX(J) = QRAUX(J)*DSQRT(T)
                     GO TO 140
  130                CONTINUE
                        QRAUX(J) = DNRM2(N-L,X(L+1,J),1)
                        WORK(J) = QRAUX(J)
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170          CONTINUE
C
C              SAVE THE TRANSFORMATION.
C
               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END
      SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB)
C***BEGIN PROLOGUE  DCHEX
C***DATE WRITTEN   780814   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C***CATEGORY NO.  D7B
C***KEYWORDS  CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE,
C             LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE
C***AUTHOR  STEWART, G. W., (U. OF MARYLAND)
C***PURPOSE  Updates the Cholesky factorization  A=TRANS(R)*R  of a
C            POSITIVE DEFINITE matrix A of order P under diagonal
C            permutations of the form  TRANS(E)*A*E  where E is a
C            permutation matrix.
C***DESCRIPTION
C
C     DCHEX updates the Cholesky factorization
C
C                   A = TRANS(R)*R
C
C     of a positive definite matrix A of order P under diagonal
C     permutations of the form
C
C                   TRANS(E)*A*E
C
C     where E is a permutation matrix.  Specifically, given
C     an upper triangular matrix R and a permutation matrix
C     E (which is specified by K, L, and JOB), DCHEX determines
C     an orthogonal matrix U such that
C
C                           U*R*E = RR,
C
C     where RR is upper triangular.  At the users option, the
C     transformation U will be multiplied into the array Z.
C     If A = TRANS(X)*X, so that R is the triangular part of the
C     QR factorization of X, then RR is the triangular part of the
C     QR factorization of X*E, i.e. X with its columns permuted.
C     For a less terse description of what DCHEX does and how
C     it may be applied, see the LINPACK guide.
C
C     The matrix Q is determined as the product U(L-K)*...*U(1)
C     of plane rotations of the form
C
C                           (    C(I)       S(I) )
C                           (                    ) ,
C                           (    -S(I)      C(I) )
C
C     where C(I) is double precision.  The rows these rotations operate
C     on are described below.
C
C     There are two types of permutations, which are determined
C     by the value of JOB.
C
C     1. Right circular shift (JOB = 1).
C
C         The columns are rearranged in the following order.
C
C                1,...,K-1,L,K,K+1,...,L-1,L+1,...,P.
C
C         U is the product of L-K rotations U(I), where U(I)
C         acts in the (L-I,L-I+1)-plane.
C
C     2. Left circular shift (JOB = 2).
C         The columns are rearranged in the following order
C
C                1,...,K-1,K+1,K+2,...,L,K,L+1,...,P.
C
C         U is the product of L-K rotations U(I), where U(I)
C         acts in the (K+I-1,K+I)-plane.
C
C     On Entry
C
C         R      DOUBLE PRECISION(LDR,P), where LDR .GE. P.
C                R contains the upper triangular factor
C                that is to be updated.  Elements of R
C                below the diagonal are not referenced.
C
C         LDR    INTEGER.
C                LDR is the leading dimension of the array R.
C
C         P      INTEGER.
C                P is the order of the matrix R.
C
C         K      INTEGER.
C                K is the first column to be permuted.
C
C         L      INTEGER.
C                L is the last column to be permuted.
C                L must be strictly greater than K.
C
C         Z      DOUBLE PRECISION(LDZ,N)Z), where LDZ .GE. P.
C                Z is an array of NZ P-vectors into which the
C                transformation U is multiplied.  Z is
C                not referenced if NZ = 0.
C
C         LDZ    INTEGER.
C                LDZ is the leading dimension of the array Z.
C
C         NZ     INTEGER.
C                NZ is the number of columns of the matrix Z.
C
C         JOB    INTEGER.
C                JOB determines the type of permutation.
C                       JOB = 1  right circular shift.
C                       JOB = 2  left circular shift.
C
C     On Return
C
C         R      contains the updated factor.
C
C         Z      contains the updated matrix Z.
C
C         C      DOUBLE PRECISION(P).
C                C contains the cosines of the transforming rotations.
C
C         S      DOUBLE PRECISION(P).
C                S contains the sines of the transforming rotations.
C
C     LINPACK.  This version dated 08/14/78 .
C     G. W. Stewart, University of Maryland, Argonne National Lab.
C
C     DCHEX uses the following functions and subroutines.
C
C     BLAS DROTG
C     Fortran MIN0
C***REFERENCES  DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C                 *LINPACK USERS  GUIDE*, SIAM, 1979.
C***ROUTINES CALLED  DROTG
C***END PROLOGUE  DCHEX
      INTEGER LDR,P,K,L,LDZ,NZ,JOB
      DOUBLE PRECISION R(LDR,*),Z(LDZ,*),S(*)
      DOUBLE PRECISION C(*)
C
      INTEGER I,II,IL,IU,J,JJ,KM1,KP1,LMK,LM1
      DOUBLE PRECISION RJP1J,T
C
C     INITIALIZE
C
C***FIRST EXECUTABLE STATEMENT  DCHEX
      KM1 = K - 1
      KP1 = K + 1
      LMK = L - K
      LM1 = L - 1
C
C     PERFORM THE APPROPRIATE TASK.
C
      GO TO (10,130), JOB
C
C     RIGHT CIRCULAR SHIFT.
C
   10 CONTINUE
C
C        REORDER THE COLUMNS.
C
         DO 20 I = 1, L
            II = L - I + 1
            S(I) = R(II,L)
   20    CONTINUE
         DO 40 JJ = K, LM1
            J = LM1 - JJ + K
            DO 30 I = 1, J
               R(I,J+1) = R(I,J)
   30       CONTINUE
            R(J+1,J+1) = 0.0D0
   40    CONTINUE
         IF (K .EQ. 1) GO TO 60
            DO 50 I = 1, KM1
               II = L - I + 1
               R(I,K) = S(II)
   50       CONTINUE
   60    CONTINUE
C
C        CALCULATE THE ROTATIONS.
C
         T = S(1)
         DO 70 I = 1, LMK
            CALL DROTG(S(I+1),T,C(I),S(I))
            T = S(I+1)
   70    CONTINUE
         R(K,K) = T
         DO 90 J = KP1, P
            IL = MAX0(1,L-J+1)
            DO 80 II = IL, LMK
               I = L - II
               T = C(II)*R(I,J) + S(II)*R(I+1,J)
               R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J)
               R(I,J) = T
   80       CONTINUE
   90    CONTINUE
C
C        IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z.
C
         IF (NZ .LT. 1) GO TO 120
         DO 110 J = 1, NZ
            DO 100 II = 1, LMK
               I = L - II
               T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
               Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J)
               Z(I,J) = T
  100       CONTINUE
  110    CONTINUE
  120    CONTINUE
      GO TO 260
C
C     LEFT CIRCULAR SHIFT
C
  130 CONTINUE
C
C        REORDER THE COLUMNS
C
         DO 140 I = 1, K
            II = LMK + I
            S(II) = R(I,K)
  140    CONTINUE
         DO 160 J = K, LM1
            DO 150 I = 1, J
               R(I,J) = R(I,J+1)
  150       CONTINUE
            JJ = J - KM1
            S(JJ) = R(J+1,J+1)
  160    CONTINUE
         DO 170 I = 1, K
            II = LMK + I
            R(I,L) = S(II)
  170    CONTINUE
         DO 180 I = KP1, L
            R(I,L) = 0.0D0
  180    CONTINUE
C
C        REDUCTION LOOP.
C
         DO 220 J = K, P
            IF (J .EQ. K) GO TO 200
C
C              APPLY THE ROTATIONS.
C
               IU = MIN0(J-1,L-1)
               DO 190 I = K, IU
                  II = I - K + 1
                  T = C(II)*R(I,J) + S(II)*R(I+1,J)
                  R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J)
                  R(I,J) = T
  190          CONTINUE
  200       CONTINUE
            IF (J .GE. L) GO TO 210
               JJ = J - K + 1
               T = S(JJ)
               CALL DROTG(R(J,J),T,C(JJ),S(JJ))
  210       CONTINUE
  220    CONTINUE
C
C        APPLY THE ROTATIONS TO Z.
C
         IF (NZ .LT. 1) GO TO 250
         DO 240 J = 1, NZ
            DO 230 I = K, LM1
               II = I - KM1
               T = C(II)*Z(I,J) + S(II)*Z(I+1,J)
               Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J)
               Z(I,J) = T
  230       CONTINUE
  240    CONTINUE
  250    CONTINUE
  260 CONTINUE
      RETURN
      END
*DJCKF
      SUBROUTINE DJCKF
     +   (FUN,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,
     +   J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE,
     +   PVTEMP,ISWRTB,MSG,LMSG,IFLAG)
C***BEGIN PROLOGUE  DJCKF
C***REFER TO  DODR,DODRC
C***ROUTINES CALLED  DPVB,DPVD
C***DATE WRITTEN   860529   (YYMMDD)
C***REVISION DATE  870204   (YYMMDD)
C***CATEGORY NO.  G2E,I1B1
C***KEYWORDS  ORTHOGONAL DISTANCE REGRESSION,
C             NONLINEAR LEAST SQUARES,
C             ERRORS IN VARIABLES
C***AUTHOR  BOGGS, PAUL T.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, GAITHERSBURG, MD 20899
C           BYRD, RICHARD H.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C           DONALDSON, JANET R.
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C           SCHNABEL, ROBERT B.
C             DEPARTMENT OF COMPUTER SCIENCE
C             UNIVERSITY OF COLORADO, BOULDER, CO 80309
C             AND
C             OPTIMIZATION GROUP/SCIENTIFIC COMPUTING DIVISION
C             NATIONAL BUREAU OF STANDARDS, BOULDER, CO 80303-3328
C***PURPOSE  CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE
C            CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES.
C            (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKFPA)
C***END PROLOGUE  DJCKF
C
C  EXTERNALS
C
      EXTERNAL FUN
C        THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B,
C        ARGUMENT FUN.)
C
C  FUNCTION DECLARATIONS
C
      DOUBLE PRECISION DPVB
      DOUBLE PRECISION DPVD
C
C  VARIABLE DECLARATIONS (ALPHABETICALLY)
C
      DOUBLE PRECISION BETA(NP)
C        THE FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      DOUBLE PRECISION CURVE
C        A MEASURE OF THE CURVATURE IN THE MODEL.
      DOUBLE PRECISION D
C        THE SCALAR IN WHICH ROW   NROW   OF THE DERIVATIVE
C        MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER
C        IS STORED.
      DOUBLE PRECISION ETA
C        THE RELATIVE NOISE IN THE MODEL
      DOUBLE PRECISION FD
C        THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE
C        JTH PARAMETER
      INTEGER IFLAG
C        AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE
C        USER WISHES THE COMPUTATIONS STOPPED.
      LOGICAL ISWRTB
C        THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT
C        BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED.
      INTEGER J
C        THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED.
      LOGICAL LARGE
C        AN INDICATOR VALUE INDICATING WHETHER THE RECOMMENDED
C        INCREASE IN THE STEP SIZE WOULD BE GREATER THAN PARMX.
      INTEGER LDXPD
C        THE LEADING DIMENSION OF ARRAY XPLUSD.
      INTEGER LMSG
C        THE LENGTH OF THE VECTOR MSG.
      INTEGER M
C        THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER MSG(LMSG)
C        THE ERROR CHECKING RESULTS.
      INTEGER N
C        THE NUMBER OF OBSERVATIONS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NP
C        THE NUMBER OF FUNCTION PARAMETERS.
C        (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.)
      INTEGER NROW
C        THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT
C        WHICH THE DERIVATIVE IS TO BE CHECKED.
      DOUBLE PRECISION ONE
C        THE VALUE 1.0D0.
      DOUBLE PRECISION PARMX
C        THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE
C        TYPICAL VALUE OF THAT PARAMETER
      DOUBLE PRECISION PV
C        THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR
C        ROW   NROW   IS STORED.
      DOUBLE PRECISION PVPSTP
C        THE PREDICTED VALUE FOR ROW    NROW   OF THE MODEL
C        BASED ON THE CURRENT PARAMETER ESTIMATES
C        FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP.
      DOUBLE PRECISION PVTEMP(N)
C        THE VECTOR OF PREDICTED VALUES FROM THE MODEL.
      DOUBLE PRECISION STP
C        THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC
C        DERIVATIVE
      DOUBLE PRECISION TEN
C        THE VALUE 10.0D0.
      DOUBLE PRECISION TOL
C        THE AGREEMENT TOLERANCE.
      DOUBLE PRECISION TWO
C        THE VALUE 2.0D0.
      DOUBLE PRECISION XPLUSD(LDXPD,M)
C        THE ARRAY X + DELTA.
C
C
      DATA ONE,TWO,TEN/1.0D0,2.0D0,10.0D0/
C
C
C***FIRST EXECUTABLE STATEMENT  DJCKF
C
C
C  CHECK WHETHER FINITE PRECISION COULD BE THE PROBLEM
C
      IF (ABS(STP*(FD-D)).GE.TEN*ETA*(ABS(PV)+ABS(PVPSTP))) THEN
C
C  DISCREPANCY BETWEEN NUMERICAL AND ANALYTICAL DERIVATIVES CANNOT
C  BE ACCOUNTED FOR BY FINITE PRECISION ARITHMETIC
C
         MSG(1) = 1
         MSG(J+1) = 1
      ELSE
C
C  FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM.
C  TRY A LARGER STEP SIZE
C
C
         IF (ISWRTB) THEN
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA
C
            STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,BETA(J))/
     +            (TOL*ABS(D))+BETA(J)) - BETA(J)
            IF (ABS(STP).GT.PARMX) THEN
               STP = PARMX*SIGN(ONE,BETA(J))
               LARGE = .TRUE.
            ELSE
               LARGE = .FALSE.
            END IF
            PVPSTP = DPVB(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                    NROW,J,STP,IFLAG)
         ELSE
C
C  PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA
C
            STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,XPLUSD(NROW,J))/
     +            (TOL*ABS(D))+XPLUSD(NROW,J)) - XPLUSD(NROW,J)
            IF (ABS(STP).GT.PARMX) THEN
               STP = PARMX*SIGN(ONE,XPLUSD(NROW,J))
               LARGE = .TRUE.
            ELSE
               LARGE = .FALSE.
            END IF
            PVPSTP = DPVD(FUN,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,
     +                    NROW,J,STP,IFLAG)
         END IF
         IF (IFLAG.LT.0) THEN
            RETURN
         END IF
C
         FD = (PVPSTP-PV)/STP
C
C  CHECK FOR AGREEMENT
C
         IF ((ABS(FD-D)).GT.TWO*TOL*ABS(D)) THEN
C
C  FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES STILL DISAGREE.
C  CHECK IF CURVATURE IS THE PROBLEM
C
            IF (ABS(CURVE*STP).GE.ABS(FD-D) .OR. LARGE) THEN
C
C  CURVATURE MAY BE THE CULPRIT
C
               IF (MSG(1).EQ.0) MSG(1) = 2
               IF (LARGE) THEN
                  MSG(J+1) = 5
               ELSE
                  MSG(J+1) = 6
               END IF
            ELSE
C
C  CURVATURE COULDNT BE THE CULPRIT
C
               MSG(1) = 1
               MSG(J+1) = 1
            END IF
         END IF
      END IF
C
      RETURN
      END
      SUBROUTINE DSCAL(N,DA,DX,INCX)
C***BEGIN PROLOGUE  DSCAL
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A6
C***KEYWORDS  BLAS,LINEAR ALGEBRA,SCALE,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  D.P. vector scale x = a*x
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DA  double precision scale factor
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C       DX  double precision result (unchanged if N.LE.0)
C
C     Replace double precision DX by double precision DA*DX.
C     For I = 0 to N-1, replace DX(1+I*INCX) with  DA * DX(1+I*INCX)
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DSCAL
C
      DOUBLE PRECISION DA,DX(*)
C***FIRST EXECUTABLE STATEMENT  DSCAL
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I = 1,NS,INCX
          DX(I) = DA*DX(I)
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
C
   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DX(I) = DA*DX(I)
   30 CONTINUE
      IF( N .LT. 5 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DX(I) = DA*DX(I)
        DX(I + 1) = DA*DX(I + 1)
        DX(I + 2) = DA*DX(I + 2)
        DX(I + 3) = DA*DX(I + 3)
        DX(I + 4) = DA*DX(I + 4)
   50 CONTINUE
      RETURN
      END
      DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
C***BEGIN PROLOGUE  DASUM
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A3A
C***KEYWORDS  ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM,
C             VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Sum of magnitudes of d.p. vector components
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C    DASUM  double precision result (zero if N .LE. 0)
C
C     Returns sum of magnitudes of double precision DX.
C     DASUM = sum from 0 to N-1 of DABS(DX(1+I*INCX))
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DASUM
C
      DOUBLE PRECISION DX(*)
C***FIRST EXECUTABLE STATEMENT  DASUM
      DASUM = 0.D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I=1,NS,INCX
          DASUM = DASUM + DABS(DX(I))
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6.
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
         DASUM = DASUM + DABS(DX(I))
   30 CONTINUE
      IF( N .LT. 6 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
         DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2))
     1   + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5))
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
C***BEGIN PROLOGUE  DSWAP
C***DATE WRITTEN   791001   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***REVISION HISTORY  (YYMMDD)
C   000330  Modified array declarations.  (JEC)
C
C***CATEGORY NO.  D1A5
C***KEYWORDS  BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR
C***AUTHOR  LAWSON, C. L., (JPL)
C           HANSON, R. J., (SNLA)
C           KINCAID, D. R., (U. OF TEXAS)
C           KROGH, F. T., (JPL)
C***PURPOSE  Interchange d.p. vectors
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C       DY  double precision vector with N elements
C     INCY  storage spacing between elements of DY
C
C     --Output--
C       DX  input vector DY (unchanged if N .LE. 0)
C       DY  input vector DX (unchanged if N .LE. 0)
C
C     Interchange double precision DX and double precision DY.
C     For I = 0 to N-1, interchange  DX(LX+I*INCX) and DY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C     defined in a similar way using INCY.
C***REFERENCES  LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T.,
C                 *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*,
C                 ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL
C                 SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  DSWAP
C
      DOUBLE PRECISION DX(*),DY(*),DTEMP1,DTEMP2,DTEMP3
C***FIRST EXECUTABLE STATEMENT  DSWAP
      IF(N.LE.0)RETURN
      IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60
    5 CONTINUE
C
C       CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
C
      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP1 = DX(IX)
        DX(IX) = DY(IY)
        DY(IY) = DTEMP1
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C       CODE FOR BOTH INCREMENTS EQUAL TO 1
C
C
C       CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3.
C
   20 M = MOD(N,3)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP1 = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP1
   30 CONTINUE
      IF( N .LT. 3 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,3
        DTEMP1 = DX(I)
        DTEMP2 = DX(I+1)
        DTEMP3 = DX(I+2)
        DX(I) = DY(I)
        DX(I+1) = DY(I+1)
        DX(I+2) = DY(I+2)
        DY(I) = DTEMP1
        DY(I+1) = DTEMP2
        DY(I+2) = DTEMP3
   50 CONTINUE
      RETURN
   60 CONTINUE
C
C     CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS.
C
      NS = N*INCX
        DO 70 I=1,NS,INCX
        DTEMP1 = DX(I)
        DX(I) = DY(I)
        DY(I) = DTEMP1
   70   CONTINUE
      RETURN
      END
