      PROGRAM SAMPLE

C  SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER
C  WHERE  MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED 
C         MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE
C              INDEPENDENT VARIABLE ALLOWED
C        MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS
C              ALLOWED 
C          LDX IS THE LEADING DIMENSION OF ARRAY X
C       LDSCLD IS THE LEADING DIMENSION OF ARRAY SCLD
C         LDWD IS THE LEADING DIMENSION OF ARRAY WD
C        LDIFX IS THE LEADING DIMENSION OF ARRAY IFIXX
C        LWORK IS THE DIMENSION OF VECTOR WORK
C       LIWORK IS THE DIMENSION OF VECTOR IWORK

C...PARAMETERS
      INTEGER
     +   MAXN,MAXM,MAXNP,LDSCLD,LDIFX,LDWD,LWORK,LIWORK
      PARAMETER
     +   (MAXN=15,
     +   MAXM=5,
     +   MAXNP=5,
     +   LDSCLD=1,
     +   LDWD=1,
     +   LDIFX=1,
     +   LWORK=17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP,
     +   LIWORK=19 + 2*MAXNP + MAXM)

C  DECLARE USER-SUPPLIED SUBROUTINES AND
C  ALL OTHER NECESSARY VARIABLES AND ARRAYS

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   PARTOL,SSTOL,TAUFAC
      INTEGER
     +   I,INFO,IPRINT,J,JOB,LDX,LUNERR,LUNRPT,M,MAXIT,N,NDIGIT,NP

C...LOCAL ARRAYS
      DOUBLE PRECISION
     +   BETA(MAXNP),WD(LDWD,MAXM),SCLB(MAXNP),
     +   SCLD(LDSCLD,MAXM),W(MAXN),WORK(LWORK),X(MAXN,MAXM),Y(MAXN)
      INTEGER
     +   IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)

C...EXTERNAL SUBROUTINES
      EXTERNAL
     +   DODRC,FUN,JAC


      OPEN(UNIT=5,FILE='DATA1')
      OPEN(UNIT=6,FILE='REPORT')

C  SPECIFY LEADING DIMENSION OF ARRAY X

      LDX = MAXN

C  READ NUMBER OF OBSERVATIONS
C       NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE
C       NUMBER OF PARAMETERS
C       OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES
C       STARTING VALUES OF FUNCTION PARAMETERS

      READ (5,*) N,M,NP
      READ (5,*) ((X(I,J),I=1,N),J=1,M)
      READ (5,*) (Y(I),I=1,N)
      READ (5,*) (BETA(I),I=1,NP)

C  FIX SECOND COLUMN OF INDEPENDENT VARIABLE AT OBSERVED VALUES

      IFIXX(1,1) = 1
      IFIXX(1,2) = 0

C  SPECIFY USE OF DEFAULT SCALING

      SCLD(1,1) = -1.0D0
      SCLB(1) = -1.0D0

C  INDICATE ALL BETA'S ARE TO BE ESTIMATED

      IFIXB(1) = -1

C  SPECIFY WEIGHTS

      WD(1,1) = 3.0D0
      WD(1,2) = 5.0D0
      W(1) = -1.0D0

C  SET CONTROL VALUES AND STOPPING CRITERIA

      JOB = 10
      NDIGIT = -1
      TAUFAC = -1.0D0
      SSTOL = -1.0D0
      PARTOL = -1.0D0
      MAXIT = -1
      IPRINT = 1111
      LUNERR = -1
      LUNRPT = -1

C  COMPUTE ODR SOLUTION USING USER-SUPPLIED ANALYTIC DERIVATIVES

      CALL DODRC
     +   (FUN,JAC,
     +   N,M,NP,
     +   X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,
     +   Y,
     +   BETA,IFIXB,SCLB,
     +   WD,LDWD,W,
     +   JOB,NDIGIT,TAUFAC,
     +   SSTOL,PARTOL,MAXIT,
     +   IPRINT,LUNERR,LUNRPT,
     +   WORK,LWORK,IWORK,LIWORK,
     +   INFO)

      END
      SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF)

C  INPUT ARGUMENTS
C  (WHICH MUST NOT BE CHANGED BY THIS ROUTINE)

C     INTEGER N,NP,M,LDXPD
C     DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M)

C  OUTPUT ARGUMENTS

C     DOUBLE PRECISION F(N)
C     INTEGER ISTOPF

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOPF,LDXPD,M,N,NP

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +    BETA(NP),F(N),XPLUSD(LDXPD,M)

C...LOCAL SCALARS
      INTEGER
     +    I

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +    EXP


      DO 10 I = 1, N
         IF (XPLUSD(I,2).NE.0.0D0) THEN
            F(I) = EXP(-BETA(1)*XPLUSD(I,1)*
     +             EXP(-BETA(2)*
     +                  (1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0)))
         ELSE
            ISTOPF = 1
            RETURN
         END IF
   10 CONTINUE
      ISTOPF = 0

      RETURN
      END
      SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD,
     +               FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ)

C  INPUT ARGUMENTS
C  (WHICH MUST NOT BE CHANGED BY THIS ROUTINE)

C     INTEGER N,NP,M,LDXPD
C     DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M)
C     LOGICAL ISODR

C  OUTPUT ARGUMENTS

C     DOUBLE PRECISION FJACB(LDFJB,NP),FJACX(LDFJX,M)
C     INTEGER ISTOPJ

C...SCALAR ARGUMENTS
      INTEGER
     +   ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP
      LOGICAL
     +   ISODR

C...ARRAY ARGUMENTS
      DOUBLE PRECISION
     +   BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M)

C...LOCAL SCALARS
      DOUBLE PRECISION
     +   FAC1,FAC2,FAC3,FAC4
      INTEGER
     +   I

C...INTRINSIC FUNCTIONS
      INTRINSIC
     +   EXP


      DO 10 I=1,N
         FAC1 = 1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0
         FAC2 = EXP(-BETA(2)*FAC1)
         FAC3 = BETA(1)*XPLUSD(I,1)
         FAC4 = EXP(-FAC3*FAC2)

         FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2
         FJACB(I,2) = FAC4*FAC3*FAC2*FAC1

         IF (ISODR) THEN
            FJACX(I,1) = -FAC4*BETA(1)*FAC2
            FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2
         END IF
   10 CONTINUE
      ISTOPJ = 0

      RETURN
      END
