New changes from l2g
w
This commit is contained in:
@@ -0,0 +1,226 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
C ODRPACK 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
|
||||
C ==> LDY LEADING DIMENSION OF ARRAY Y
|
||||
C ==> X EXPLANATORY VARIABLE
|
||||
C ==> LDX LEADING DIMENSION OF ARRAY X
|
||||
C ==> WE "EPSILON" WEIGHTS
|
||||
C ==> LDWE LEADING DIMENSION OF ARRAY WE
|
||||
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
|
||||
C ==> WD "DELTA" WEIGHTS
|
||||
C ==> LDWD LEADING DIMENSION OF ARRAY WD
|
||||
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
|
||||
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
|
||||
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
|
||||
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
|
||||
C ==> JOB TASK TO BE PERFORMED
|
||||
C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS
|
||||
C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR
|
||||
C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION
|
||||
C ==> PARTOL PARAMETER CONVERGENCE CRITERION
|
||||
C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS
|
||||
C ==> IPRINT PRINT CONTROL
|
||||
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
|
||||
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
|
||||
C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
|
||||
C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
|
||||
C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD
|
||||
C ==> SCLB SCALE VALUES FOR PARAMETERS BETA
|
||||
C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
|
||||
C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD
|
||||
C <==> WORK DOUBLE PRECISION WORK VECTOR
|
||||
C ==> LWORK DIMENSION OF VECTOR WORK
|
||||
C <== IWORK INTEGER WORK VECTOR
|
||||
C ==> LIWORK DIMENSION OF VECTOR IWORK
|
||||
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 LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=1,
|
||||
+ LDY=MAXN,LDX=MAXN,
|
||||
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
|
||||
+ LDIFX=MAXN,LDSTPD=1,LDSCLD=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,L,LUNERR,LUNRPT,M,MAXIT,N,
|
||||
+ NDIGIT,NP,NQ
|
||||
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
|
||||
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
|
||||
DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
+ STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
|
||||
WE(1,1,1) = -1.0D0
|
||||
WD(1,1,1) = -1.0D0
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT1')
|
||||
|
||||
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
|
||||
OPEN (UNIT=5,FILE='DATA1')
|
||||
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),(Y(I,L),L=1,NQ)
|
||||
IF (X(I,1).EQ.0.0D0 .OR. X(I,1).EQ.100.0D0) THEN
|
||||
IFIXX(I,1) = 0
|
||||
ELSE
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
10 CONTINUE
|
||||
|
||||
C SPECIFY TASK: EXPLICIT ORTHOGONAL DISTANCE REGRESSION
|
||||
C WITH USER SUPPLIED DERIVATIVES (CHECKED)
|
||||
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
|
||||
C DELTA INITIALIZED TO ZERO
|
||||
C NOT A RESTART
|
||||
C AND INDICATE SHORT INITIAL REPORT
|
||||
C SHORT ITERATION REPORTS EVERY ITERATION, AND
|
||||
C LONG FINAL REPORT
|
||||
JOB = 00020
|
||||
IPRINT = 1112
|
||||
|
||||
C COMPUTE SOLUTION
|
||||
CALL DODRC(FCN,
|
||||
+ N,M,NP,NQ,
|
||||
+ BETA,
|
||||
+ Y,LDY,X,LDX,
|
||||
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ JOB,NDIGIT,TAUFAC,
|
||||
+ SSTOL,PARTOL,MAXIT,
|
||||
+ IPRINT,LUNERR,LUNRPT,
|
||||
+ STPB,STPD,LDSTPD,
|
||||
+ SCLB,SCLD,LDSCLD,
|
||||
+ WORK,LWORK,IWORK,LIWORK,
|
||||
+ INFO)
|
||||
END
|
||||
|
||||
|
||||
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; ODRPACK SHOULD SELECT VALUES
|
||||
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
|
||||
C -1 MEANS CURRENT BETA AND X+DELTA ARE
|
||||
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
|
||||
|
||||
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
|
||||
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C OUTPUT ARGUMENTS:
|
||||
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
C LOCAL VARIABLES
|
||||
INTRINSIC EXP
|
||||
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
IF (BETA(1) .LT. 0.0D0) 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(1) +
|
||||
+ BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
|
||||
IF (MOD(IDEVAL/10,10).GE.1) THEN
|
||||
DO 210 L = 1,NQ
|
||||
DO 200 I = 1,N
|
||||
FJACB(I,1,L) = 1.0D0
|
||||
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
|
||||
FJACB(I,3,L) = BETA(2)*2*
|
||||
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
|
||||
+ EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
END IF
|
||||
|
||||
C COMPUTE DERIVATIVES WITH RESPECT TO DELTA
|
||||
IF (MOD(IDEVAL/100,10).GE.1) THEN
|
||||
DO 310 L = 1,NQ
|
||||
DO 300 I = 1,N
|
||||
FJACD(I,1,L) = BETA(2)*2*
|
||||
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
|
||||
+ EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,160 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
C ODRPACK 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 ==> LDY LEADING DIMENSION OF ARRAY Y
|
||||
C ==> X EXPLANATORY VARIABLE
|
||||
C ==> LDX LEADING DIMENSION OF ARRAY X
|
||||
C ==> WE INITIAL PENALTY PARAMETER FOR IMPLICIT MODEL
|
||||
C ==> LDWE LEADING DIMENSION OF ARRAY WE
|
||||
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
|
||||
C ==> WD "DELTA" WEIGHTS
|
||||
C ==> LDWD LEADING DIMENSION OF ARRAY WD
|
||||
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
|
||||
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 DOUBLE PRECISION WORK VECTOR
|
||||
C ==> LWORK DIMENSION OF VECTOR WORK
|
||||
C <== IWORK INTEGER WORK VECTOR
|
||||
C ==> LIWORK DIMENSION OF VECTOR IWORK
|
||||
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(LIWORK)
|
||||
DOUBLE PRECISION BETA(MAXNP),
|
||||
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
C SPECIFY DEFAULT VALUES FOR DODR ARGUMENTS
|
||||
WE(1,1,1) = -1.0D0
|
||||
WD(1,1,1) = -1.0D0
|
||||
JOB = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
|
||||
C SET UP ODRPACK 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 DODR(FCN,
|
||||
+ N,M,NP,NQ,
|
||||
+ BETA,
|
||||
+ Y,LDY,X,LDX,
|
||||
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
|
||||
+ JOB,
|
||||
+ IPRINT,LUNERR,LUNRPT,
|
||||
+ WORK,LWORK,IWORK,LIWORK,
|
||||
+ INFO)
|
||||
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; ODRPACK SHOULD SELECT VALUES
|
||||
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
|
||||
C -1 MEANS CURRENT BETA AND X+DELTA ARE
|
||||
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
|
||||
|
||||
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
|
||||
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C OUTPUT ARGUMENTS:
|
||||
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
IF (BETA(1) .GT. 0.0D0) 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.0D0
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,248 @@
|
||||
PROGRAM SAMPLE
|
||||
|
||||
C ODRPACK 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
|
||||
C ==> LDY LEADING DIMENSION OF ARRAY Y
|
||||
C ==> X EXPLANATORY VARIABLE
|
||||
C ==> LDX LEADING DIMENSION OF ARRAY X
|
||||
C ==> WE "EPSILON" WEIGHTS
|
||||
C ==> LDWE LEADING DIMENSION OF ARRAY WE
|
||||
C ==> LD2WE SECOND DIMENSION OF ARRAY WE
|
||||
C ==> WD "DELTA" WEIGHTS
|
||||
C ==> LDWD LEADING DIMENSION OF ARRAY WD
|
||||
C ==> LD2WD SECOND DIMENSION OF ARRAY WD
|
||||
C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA)
|
||||
C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
|
||||
C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX
|
||||
C ==> JOB TASK TO BE PERFORMED
|
||||
C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FCN RESULTS
|
||||
C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR
|
||||
C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION
|
||||
C ==> PARTOL PARAMETER CONVERGENCE CRITERION
|
||||
C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS
|
||||
C ==> IPRINT PRINT CONTROL
|
||||
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
|
||||
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
|
||||
C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
|
||||
C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
|
||||
C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD
|
||||
C ==> SCLB SCALE VALUES FOR PARAMETERS BETA
|
||||
C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
|
||||
C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD
|
||||
C <==> WORK DOUBLE PRECISION WORK VECTOR
|
||||
C ==> LWORK DIMENSION OF VECTOR WORK
|
||||
C <== IWORK INTEGER WORK VECTOR
|
||||
C ==> LIWORK DIMENSION OF VECTOR IWORK
|
||||
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 LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=100,MAXNP=25,MAXNQ=5,
|
||||
+ LDY=MAXN,LDX=MAXN,
|
||||
+ LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
|
||||
+ LDIFX=MAXN,LDSCLD=1,LDSTPD=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,L,LUNERR,LUNRPT,M,MAXIT,N,
|
||||
+ NDIGIT,NP,NQ
|
||||
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
|
||||
DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
|
||||
DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
+ STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
|
||||
|
||||
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
|
||||
WE(1,1,1) = -1.0D0
|
||||
WD(1,1,1) = -1.0D0
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT3')
|
||||
|
||||
C READ PROBLEM DATA
|
||||
OPEN (UNIT=5,FILE='DATA3')
|
||||
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),(Y(I,L),L=1,NQ)
|
||||
10 CONTINUE
|
||||
|
||||
C SPECIFY TASK AS EXPLICIT ORTHOGONAL DISTANCE REGRESSION
|
||||
C WITH CENTRAL DIFFERENCE DERIVATIVES
|
||||
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
|
||||
C DELTA INITIALIZED BY USER
|
||||
C NOT A RESTART
|
||||
C AND INDICATE LONG INITIAL REPORT
|
||||
C NO ITERATION REPORTS
|
||||
C LONG FINAL REPORT
|
||||
JOB = 01010
|
||||
IPRINT = 2002
|
||||
|
||||
C INITIALIZE DELTA, AND SPECIFY FIRST DECADE OF FREQUENCIES AS FIXED
|
||||
DO 20 I=1,N
|
||||
IF (X(I,1).LT.100.0D0) THEN
|
||||
WORK(I) = 0.0D0
|
||||
IFIXX(I,1) = 0
|
||||
ELSE IF (X(I,1).LE.150.0D0) THEN
|
||||
WORK(I) = 0.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.1000.0D0) THEN
|
||||
WORK(I) = 25.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.10000.0D0) THEN
|
||||
WORK(I) = 560.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.100000.0D0) THEN
|
||||
WORK(I) = 9500.0D0
|
||||
IFIXX(I,1) = 1
|
||||
ELSE
|
||||
WORK(I) = 144000.0D0
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
20 CONTINUE
|
||||
|
||||
C SET WEIGHTS
|
||||
DO 30 I=1,N
|
||||
IF (X(I,1).EQ.100.0D0 .OR. X(I,1).EQ.150.0D0) THEN
|
||||
WE(I,1,1) = 0.0D0
|
||||
WE(I,1,2) = 0.0D0
|
||||
WE(I,2,1) = 0.0D0
|
||||
WE(I,2,2) = 0.0D0
|
||||
ELSE
|
||||
WE(I,1,1) = 559.6D0
|
||||
WE(I,1,2) = -1634.0D0
|
||||
WE(I,2,1) = -1634.0D0
|
||||
WE(I,2,2) = 8397.0D0
|
||||
END IF
|
||||
WD(I,1,1) = (1.0D-4)/(X(I,1)**2)
|
||||
30 CONTINUE
|
||||
|
||||
C COMPUTE SOLUTION
|
||||
CALL DODRC(FCN,
|
||||
+ N,M,NP,NQ,
|
||||
+ BETA,
|
||||
+ Y,LDY,X,LDX,
|
||||
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ JOB,NDIGIT,TAUFAC,
|
||||
+ SSTOL,PARTOL,MAXIT,
|
||||
+ IPRINT,LUNERR,LUNRPT,
|
||||
+ STPB,STPD,LDSTPD,
|
||||
+ SCLB,SCLD,LDSCLD,
|
||||
+ WORK,LWORK,IWORK,LIWORK,
|
||||
+ INFO)
|
||||
END
|
||||
|
||||
|
||||
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; ODRPACK SHOULD SELECT VALUES
|
||||
C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
|
||||
C -1 MEANS CURRENT BETA AND X+DELTA ARE
|
||||
C NOT ACCEPTABLE; ODRPACK SHOULD STOP
|
||||
|
||||
C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
|
||||
INTEGER I,IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
|
||||
C OUTPUT ARGUMENTS:
|
||||
DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
|
||||
C LOCAL VARIABLES
|
||||
DOUBLE PRECISION FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
|
||||
INTRINSIC ATAN2,EXP,SQRT
|
||||
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
DO 10 I=1,N
|
||||
IF (XPLUSD(I,1).LT.0.0D0) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ISTOP = 0
|
||||
|
||||
PI = 3.141592653589793238462643383279D0
|
||||
|
||||
THETA = PI*BETA(4)*0.5D0
|
||||
CTHETA = COS(THETA)
|
||||
STHETA = SIN(THETA)
|
||||
|
||||
C COMPUTE PREDICTED VALUES
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 100 I = 1,N
|
||||
FREQ = XPLUSD(I,1)
|
||||
OMEGA = (2.0D0*PI*FREQ*EXP(-BETA(3)))**BETA(4)
|
||||
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
|
||||
R = (BETA(1)-BETA(2)) *
|
||||
+ SQRT((1+OMEGA*CTHETA)**2+
|
||||
+ (OMEGA*STHETA)**2)**(-BETA(5))
|
||||
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
|
||||
F(I,2) = R*SIN(BETA(5)*PHI)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,203 @@
|
||||
*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 920304 (YYMMDD)
|
||||
C***PURPOSE DETERMINE 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, AND
|
||||
C 0 .LT. X(1).
|
||||
C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
|
||||
C EITHER
|
||||
C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY
|
||||
C REMOVING THE C FROM COLUMN 1
|
||||
C OR
|
||||
C SET B, TD AND TS USING I1MACH BY ACTIVATING
|
||||
C THE DECLARATION STATEMENTS FOR I1MACH
|
||||
C AND THE STATEMENTS PRECEEDING THE FIRST
|
||||
C EXECUTABLE STATEMENT BELOW.
|
||||
C***END PROLOGUE DPREC
|
||||
|
||||
C...LOCAL SCALARS
|
||||
DOUBLE PRECISION
|
||||
+ B
|
||||
INTEGER
|
||||
+ TD,TS
|
||||
|
||||
C...EXTERNAL FUNCTIONS
|
||||
C INTEGER
|
||||
C + I1MACH
|
||||
C EXTERNAL
|
||||
C + I1MACH
|
||||
|
||||
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
|
||||
|
||||
C DOUBLE PRECISION B
|
||||
C THE BASE OF THE TARGET MACHINE.
|
||||
C (MAY BE DEFINED USING I1MACH(10).)
|
||||
C INTEGER TD
|
||||
C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
|
||||
C (MAY BE DEFINED USING I1MACH(14).)
|
||||
C INTEGER TS
|
||||
C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
|
||||
C (MAY BE DEFINED USING I1MACH(11).)
|
||||
|
||||
|
||||
C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD
|
||||
C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC
|
||||
C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE
|
||||
C IBM PC AND THE AT&T 6300).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 60 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
|
||||
C THE BURROUGHS 6700/7700 SYSTEMS
|
||||
C DATA B / 8 /
|
||||
C DATA TS / 13 /
|
||||
C DATA TD / 26 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER)
|
||||
C THE CYBER 170/180 SERIES UNDER NOS
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 48 /
|
||||
C DATA TD / 96 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER)
|
||||
C THE CYBER 170/180 SERIES UNDER NOS/VE
|
||||
C THE CYBER 200 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 47 /
|
||||
C DATA TD / 94 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE CRAY
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 47 /
|
||||
C DATA TD / 94 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HARRIS COMPUTER
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 38 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
|
||||
C THE HONEYWELL 600/6000 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 63 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C (3 WORD DOUBLE PRECISION OPTION WITH FTN4)
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 39 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C (4 WORD DOUBLE PRECISION OPTION WITH FTN4)
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 55 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE IBM PC
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32
|
||||
C INTERDATA (PERKIN ELMER) 8/32
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 54 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 62 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 23 /
|
||||
C DATA TD / 47 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 27 /
|
||||
C DATA TD / 60 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 56 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING
|
||||
C DATA B / 2 /
|
||||
C DATA TS / 24 /
|
||||
C DATA TD / 53 /
|
||||
|
||||
C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9
|
||||
C DATA B / 16 /
|
||||
C DATA TS / 6 /
|
||||
C DATA TD / 14 /
|
||||
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT DMPREC
|
||||
|
||||
|
||||
C B = I1MACH(10)
|
||||
C TS = I1MACH(11)
|
||||
C TD = I1MACH(14)
|
||||
|
||||
DMPREC = B ** (1-TD)
|
||||
|
||||
RETURN
|
||||
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,14 @@
|
||||
12 1 3 1
|
||||
1500.0 -50.0 -0.1
|
||||
0.0 1265.0
|
||||
0.0 1263.6
|
||||
5.0 1258.0
|
||||
7.0 1254.0
|
||||
7.5 1253.0
|
||||
10.0 1249.8
|
||||
16.0 1237.0
|
||||
26.0 1218.0
|
||||
30.0 1220.6
|
||||
34.0 1213.8
|
||||
34.5 1215.5
|
||||
100.0 1212.0
|
||||
@@ -0,0 +1,22 @@
|
||||
20 2 5 1
|
||||
-1.0 -3.0 0.09 0.02 0.08
|
||||
0.50 -0.12
|
||||
1.20 -0.60
|
||||
1.60 -1.00
|
||||
1.86 -1.40
|
||||
2.12 -2.54
|
||||
2.36 -3.36
|
||||
2.44 -4.00
|
||||
2.36 -4.75
|
||||
2.06 -5.25
|
||||
1.74 -5.64
|
||||
1.34 -5.97
|
||||
0.90 -6.32
|
||||
-0.28 -6.44
|
||||
-0.78 -6.44
|
||||
-1.36 -6.41
|
||||
-1.90 -6.25
|
||||
-2.50 -5.88
|
||||
-2.88 -5.50
|
||||
-3.18 -5.24
|
||||
-3.44 -4.86
|
||||
@@ -0,0 +1,25 @@
|
||||
23 1 5 2
|
||||
4.0 2.0 7.0 0.40 0.50
|
||||
30.0 4.220 0.136
|
||||
50.0 4.167 0.167
|
||||
70.0 4.132 0.188
|
||||
100.0 4.038 0.212
|
||||
150.0 4.019 0.236
|
||||
200.0 3.956 0.257
|
||||
300.0 3.884 0.276
|
||||
500.0 3.784 0.297
|
||||
700.0 3.713 0.309
|
||||
1000.0 3.633 0.311
|
||||
1500.0 3.540 0.314
|
||||
2000.0 3.433 0.311
|
||||
3000.0 3.358 0.305
|
||||
5000.0 3.258 0.289
|
||||
7000.0 3.193 0.277
|
||||
10000.0 3.128 0.255
|
||||
15000.0 3.059 0.240
|
||||
20000.0 2.984 0.218
|
||||
30000.0 2.934 0.202
|
||||
50000.0 2.876 0.182
|
||||
70000.0 2.838 0.168
|
||||
100000.0 2.798 0.153
|
||||
150000.0 2.759 0.139
|
||||
@@ -0,0 +1,236 @@
|
||||
|
||||
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
|
||||
C ==> X Explanatory variable
|
||||
C ==> WE "Epsilon" weights
|
||||
C ==> WD "Delta" weights
|
||||
C ==> IFIXB Indicators for "fixing" parameters (BETA)
|
||||
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
|
||||
C ==> JOB Task to be performed
|
||||
C ==> NDIGIT Good digits in subroutine function results
|
||||
C ==> TAUFAC Trust region initialization factor
|
||||
C ==> SSTOL Sum of squares convergence criterion
|
||||
C ==> PARTOL Parameter convergence criterion
|
||||
C ==> MAXIT Maximum number of iterations
|
||||
C ==> IPRINT Print control
|
||||
c ==> LUNERR Logical unit for error reports
|
||||
C ==> LUNRPT Logical unit for computation reports
|
||||
C ==> STPB Step sizes for finite difference derivatives wrt BETA
|
||||
C ==> STPD Step sizes for finite difference derivatives wrt DELTA
|
||||
C ==> SCLB Scale values for parameters BETA
|
||||
C ==> SCLD Scale values for errors delta in explanatory variable
|
||||
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 LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
& LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=1,
|
||||
& LDY=MAXN,LDX=MAXN,
|
||||
& LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
|
||||
& LDIFX=MAXN,LDSTPD=1,LDSCLD=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,L,LUNERR,LUNRPT,M,MAXIT,N,
|
||||
& NDIGIT,NP,NQ
|
||||
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(:)
|
||||
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
|
||||
REAL (KIND=R8) BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
& STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
& 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 ODR arguments
|
||||
WE(1,1,1) = -1.0E0_R8
|
||||
WD(1,1,1) = -1.0E0_R8
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0E0_R8
|
||||
SSTOL = -1.0E0_R8
|
||||
PARTOL = -1.0E0_R8
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0E0_R8
|
||||
STPD(1,1) = -1.0E0_R8
|
||||
SCLB(1) = -1.0E0_R8
|
||||
SCLD(1,1) = -1.0E0_R8
|
||||
|
||||
C Set up ODRPACK95 report files
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT1')
|
||||
|
||||
C Read problem data, and set nondefault value for argument IFIXX
|
||||
OPEN (UNIT=5,FILE='DATA1')
|
||||
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),(Y(I,L),L=1,NQ)
|
||||
IF (X(I,1).EQ.0.0E0_R8 .OR. X(I,1).EQ.100.0E0_R8) THEN
|
||||
IFIXX(I,1) = 0
|
||||
ELSE
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
10 CONTINUE
|
||||
|
||||
C Specify task: Explicit orthogonal distance regression
|
||||
C With user supplied derivatives (checked)
|
||||
C Covariance matrix constructed with recomputed derivatives
|
||||
C Delta initialized to zero
|
||||
C Not a restart
|
||||
C And indicate short initial report
|
||||
C Short iteration reports every iteration, and
|
||||
C Long final report
|
||||
JOB = 00020
|
||||
IPRINT = 1112
|
||||
|
||||
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,
|
||||
& IFIXB=IFIXB,IFIXX=IFIXX,
|
||||
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
|
||||
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
|
||||
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
||||
& STPB=STPB,STPD=STPD,
|
||||
& SCLB=SCLB,SCLD=SCLD,
|
||||
& 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 Local variables
|
||||
INTRINSIC EXP
|
||||
|
||||
|
||||
C Do something with IFIXB and IFIXX to avoid warnings that they are not being
|
||||
C used. This is simply not to worry users that the example program is failing.
|
||||
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 ) THEN
|
||||
C Do nothing.
|
||||
END IF
|
||||
|
||||
|
||||
C Check for unacceptable values for this problem
|
||||
IF (BETA(1) .LT. 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(1) +
|
||||
& BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
END IF
|
||||
|
||||
C Compute derivatives with respect to BETA
|
||||
IF (MOD(IDEVAL/10,10).GE.1) THEN
|
||||
DO 210 L = 1,NQ
|
||||
DO 200 I = 1,N
|
||||
FJACB(I,1,L) = 1.0E0_R8
|
||||
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
|
||||
FJACB(I,3,L) = BETA(2)*2*
|
||||
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
|
||||
& EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
END IF
|
||||
|
||||
C Compute derivatives with respect to DELTA
|
||||
IF (MOD(IDEVAL/100,10).GE.1) THEN
|
||||
DO 310 L = 1,NQ
|
||||
DO 300 I = 1,N
|
||||
FJACD(I,1,L) = BETA(2)*2*
|
||||
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
|
||||
& EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,170 @@
|
||||
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
|
||||
@@ -0,0 +1,301 @@
|
||||
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
|
||||
C ==> X Explanatory variable
|
||||
C ==> WE "Epsilon" weights
|
||||
C ==> WD "Delta" weights
|
||||
C ==> IFIXB Indicators for "fixing" parameters (BETA)
|
||||
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
|
||||
C ==> JOB Task to be performed
|
||||
C ==> NDIGIT Good digits in subroutine fcn results
|
||||
C ==> TAUFAC Trust region initialization factor
|
||||
C ==> SSTOL Sum of squares convergence criterion
|
||||
C ==> PARTOL Parameter convergence criterion
|
||||
C ==> MAXIT Maximum number of iterations
|
||||
C ==> IPRINT Print control
|
||||
C ==> LUNERR Logical unit for error reports
|
||||
C ==> LUNRPT Logical unit for computation reports
|
||||
C ==> STPB Step sizes for finite difference derivatives wrt BETA
|
||||
C ==> STPD Step sizes for finite difference derivatives wrt DELTA
|
||||
C ==> SCLB Scale values for parameters BETA
|
||||
C ==> SCLD Scale values for errors DELTA in explanatory variable
|
||||
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 LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
|
||||
& LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
|
||||
PARAMETER (MAXM=5,MAXN=100,MAXNP=25,MAXNQ=5,
|
||||
& LDY=MAXN,LDX=MAXN,
|
||||
& LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
|
||||
& LDIFX=MAXN,LDSCLD=1,LDSTPD=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,L,LUNERR,LUNRPT,M,MAXIT,N,
|
||||
& NDIGIT,NP,NQ
|
||||
INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(:)
|
||||
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
|
||||
REAL (KIND=R8) BETA(MAXNP),DELTA(:,:),
|
||||
& SCLB(MAXNP),SCLD(LDSCLD,MAXM),
|
||||
& STPB(MAXNP),STPD(LDSTPD,MAXM),
|
||||
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
|
||||
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
|
||||
EXTERNAL FCN
|
||||
POINTER DELTA,IWORK,WORK
|
||||
|
||||
|
||||
C Specify default values for DODRC arguments
|
||||
WE(1,1,1) = -1.0E0_R8
|
||||
WD(1,1,1) = -1.0E0_R8
|
||||
IFIXB(1) = -1
|
||||
IFIXX(1,1) = -1
|
||||
JOB = -1
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0E0_R8
|
||||
SSTOL = -1.0E0_R8
|
||||
PARTOL = -1.0E0_R8
|
||||
MAXIT = -1
|
||||
IPRINT = -1
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0E0_R8
|
||||
STPD(1,1) = -1.0E0_R8
|
||||
SCLB(1) = -1.0E0_R8
|
||||
SCLD(1,1) = -1.0E0_R8
|
||||
|
||||
C Set up ODRPACK95 report files
|
||||
LUNERR = 9
|
||||
LUNRPT = 9
|
||||
OPEN (UNIT=9,FILE='REPORT3')
|
||||
|
||||
C Read problem data
|
||||
OPEN (UNIT=5,FILE='DATA3')
|
||||
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),(Y(I,L),L=1,NQ)
|
||||
10 CONTINUE
|
||||
|
||||
C Allocate work arrays
|
||||
ALLOCATE(DELTA(N,M),IWORK(LIWORK),WORK(LWORK))
|
||||
|
||||
C Specify task as explicit orthogonal distance regression
|
||||
C With central difference derivatives
|
||||
C Covariance matrix constructed with recomputed derivatives
|
||||
C DELTA initialized by user
|
||||
C Not a restart
|
||||
C And indicate long initial report
|
||||
C No iteration reports
|
||||
C Long final report
|
||||
JOB = 01010
|
||||
IPRINT = 2002
|
||||
|
||||
C Initialize DELTA, and specify first decade of frequencies as fixed
|
||||
DO 20 I=1,N
|
||||
IF (X(I,1).LT.100.0E0_R8) THEN
|
||||
DELTA(I,1) = 0.0E0_R8
|
||||
IFIXX(I,1) = 0
|
||||
ELSE IF (X(I,1).LE.150.0E0_R8) THEN
|
||||
DELTA(I,1) = 0.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.1000.0E0_R8) THEN
|
||||
DELTA(I,1) = 25.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.10000.0E0_R8) THEN
|
||||
DELTA(I,1) = 560.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE IF (X(I,1).LE.100000.0E0_R8) THEN
|
||||
DELTA(I,1) = 9500.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
ELSE
|
||||
DELTA(I,1) = 144000.0E0_R8
|
||||
IFIXX(I,1) = 1
|
||||
END IF
|
||||
20 CONTINUE
|
||||
|
||||
C Set weights
|
||||
DO 30 I=1,N
|
||||
IF (X(I,1).EQ.100.0E0_R8 .OR. X(I,1).EQ.150.0E0_R8) THEN
|
||||
WE(I,1,1) = 0.0E0_R8
|
||||
WE(I,1,2) = 0.0E0_R8
|
||||
WE(I,2,1) = 0.0E0_R8
|
||||
WE(I,2,2) = 0.0E0_R8
|
||||
ELSE
|
||||
WE(I,1,1) = 559.6E0_R8
|
||||
WE(I,1,2) = -1634.0E0_R8
|
||||
WE(I,2,1) = -1634.0E0_R8
|
||||
WE(I,2,2) = 8397.0E0_R8
|
||||
END IF
|
||||
WD(I,1,1) = (1.0E-4_R8)/(X(I,1)**2)
|
||||
30 CONTINUE
|
||||
|
||||
C Compute solution
|
||||
CALL ODR(FCN=FCN,
|
||||
& N=N,M=M,NP=NP,NQ=NQ,
|
||||
& BETA=BETA,
|
||||
& Y=Y,X=X,
|
||||
& DELTA=DELTA,
|
||||
& WE=WE,WD=WD,
|
||||
& IFIXB=IFIXB,IFIXX=IFIXX,
|
||||
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
|
||||
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
|
||||
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
|
||||
& STPB=STPB,STPD=STPD,
|
||||
& SCLB=SCLB,SCLD=SCLD,
|
||||
& 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,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 Local variables
|
||||
REAL (KIND=R8) FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
|
||||
INTRINSIC ATAN2,EXP,SQRT
|
||||
|
||||
|
||||
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
|
||||
DO 10 I=1,N
|
||||
IF (XPLUSD(I,1).LT.0.0E0_R8) THEN
|
||||
ISTOP = 1
|
||||
RETURN
|
||||
END IF
|
||||
10 CONTINUE
|
||||
ISTOP = 0
|
||||
|
||||
PI = 3.141592653589793238462643383279E0_R8
|
||||
|
||||
THETA = PI*BETA(4)*0.5E0_R8
|
||||
CTHETA = COS(THETA)
|
||||
STHETA = SIN(THETA)
|
||||
|
||||
C Compute predicted values
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 100 I = 1,N
|
||||
FREQ = XPLUSD(I,1)
|
||||
OMEGA = (2.0E0_R8*PI*FREQ*EXP(-BETA(3)))**BETA(4)
|
||||
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
|
||||
R = (BETA(1)-BETA(2)) *
|
||||
& SQRT((1+OMEGA*CTHETA)**2+
|
||||
& (OMEGA*STHETA)**2)**(-BETA(5))
|
||||
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
|
||||
F(I,2) = R*SIN(BETA(5)*PHI)
|
||||
100 CONTINUE
|
||||
END IF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,151 @@
|
||||
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
|
||||
C Symposium, "Estimating rate constants in cell cycle models"). The call to
|
||||
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
|
||||
C done to illustrate the need for bounds. The authors could just have easily
|
||||
C used the call statement here to solve their problem.
|
||||
C
|
||||
C Curious users are encouraged to remove the bounds in the call statement,
|
||||
C run the code, and compare the results to the current call statement.
|
||||
PROGRAM SAMPLE
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
IMPLICIT NONE
|
||||
C INTEGER :: I
|
||||
C REAL (KIND=R8) :: C, M, TOUT
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
|
||||
OPEN(9,FILE="REPORT4")
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ UPPER = (/ 1000.0_R8, 1000.0_R8, 1000.0_R8 /),
|
||||
+ IPRINT = 2122,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20
|
||||
+)
|
||||
CLOSE(9)
|
||||
C The following code will reproduce the plot in Figure 2 of Zwolak et
|
||||
C al. 2001.
|
||||
C DO I = 0, 100
|
||||
C C = 0.05+(0.7-0.05)*I/100
|
||||
C TOUT = 1440.0D0
|
||||
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
|
||||
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
|
||||
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
|
||||
C WRITE(*,*) C, TOUT
|
||||
C END DO
|
||||
END PROGRAM
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
! Local variables
|
||||
REAL(KIND=R8) :: MOUT
|
||||
INTEGER :: I
|
||||
ISTOP = 0
|
||||
FJACB(:,:,:) = 0.0E0_R8
|
||||
FJACD(:,:,:) = 0.0E0_R8
|
||||
IF ( MOD(IDEVAL,10).GE.1 ) THEN
|
||||
DO I = 1, N
|
||||
F(I,1) = 1440.0_R8
|
||||
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
|
||||
+ F(I,1),XPLUSD(I,1)/2)
|
||||
END DO
|
||||
END IF
|
||||
END SUBROUTINE FCN
|
||||
|
||||
C-------------------------------------------------------------------------------
|
||||
C
|
||||
C MPF
|
||||
C
|
||||
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
|
||||
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
|
||||
C the solution is printed every PRINT_EVERY time units or every H (which ever
|
||||
C is greater).
|
||||
C
|
||||
C This routine is not meant to be precise, it is only intended to be good
|
||||
C enough for providing a working example of ODRPACK95 with bounds. 4th order
|
||||
C Runge Kutta and linear interpolation are used for numerical integration and
|
||||
C root finding, respectively.
|
||||
C
|
||||
C M - MPF
|
||||
C C - Total Cyclin
|
||||
C KWEE, K25, K25P - Model parameters (BETA(1:3))
|
||||
C
|
||||
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), INTENT(OUT) :: M
|
||||
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
|
||||
+ PRINT_EVERY, ROOT
|
||||
REAL (KIND=R8), INTENT(INOUT) :: TOUT
|
||||
! Local variables
|
||||
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
|
||||
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
|
||||
REAL (KIND=R8) :: K1, K2, K3, K4
|
||||
INTERFACE
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
END FUNCTION
|
||||
END INTERFACE
|
||||
M = 0.0D0
|
||||
T = 0.0D0
|
||||
LAST_PRINT = 0.0D0
|
||||
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
|
||||
WRITE(*,*) T, M
|
||||
END IF
|
||||
DO WHILE ( T .LT. TOUT )
|
||||
LAST_T = T
|
||||
LAST_M = M
|
||||
K1 = H*DMDT(M,C,KWEE,K25,K25P)
|
||||
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
|
||||
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
|
||||
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
|
||||
M = M+(K1+2*K2+2*K3+K4)/6
|
||||
T = T + H
|
||||
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
|
||||
+ PRINT_EVERY .GT. 0.0D0 )
|
||||
+ THEN
|
||||
WRITE(*,*) T, M
|
||||
LAST_PRINT = T
|
||||
END IF
|
||||
IF ( ROOT .GT. 0.0D0 ) THEN
|
||||
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
|
||||
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
END SUBROUTINE MPF
|
||||
|
||||
|
||||
C Equation from Zwolak et al. 2001.
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
|
||||
END FUNCTION DMDT
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,108 @@
|
||||
# This makefile creates a library >> odrpack.a << comprised of both the single
|
||||
# and double precision versions of ODRPACK. It also runs each of the test
|
||||
# problems for both versions. Change S_SOURCE (D_SOURCE) and S_TESTS (D_TESTS)
|
||||
# as approprite if only the double precision (single precision) version is to
|
||||
# be installed.
|
||||
|
||||
# NB: This makefile creates a temporary subdirectory, >> ZodrpackZ <<, for
|
||||
# splitting and compiling the individual subprograms in each of the
|
||||
# release files. The makefile will fail if such a subdirectory already
|
||||
# exists. The subdirectory is automatically removed upon completion.
|
||||
|
||||
# Note also that some systems need to invoke ranlib, while others do not:
|
||||
# if your system lacks ranlib, simply comment out the ranlib invocation
|
||||
# below. Also, compiler names and options, and/or names of data files may
|
||||
# have to be modified for some systems.
|
||||
|
||||
|
||||
.SUFFIXES: .f .o .a .out
|
||||
F77 = f77 # specify compiler name as appropriate
|
||||
F77OPT = -u -O # specify desired compiler options here
|
||||
LIB = odrpack.a # specify ODRPACK library name
|
||||
DIR = ZodrpackZ # specify temporary subdirectory name
|
||||
L = # specify directory for library files
|
||||
|
||||
# Specify what files are to be installed, where
|
||||
# D_SOURCE = double-precision non-test source files
|
||||
# = d_odr.f d_lpkbls.f d_mprec.f
|
||||
# S_SOURCE = single-precision non-test source files
|
||||
# = s_odr.f s_lpkbls.f s_mprec.f
|
||||
D_SOURCE = d_odr.f d_lpkbls.f d_mprec.f
|
||||
S_SOURCE = s_odr.f s_lpkbls.f s_mprec.f
|
||||
|
||||
|
||||
|
||||
# Test installation...
|
||||
|
||||
tests: D_TESTS S_TESTS
|
||||
D_TESTS: d_drive1.out d_drive2.out d_drive3.out d_test.out
|
||||
S_TESTS: s_drive1.out s_drive2.out s_drive3.out s_test.out
|
||||
|
||||
|
||||
# Create ODRPACK library...
|
||||
|
||||
$(LIB): $(D_SOURCE) $(S_SOURCE)
|
||||
mkdir $(DIR)
|
||||
cd $(DIR) ;\
|
||||
for i in $? ;\
|
||||
do fsplit ../$$i ;\
|
||||
$(F77) -c $(F77OPT) *.f ;\
|
||||
ar ruv ../$@ *.o ;\
|
||||
rm *.f *.o ;\
|
||||
done ;\
|
||||
cd ..
|
||||
rm -rf $(DIR)
|
||||
ranlib $(LIB)
|
||||
|
||||
d_mprec.f: d_mprec0.f
|
||||
true # Obtain d_mprec.f from d_mprec0.f by activating the statements
|
||||
false # appropriate to your machine
|
||||
|
||||
s_mprec.f: s_mprec0.f
|
||||
true # Obtain s_mprec.f from s_mprec0.f by activating the statements
|
||||
false # appropriate to your machine
|
||||
|
||||
|
||||
# Run double-precision test problems...
|
||||
|
||||
d_drive1.out: d_drive1.f $(LIB) data1.dat
|
||||
cp data1.dat DATA1
|
||||
$(F77) d_drive1.f $(LIB) $L; a.out
|
||||
mv REPORT1 $@; rm -f DATA1 d_drive1.o a.out
|
||||
|
||||
d_drive2.out: d_drive2.f $(LIB) data2.dat
|
||||
cp data2.dat DATA2
|
||||
$(F77) d_drive2.f $(LIB) $L; a.out
|
||||
mv REPORT2 $@; rm -f DATA2 d_drive2.o a.out
|
||||
|
||||
d_drive3.out: d_drive3.f $(LIB) data3.dat
|
||||
cp data3.dat DATA3
|
||||
$(F77) d_drive3.f $(LIB) $L; a.out
|
||||
mv REPORT3 $@; rm -f DATA3 d_drive3.o a.out
|
||||
|
||||
d_test.out: d_test.f $(LIB)
|
||||
$(F77) d_test.f $(LIB) $L; a.out
|
||||
mv REPORT $@; cat SUMMARY >> $@; rm -f d_test.o a.out SUMMARY
|
||||
|
||||
|
||||
# Run single-precision test problems...
|
||||
|
||||
s_drive1.out: s_drive1.f $(LIB) data1.dat
|
||||
cp data1.dat DATA1
|
||||
$(F77) s_drive1.f $(LIB) $L; a.out
|
||||
mv REPORT1 $@; rm -f DATA1 s_drive1.o a.out
|
||||
|
||||
s_drive2.out: s_drive2.f $(LIB) data2.dat
|
||||
cp data2.dat DATA2
|
||||
$(F77) s_drive2.f $(LIB) $L; a.out
|
||||
mv REPORT2 $@; rm -f DATA2 s_drive2.o a.out
|
||||
|
||||
s_drive3.out: s_drive3.f $(LIB) data3.dat
|
||||
cp data3.dat DATA3
|
||||
$(F77) s_drive3.f $(LIB) $L; a.out
|
||||
mv REPORT3 $@; rm -f DATA3 s_drive3.o a.out
|
||||
|
||||
s_test.out: s_test.f $(LIB)
|
||||
$(F77) s_test.f $(LIB) $L; a.out
|
||||
mv REPORT $@; cat SUMMARY >> $@; rm -f s_test.o a.out SUMMARY
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,5 @@
|
||||
C From HOMPACK90.
|
||||
MODULE REAL_PRECISION
|
||||
C This is for 64-bit arithmetic.
|
||||
INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)
|
||||
END MODULE REAL_PRECISION
|
||||
@@ -0,0 +1,172 @@
|
||||
C
|
||||
C This example takes drive4.f and modifies it to stop ODRPACK95 and use the
|
||||
C restart facility. Run diff to see what additions were made.
|
||||
C
|
||||
|
||||
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
|
||||
C Symposium, "Estimating rate constants in cell cycle models"). The call to
|
||||
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
|
||||
C done to illustrate the need for bounds. The authors could just have easily
|
||||
C used the call statement here to solve their problem.
|
||||
C
|
||||
C Curious users are encouraged to remove the bounds in the call statement,
|
||||
C run the code, and compare the results to the current call statement.
|
||||
PROGRAM SAMPLE
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
IMPLICIT NONE
|
||||
INTEGER :: I
|
||||
REAL (KIND=R8) :: C, M, TOUT
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
|
||||
REAL(KIND=R8), POINTER :: WORK(:)
|
||||
INTEGER, POINTER :: IWORK(:)
|
||||
OPEN(9,FILE="REPORT_RESTART")
|
||||
WORK => NULL()
|
||||
IWORK => NULL()
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ IPRINT = 6666,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20,
|
||||
+ WORK = WORK,
|
||||
+ IWORK = IWORK
|
||||
+)
|
||||
WRITE(*,*) "Restarting ----------------------------------------"
|
||||
CALL ODR(
|
||||
+ FCN,
|
||||
+ N = 5, M = 1, NP = 3, NQ = 1,
|
||||
+ BETA = BETA,
|
||||
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
|
||||
+ (/5,1/)),
|
||||
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
|
||||
+ IPRINT = 6666,
|
||||
+ LUNRPT = 9,
|
||||
+ MAXIT = 20,
|
||||
+ WORK = WORK,
|
||||
+ IWORK = IWORK,
|
||||
+ JOB = 10000
|
||||
+)
|
||||
CLOSE(9)
|
||||
C The following code will reproduce the plot in Figure 2 of Zwolak et
|
||||
C al. 2001.
|
||||
C DO I = 0, 100
|
||||
C C = 0.05+(0.7-0.05)*I/100
|
||||
C TOUT = 1440.0D0
|
||||
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
|
||||
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
|
||||
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
|
||||
C WRITE(*,*) C, TOUT
|
||||
C END DO
|
||||
END PROGRAM
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
|
||||
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
IMPLICIT NONE
|
||||
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
|
||||
INTEGER, INTENT(OUT) :: ISTOP
|
||||
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
|
||||
+ FJACD(LDN,LDM,NQ)
|
||||
! Local variables
|
||||
REAL(KIND=R8) :: MOUT
|
||||
INTEGER :: I
|
||||
ISTOP = 0
|
||||
FJACB(:,:,:) = 0.0E0_R8
|
||||
FJACD(:,:,:) = 0.0E0_R8
|
||||
IF ( MOD(IDEVAL,10).GE.1 ) THEN
|
||||
DO I = 1, N
|
||||
F(I,1) = 1440.0_R8
|
||||
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
|
||||
+ F(I,1),XPLUSD(I,1)/2)
|
||||
END DO
|
||||
END IF
|
||||
END SUBROUTINE FCN
|
||||
|
||||
C-------------------------------------------------------------------------------
|
||||
C
|
||||
C MPF
|
||||
C
|
||||
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
|
||||
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
|
||||
C the solution is printed every PRINT_EVERY time units or every H (which ever
|
||||
C is greater).
|
||||
C
|
||||
C This routine is not meant to be precise, it is only intended to be good
|
||||
C enough for providing a working example of ODRPACK95 with bounds. 4th order
|
||||
C Runge Kutta and linear interpolation are used for numerical integration and
|
||||
C root finding, respectively.
|
||||
C
|
||||
C M - MPF
|
||||
C C - Total Cyclin
|
||||
C KWEE, K25, K25P - Model parameters (BETA(1:3))
|
||||
C
|
||||
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), INTENT(OUT) :: M
|
||||
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
|
||||
+ PRINT_EVERY, ROOT
|
||||
REAL (KIND=R8), INTENT(INOUT) :: TOUT
|
||||
! Local variables
|
||||
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
|
||||
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
|
||||
REAL (KIND=R8) :: K1, K2, K3, K4, DMDT
|
||||
M = 0.0D0
|
||||
T = 0.0D0
|
||||
LAST_PRINT = 0
|
||||
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
|
||||
WRITE(*,*) T, M
|
||||
END IF
|
||||
DO WHILE ( T .LT. TOUT )
|
||||
LAST_T = T
|
||||
LAST_M = M
|
||||
K1 = H*DMDT(M,C,KWEE,K25,K25P)
|
||||
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
|
||||
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
|
||||
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
|
||||
M = M+(K1+2*K2+2*K3+K4)/6
|
||||
T = T + H
|
||||
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
|
||||
+ PRINT_EVERY .GT. 0.0D0 )
|
||||
+ THEN
|
||||
WRITE(*,*) T, M
|
||||
LAST_PRINT = LAST_PRINT + PRINT_EVERY
|
||||
END IF
|
||||
IF ( ROOT .GT. 0.0D0 ) THEN
|
||||
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
|
||||
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
|
||||
RETURN
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
END SUBROUTINE MPF
|
||||
|
||||
|
||||
C Equation from Zwolak et al. 2001.
|
||||
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
|
||||
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
|
||||
END FUNCTION DMDT
|
||||
@@ -0,0 +1,66 @@
|
||||
PROGRAM ODRPACK95_EXAMPLE
|
||||
USE ODRPACK95
|
||||
USE REAL_PRECISION
|
||||
REAL (KIND=R8), ALLOCATABLE :: BETA(:),L(:),U(:),X(:,:),Y(:,:)
|
||||
INTEGER :: NP,N,M,NQ
|
||||
INTERFACE
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
|
||||
IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
USE REAL_PRECISION
|
||||
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
|
||||
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
|
||||
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
END SUBROUTINE FCN
|
||||
END INTERFACE
|
||||
|
||||
NP = 2
|
||||
N = 4
|
||||
M = 1
|
||||
NQ = 1
|
||||
ALLOCATE(BETA(NP),L(NP),U(NP),X(N,M),Y(N,NQ))
|
||||
BETA(1:2) = (/ 2.0_R8, 0.5_R8 /)
|
||||
L(1:2) = (/ 0.0_R8, 0.0_R8 /)
|
||||
U(1:2) = (/ 10.0_R8, 0.9_R8 /)
|
||||
X(1:4,1) = (/ 0.982_R8, 1.998_R8, 4.978_R8, 6.01_R8 /)
|
||||
Y(1:4,1) = (/ 2.7_R8, 7.4_R8, 148.0_R8, 403.0_R8 /)
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,LOWER=L,UPPER=U)
|
||||
END PROGRAM ODRPACK95_EXAMPLE
|
||||
|
||||
|
||||
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
|
||||
IDEVAL,F,FJACB,FJACD,ISTOP)
|
||||
|
||||
USE REAL_PRECISION
|
||||
|
||||
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ, I
|
||||
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
|
||||
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
|
||||
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
|
||||
|
||||
ISTOP = 0
|
||||
|
||||
! Calculate model.
|
||||
IF (MOD(IDEVAL,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
! Calculate model partials with respect to BETA.
|
||||
IF (MOD(IDEVAL/10,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
|
||||
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
! Calculate model partials with respect to DELTA.
|
||||
IF (MOD(IDEVAL/100,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
|
||||
END SUBROUTINE FCN
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,241 @@
|
||||
*TESTER
|
||||
PROGRAM TESTER
|
||||
C***BEGIN PROLOGUE TESTER
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED ODR
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE EXCERCISE ERROR REPORTING OF THE F90 VERSION OF ODRPACK95
|
||||
C***END PROLOGUE TESTER
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
USE ODRPACK95
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER N, M, NQ, NP, INFO, LUN
|
||||
C STAT
|
||||
|
||||
C...LOCAL ARRAYS
|
||||
REAL (KIND=R8)
|
||||
& BETA(:),Y(:,:),X(:,:),UPPER(2),LOWER(2)
|
||||
|
||||
C...ALLOCATABLE ARRAYS
|
||||
ALLOCATABLE BETA,Y,X
|
||||
|
||||
C...EXTERNAL SUBPROGRAMS
|
||||
EXTERNAL FCN
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT TESTER
|
||||
|
||||
OPEN(UNIT=8,FILE="SUMMARY")
|
||||
WRITE(8,*) "NO SUMMARY AVAILABLE"
|
||||
CLOSE(8)
|
||||
|
||||
LUN = 9
|
||||
OPEN(UNIT=LUN,FILE="REPORT")
|
||||
|
||||
C ERROR IN PROBLEM SIZE
|
||||
|
||||
N = 0
|
||||
M = 0
|
||||
NQ = 0
|
||||
NP = 0
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH WORK AND IWORK
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=10000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN JOB SPECIFICATION WITH DELTA
|
||||
|
||||
N = 1
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 1
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
Y(:,:) = 0.0_R8
|
||||
X(:,:) = 0.0_R8
|
||||
BETA(:) = 0.0_R8
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=1000,
|
||||
& LUNRPT=LUN,LUNERR=LUN)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C BOUNDS TOO SMALL FOR DERIVATIVE CHECKER WHEN DERIVATIVES DON'T AGREE.
|
||||
|
||||
N = 4
|
||||
M = 1
|
||||
NQ = 1
|
||||
NP = 2
|
||||
DEALLOCATE(BETA,Y,X)
|
||||
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
|
||||
BETA(:) = (/ -200.0_R8, -5.0_R8 /)
|
||||
UPPER(1:2) = (/ -200.0_R8, 0.0_R8 /)
|
||||
LOWER(1:2) = (/ -200.000029802322_R8, -5.0_R8 /)
|
||||
Y(:,1) = (/ 2.718281828459045_R8, 7.389056098930650_R8,
|
||||
&148.4131591025766_R8, 403.4287934927353_R8 /)
|
||||
X(:,1) = (/ 1.0_R8, 2.0_R8, 5.0_R8, 6.0_R8 /)
|
||||
|
||||
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=0020,
|
||||
& LUNRPT=LUN,LUNERR=LUN,LOWER=LOWER,UPPER=UPPER)
|
||||
|
||||
WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
C ERROR IN ARRAY ALLOCATION
|
||||
C The following code is intended to force memory allocation failure. An
|
||||
C appropriate N for your machine must be chosen to ensure memory allocation
|
||||
C will fail within ODRPACK95. A value of about 1/4 the total memory available
|
||||
C to a process should do the trick. However, most modern operating systems and
|
||||
C Fortran compilers will not likely deny ODRPACK95 memory before they fail for
|
||||
C another reason. Therefore, the memory allocation checks in ODRPACK95 are not
|
||||
C easy to provoke. An operating system may return successfull memory
|
||||
C allocation but fail to guarantee the memory causing a segfault when some
|
||||
C memory locations are accessed. A Fortran compiler or operating system may
|
||||
C allow limited sized stacks during subroutine invocation causing the ODRPACK95
|
||||
C call to fail before ODRPACK95 executes its first line.
|
||||
C
|
||||
C N = 032000000
|
||||
C M = 1
|
||||
C NQ = 1
|
||||
C NP = 1
|
||||
C DEALLOCATE(BETA,Y,X)
|
||||
C ALLOCATE(BETA(NP),Y(N,NQ),X(N,M),STAT=STAT)
|
||||
C IF (STAT.NE.0) THEN
|
||||
C WRITE(0,*)
|
||||
C & "SYSTEM ERROR: COULD NOT ALLOCATE MEMORY, TESTER ",
|
||||
C & "FAILED TO RUN."
|
||||
C STOP
|
||||
C END IF
|
||||
C Y(:,:) = 0.0_R8
|
||||
C X(:,:) = 0.0_R8
|
||||
C BETA(:) = 0.0_R8
|
||||
C
|
||||
C CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
|
||||
C & LUNRPT=LUN,LUNERR=LUN)
|
||||
C
|
||||
C WRITE(LUN,*) "INFO = ", INFO
|
||||
|
||||
CLOSE(LUN)
|
||||
|
||||
END PROGRAM
|
||||
*FCN
|
||||
SUBROUTINE FCN
|
||||
& (N,M,NP,NQ,
|
||||
& LDN,LDM,LDNP,
|
||||
& BETA,XPLUSD,
|
||||
& IFIXB,IFIXX,LDIFX,
|
||||
& IDEVAL,F,FJACB,FJACD,
|
||||
& ISTOP)
|
||||
C***BEGIN PROLOGUE FCN
|
||||
C***REFER TO ODR
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***DATE WRITTEN 20040322 (YYYYMMDD)
|
||||
C***REVISION DATE 20040322 (YYYYMMDD)
|
||||
C***PURPOSE DUMMY ROUTINE FOR ODRPACK95 ERROR EXERCISER
|
||||
C***END PROLOGUE FCN
|
||||
|
||||
C...USED MODULES
|
||||
USE REAL_PRECISION
|
||||
|
||||
C...SCALAR ARGUMENTS
|
||||
INTEGER
|
||||
& IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
|
||||
|
||||
C...ARRAY ARGUMENTS
|
||||
REAL (KIND=R8)
|
||||
& BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ),
|
||||
& XPLUSD(LDN,M)
|
||||
INTEGER
|
||||
& IFIXB(NP),IFIXX(LDIFX,M)
|
||||
|
||||
C...ARRAYS IN COMMON
|
||||
REAL (KIND=R8)
|
||||
& LOWER(2),UPPER(2)
|
||||
|
||||
C...LOCAL SCALARS
|
||||
INTEGER
|
||||
& I
|
||||
|
||||
COMMON /BOUNDS/ UPPER,LOWER
|
||||
|
||||
|
||||
C***FIRST EXECUTABLE STATEMENT
|
||||
|
||||
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
|
||||
|
||||
|
||||
IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "LOWER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (LOWER(I).GT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& "<", LOWER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN
|
||||
WRITE(0,*) "UPPER BOUNDS VIOLATED"
|
||||
DO I=1,NP
|
||||
IF (UPPER(I).LT.BETA(I)) THEN
|
||||
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
|
||||
& ">", UPPER(I)
|
||||
END IF
|
||||
END DO
|
||||
END IF
|
||||
|
||||
ISTOP = 0
|
||||
|
||||
IF (MOD(IDEVAL,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/10,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
|
||||
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*
|
||||
& XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
IF (MOD(IDEVAL/100,10).NE.0) THEN
|
||||
DO I=1,N
|
||||
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
|
||||
END DO
|
||||
END IF
|
||||
|
||||
END SUBROUTINE
|
||||
Reference in New Issue
Block a user