Initial commit
This commit is contained in:
@@ -0,0 +1,274 @@
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
!
|
||||
subroutine odr_recthypb(npoints,nparams,yobs,xobs,
|
||||
& a,b,c,d,root,der_root,fmax,rms,INFO)
|
||||
implicit none
|
||||
c
|
||||
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=25,MAXN=10000,MAXNP=30,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)
|
||||
c
|
||||
integer npoints,i1,i2,i3,i4,i5,iwrong,nparams
|
||||
double precision yobs(npoints),xobs(npoints),
|
||||
& a,b,c,d,root,der_root,fmax,ypred(npoints),rms,
|
||||
& rsq,agrind
|
||||
|
||||
EXTERNAL FCN_rhb
|
||||
c
|
||||
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 = 00023
|
||||
JOB=43
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
! IPRINT = -1
|
||||
IPRINT=0
|
||||
LUNERR = -1
|
||||
LUNRPT = -1
|
||||
STPB(1) = -1.0D0
|
||||
STPD(1,1) = -1.0D0
|
||||
SCLB(1) = -1.0D0
|
||||
SCLD(1,1) = -1.0D0
|
||||
|
||||
MAXIT = 200000
|
||||
C SET UP ODRPACK REPORT FILES
|
||||
LUNERR = 107
|
||||
LUNRPT = 108
|
||||
c
|
||||
N=npoints
|
||||
NP=nparams
|
||||
M=1
|
||||
NQ=1
|
||||
BETA(1)=a
|
||||
BETA(2)=b
|
||||
BETA(3)=c
|
||||
if(NP.eq.4)BETA(4)=d
|
||||
|
||||
do I=1,N
|
||||
X(I,1)=xobs(I)
|
||||
Y(I,1)=yobs(I)
|
||||
enddo
|
||||
NQ=1
|
||||
|
||||
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
|
||||
DO 10 I=1,N
|
||||
DO 15 J=1, M
|
||||
IFIXX(I,J) = 1
|
||||
15 CONTINUE
|
||||
10 CONTINUE
|
||||
60 CALL DODRC(FCN_rhb,
|
||||
+ 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)
|
||||
i1=mod(INFO,10)
|
||||
i2=(mod(INFO,100)-i1)/10
|
||||
i3=(mod(INFO,1000)-mod(INFO,100))/100
|
||||
i4=(mod(INFO,10000)-mod(INFO,1000))/1000
|
||||
i5=(INFO-mod(INFO,10000))/10000
|
||||
a=BETA(1)
|
||||
b=BETA(2)
|
||||
c=BETA(3)
|
||||
if(NP.eq.4)then
|
||||
d=BETA(4)
|
||||
do I=1,N
|
||||
call fnonrecthypb(a,b,c,d,xobs(I),ypred(I),
|
||||
& iwrong)
|
||||
if(iwrong.eq.1)then
|
||||
INFO=6
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
call indices_fnonrecthypb(a,b,c,d,root,
|
||||
& der_root,fmax,iwrong)
|
||||
if(iwrong.eq.1)then
|
||||
INFO=6
|
||||
return
|
||||
endif
|
||||
else
|
||||
do I=1,N
|
||||
call recthypb(a,b,c,xobs(I),ypred(I))
|
||||
enddo
|
||||
call indices_frecthypb(a,b,c,root,
|
||||
& der_root,fmax)
|
||||
endif
|
||||
call rsq_rms(yobs,ypred,N,rsq,rms,agrind)
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE FCN_rhb(N,M,NP,NQ,
|
||||
+ LDN,LDM,LDNP,
|
||||
+ BETA,XPLUSD,
|
||||
+ IFIXB,IFIXX,LDIFX,
|
||||
+ IDEVAL,F,FJACB,FJACD,
|
||||
+ ISTOP)
|
||||
implicit none
|
||||
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)
|
||||
double precision a,b,c,d,x,da,db,dc,dd,dx,yvalue
|
||||
integer iwrong
|
||||
|
||||
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
|
||||
c
|
||||
!
|
||||
IF (MOD(IDEVAL,10).GE.1) THEN
|
||||
DO 110 L = 1,NQ
|
||||
DO 100 I = 1,N
|
||||
a=BETA(1)
|
||||
b=BETA(2)
|
||||
c=BETA(3)
|
||||
x=XPLUSD(I,1)
|
||||
if(NP.eq.4)then
|
||||
d=BETA(4)
|
||||
call fnonrecthypb(a,b,c,d,x,yvalue,iwrong)
|
||||
if(iwrong.eq.1)then
|
||||
ISTOP=1
|
||||
return
|
||||
endif
|
||||
else
|
||||
call recthypb(a,b,c,x,yvalue)
|
||||
endif
|
||||
F(I,L)=yvalue
|
||||
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
|
||||
a=BETA(1)
|
||||
b=BETA(2)
|
||||
c=BETA(3)
|
||||
x=XPLUSD(I,1)
|
||||
if(NP.eq.4)then
|
||||
d=BETA(4)
|
||||
call der_fnonrecthypb(a,b,c,d,x,da,db,
|
||||
& dc,dd,dx,iwrong)
|
||||
if(iwrong.eq.1)then
|
||||
ISTOP=1
|
||||
return
|
||||
endif
|
||||
FJACB(I,4,L)=dd
|
||||
else
|
||||
call der_recthypb(a,b,c,x,da,db,dc,dx)
|
||||
endif
|
||||
FJACB(I,1,L)=da
|
||||
FJACB(I,2,L)=db
|
||||
FJACB(I,3,L)=dc
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
@@ -0,0 +1,124 @@
|
||||
!-----------4 parameters---------------------------------
|
||||
! Non-rectangular hyperbola function and derivatives
|
||||
! y=a+b(x-sqrt(c+dx+x2)) or y=(ax+b-sqrt((ax+b)^2-4abcx))/2c-d
|
||||
!
|
||||
subroutine fnonrecthypb(a,b,c,d,x,y,iwrong)
|
||||
implicit none
|
||||
integer iwrong
|
||||
double precision a,b,c,d,x,y,p
|
||||
iwrong=0
|
||||
goto 10
|
||||
!----------------------------------------
|
||||
!a=alpha, b=Amax, c=theta, d=rd
|
||||
p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
y=(a*x+b-dsqrt(p))/(2.0d0*c)-d
|
||||
return
|
||||
!----------------------------------------
|
||||
10 p=c+d*x+x*x
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
y=a+b*(x-dsqrt(p))
|
||||
return
|
||||
end
|
||||
|
||||
subroutine indices_fnonrecthypb(a,b,c,d,root,
|
||||
& der_root,fmax,iwrong)
|
||||
implicit none
|
||||
double precision a,b,c,d,root,der_root,fmax,p
|
||||
integer iwrong
|
||||
iwrong=0
|
||||
goto 10
|
||||
!---------------------------
|
||||
root=(c*d*d-b*d)/(a*d-a*b)
|
||||
fmax=b
|
||||
p=(a*root+b)*(a*root+b)-4.0d0*a*b*c*root
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
der_root=(a-a*(a*root+b-2.0d0*b*c)/dsqrt(p))
|
||||
& /(2.0d0*c)
|
||||
return
|
||||
!------------------------------
|
||||
10 root=(b*b*c-a*a)/(2.0d0*a*b-b*b*d)
|
||||
fmax=a-0.5d0*b*d
|
||||
p=root*root+d*root+c
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
der_root=b*(1.0d0-(2.0d0*root+d)/
|
||||
& (2.0d0*dsqrt(p)))
|
||||
return
|
||||
end
|
||||
|
||||
subroutine der_fnonrecthypb(a,b,c,d,x,da,db,dc,dd,dx,
|
||||
& iwrong)
|
||||
implicit none
|
||||
integer iwrong
|
||||
double precision a,b,c,d,x,da,db,dc,dd,dx
|
||||
double precision p
|
||||
iwrong=0
|
||||
goto 10
|
||||
!-----------------------------------------
|
||||
p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
p=dsqrt(p)
|
||||
da=(x-x*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c)
|
||||
db=(1.0d0-(a*x+b-2.0d0*a*c*x)/p)/(2.0d0*c)
|
||||
dd=-1.0d0
|
||||
dc=a*b*x/(c*p)-(a*x+b-p)/(2.0d0*c*c)
|
||||
dx=(a-a*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c)
|
||||
return
|
||||
!------------------------------------------
|
||||
10 p=c+d*x+x*x
|
||||
if(p.lt.0.0d0)then
|
||||
iwrong=1
|
||||
return
|
||||
endif
|
||||
p=dsqrt(p)
|
||||
da=1.0d0
|
||||
db=x-p
|
||||
dc=-b/(2.0d0*p)
|
||||
dd=dc*x
|
||||
dx=b*(1.0d0-(d+2.0d0*x)/(2.0d0*p))
|
||||
return
|
||||
end
|
||||
|
||||
!-------3 parameters----------------------
|
||||
subroutine recthypb(a,b,c,x,y)
|
||||
implicit none
|
||||
double precision a,b,c,x,y
|
||||
y=(a*x+b)/(x+c)
|
||||
return
|
||||
end
|
||||
|
||||
subroutine indices_frecthypb(a,b,c,root,
|
||||
& der_root,fmax)
|
||||
implicit none
|
||||
double precision a,b,c,root,
|
||||
& der_root,fmax
|
||||
root=-b/a
|
||||
der_root=a*a/(a*c-b)
|
||||
fmax=a
|
||||
return
|
||||
end
|
||||
|
||||
subroutine der_recthypb(a,b,c,x,da,db,dc,dx)
|
||||
implicit none
|
||||
double precision a,b,c,x,da,db,dc,dx
|
||||
da=x/(x+c)
|
||||
db=1.0d0/(x+c)
|
||||
dc=-(a*x+b)/((x+c)*(x+c))
|
||||
dx=a/(x+c)-(a*x+b)/((x+c)*(x+c))
|
||||
return
|
||||
end
|
||||
Reference in New Issue
Block a user