171 lines
6.2 KiB
FortranFixed
171 lines
6.2 KiB
FortranFixed
PROGRAM SAMPLE
|
|
USE ODRPACK95
|
|
USE REAL_PRECISION
|
|
|
|
C ODRPACK95 Argument Definitions
|
|
C ==> FCN Name of the user supplied function subroutine
|
|
C ==> N Number of observations
|
|
C ==> M Columns of data in the explanatory variable
|
|
C ==> NP Number of parameters
|
|
C ==> NQ Number of responses per observation
|
|
C <==> BETA Function parameters
|
|
C ==> Y Response variable (unused when model is implicit)
|
|
C ==> X Explanatory variable
|
|
C ==> WE Initial penalty parameter for implicit model
|
|
C ==> WD "Delta" weights
|
|
C ==> JOB Task to be performed
|
|
C ==> IPRINT Print control
|
|
C ==> LUNERR Logical unit for error reports
|
|
C ==> LUNRPT Logical unit for computation reports
|
|
C <==> WORK REAL (KIND=R8) work vector
|
|
C <== IWORK Integer work vector
|
|
C <== INFO Stopping condition
|
|
|
|
C Parameters specifying maximum problem sizes handled by this driver
|
|
C MAXN Maximum number of observations
|
|
C MAXM Maximum number of columns in explanatory variable
|
|
C MAXNP Maximum number of function parameters
|
|
C MAXNQ Maximum number of responses per observation
|
|
|
|
C Parameter declarations and specifications
|
|
INTEGER LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
|
& LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
|
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
|
|
& LDY=MAXN,LDX=MAXN,
|
|
& LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
|
|
& LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 +
|
|
& 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +
|
|
& 2*MAXN*MAXNQ*MAXM + MAXNQ**2 +
|
|
& 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
|
|
& LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
|
|
|
|
C Variable declarations
|
|
INTEGER I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP,NQ
|
|
INTEGER IWORK(:)
|
|
REAL (KIND=R8) BETA(MAXNP),
|
|
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
|
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
|
|
EXTERNAL FCN
|
|
POINTER IWORK,WORK
|
|
|
|
|
|
C Allocate work arrays
|
|
ALLOCATE(IWORK(LIWORK),WORK(LWORK))
|
|
|
|
C Specify default values for DODR arguments
|
|
WE(1,1,1) = -1.0E0_R8
|
|
WD(1,1,1) = -1.0E0_R8
|
|
JOB = -1
|
|
IPRINT = -1
|
|
LUNERR = -1
|
|
LUNRPT = -1
|
|
|
|
C Set up ODRPACK95 report files
|
|
LUNERR = 9
|
|
LUNRPT = 9
|
|
OPEN (UNIT=9,FILE='REPORT2')
|
|
|
|
C Read problem data
|
|
OPEN (UNIT=5,FILE='DATA2')
|
|
READ (5,FMT=*) N,M,NP,NQ
|
|
READ (5,FMT=*) (BETA(I),I=1,NP)
|
|
DO 10 I=1,N
|
|
READ (5,FMT=*) (X(I,J),J=1,M)
|
|
10 CONTINUE
|
|
|
|
C Specify task: Implicit orthogonal distance regression
|
|
C With forward finite difference derivatives
|
|
C Covariance matrix constructed with recomputed derivatives
|
|
C DELTA initialized to zero
|
|
C Not a restart
|
|
JOB = 00001
|
|
|
|
C Compute solution
|
|
CALL ODR(FCN=FCN,
|
|
& N=N,M=M,NP=NP,NQ=NQ,
|
|
& BETA=BETA,
|
|
& Y=Y,X=X,
|
|
& WE=WE,WD=WD,
|
|
& JOB=JOB,
|
|
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
|
& WORK=WORK,IWORK=IWORK,
|
|
& INFO=INFO)
|
|
END
|
|
|
|
|
|
SUBROUTINE FCN(N,M,NP,NQ,
|
|
& LDN,LDM,LDNP,
|
|
& BETA,XPLUSD,
|
|
& IFIXB,IFIXX,LDIFX,
|
|
& IDEVAL,F,FJACB,FJACD,
|
|
& ISTOP)
|
|
|
|
C Subroutine Arguments
|
|
C ==> N Number of observations
|
|
C ==> M Number of columns in explanatory variable
|
|
C ==> NP Number of parameters
|
|
C ==> NQ Number of responses per observation
|
|
C ==> LDN Leading dimension declarator equal or exceeding N
|
|
C ==> LDM Leading dimension declarator equal or exceeding M
|
|
C ==> LDNP Leading dimension declarator equal or exceeding NP
|
|
C ==> BETA Current values of parameters
|
|
C ==> XPLUSD Current value of explanatory variable, i.e., X + DELTA
|
|
C ==> IFIXB Indicators for "fixing" parameters (BETA)
|
|
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
|
|
C ==> LDIFX Leading dimension of array IFIXX
|
|
C ==> IDEVAL Indicator for selecting computation to be performed
|
|
C <== F Predicted function values
|
|
C <== FJACB Jacobian with respect to BETA
|
|
C <== FJACD Jacobian with respect to errors DELTA
|
|
C <== ISTOP Stopping condition, where
|
|
C 0 Means current BETA and X+DELTA were
|
|
C acceptable and values were computed successfully
|
|
C 1 Means current BETA and X+DELTA are
|
|
C not acceptable; ODRPACK95 should select values
|
|
C closer to most recently used values if possible
|
|
C -1 Means current BETA and X+DELTA are
|
|
C not acceptable; ODRPACK95 should stop
|
|
|
|
C Used Modules
|
|
USE REAL_PRECISION
|
|
|
|
C Input arguments, not to be changed by this routine:
|
|
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
|
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
|
|
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
|
C Output arguments:
|
|
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
|
|
|
|
|
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
|
|
C are not being used. This is simply not to worry users that the example
|
|
C program is failing.
|
|
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
|
|
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
|
|
C Do nothing.
|
|
END IF
|
|
|
|
|
|
C Check for unacceptable values for this problem
|
|
IF (BETA(1) .GT. 0.0E0_R8) THEN
|
|
ISTOP = 1
|
|
RETURN
|
|
ELSE
|
|
ISTOP = 0
|
|
END IF
|
|
|
|
C Compute predicted values
|
|
IF (MOD(IDEVAL,10).GE.1) THEN
|
|
DO 110 L = 1,NQ
|
|
DO 100 I = 1,N
|
|
F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
|
|
& 2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
|
|
& (XPLUSD(I,2)-BETA(2)) +
|
|
& BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0E0_R8
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
END IF
|
|
|
|
RETURN
|
|
END
|