Initial commit
This commit is contained in:
@@ -0,0 +1,428 @@
|
||||
|
||||
program main
|
||||
implicit none
|
||||
double precision x(1000),y(1000),dx(1000),dy(1000),
|
||||
* slope,fintcpt,rtmnsquare,xoutliers(100),youtliers(1000),
|
||||
* x1(1000),y1(1000),k,b,sum1,sum2
|
||||
integer nsamp,i,numoutliers,nsamp1
|
||||
|
||||
open(unit=1,file='testdata.txt')
|
||||
i=1
|
||||
10 read(1,*,end=100)x(i),y(i)
|
||||
i=i+1
|
||||
goto 10
|
||||
100 nsamp=i-1
|
||||
|
||||
goto 200
|
||||
|
||||
|
||||
nsamp=13
|
||||
x(1)=-1.0d0
|
||||
y(1)=3.0d0
|
||||
x(2)=-3.0d0
|
||||
y(2)=4.0d0
|
||||
x(3)=-5.0d0
|
||||
y(3)=5.0d0
|
||||
x(4)=-7.0d0
|
||||
y(4)=6.0d0
|
||||
x(5)=-9.0d0
|
||||
y(5)=7.0d0
|
||||
x(6)=-11.0d0
|
||||
y(6)=8.0d0
|
||||
x(7)=-3.0d0
|
||||
y(7)=1.0d0
|
||||
x(8)=-5.0d0
|
||||
y(8)=2.0d0
|
||||
x(9)=-7.0d0
|
||||
y(9)=3.0d0
|
||||
x(10)=-9.0d0
|
||||
y(10)=4.0d0
|
||||
x(11)=-11.0d0
|
||||
y(11)=5.0d0
|
||||
x(12)=-4.0d0
|
||||
y(12)=7.0d0
|
||||
x(13)=-12.0d0
|
||||
y(13)=1.0d0
|
||||
|
||||
200 slope=-2.0d0
|
||||
fintcpt=0.0d0
|
||||
|
||||
call OrthSoilRespRegres(nsamp,x,y,slope,fintcpt)
|
||||
write(*,*)slope,fintcpt
|
||||
pause
|
||||
|
||||
slope=-2.0d0
|
||||
fintcpt=0.0d0
|
||||
|
||||
call orthlinreg_outlier(nsamp,x,y,slope,
|
||||
& fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers,
|
||||
& numoutliers)
|
||||
write(*,*)slope/2.0d0,fintcpt,numoutliers
|
||||
do i=1,numoutliers
|
||||
write(*,*)xoutliers(i),youtliers(i)
|
||||
enddo
|
||||
end
|
||||
|
||||
subroutine orthlinreg_outlier(nsamp0,x0,y0,slope,
|
||||
& fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers,
|
||||
& numoutliers)
|
||||
implicit none
|
||||
integer nsamp0,numoutliers
|
||||
double precision x0(nsamp0),y0(nsamp0),slope,
|
||||
& fintcpt,dx(nsamp0),dy(nsamp0),rtmnsquare,
|
||||
& xoutliers(nsamp0),youtliers(nsamp0),xtest(nsamp0),
|
||||
& ytest(nsamp0),slopetest,fintcpttest,dxtest(nsamp0),
|
||||
& dytest(nsamp0),rtmnsquaretest,testmeasure(nsamp0),
|
||||
& x(nsamp0),y(nsamp0)
|
||||
|
||||
integer iwhichside,nsamptest,isitoutlier,
|
||||
& isoutlier_1side,i,j,nsamp
|
||||
parameter (iwhichside=1)
|
||||
|
||||
numoutliers=0
|
||||
nsamp=nsamp0
|
||||
do i=1,nsamp
|
||||
x(i)=x0(i)
|
||||
y(i)=y0(i)
|
||||
enddo
|
||||
|
||||
50 call orthlinreg(nsamp,x,y,slope,fintcpt,
|
||||
& dx,dy,rtmnsquare)
|
||||
|
||||
write(*,*)slope,fintcpt,rtmnsquare
|
||||
stop
|
||||
nsamptest=nsamp-1
|
||||
do i=1,nsamp
|
||||
do j=1,nsamp
|
||||
xtest(j)=x(j)
|
||||
ytest(j)=y(j)
|
||||
enddo
|
||||
xtest(i)=x(nsamp)
|
||||
ytest(i)=y(nsamp)
|
||||
call orthlinreg(nsamptest,xtest,ytest,slopetest,
|
||||
& fintcpttest,dxtest,dytest,rtmnsquaretest)
|
||||
! write(*,*)i,slopetest,fintcpttest
|
||||
|
||||
! testmeasure(i)=(slopetest-slope)**2+
|
||||
! & (fintcpttest-fintcpt)**2
|
||||
|
||||
testmeasure(i)=100.0d0*dabs(rtmnsquaretest-rtmnsquare)/
|
||||
& rtmnsquare
|
||||
! write(*,*)i,testmeasure(i)
|
||||
enddo
|
||||
|
||||
isitoutlier=isoutlier_1side(nsamp,testmeasure,iwhichside)
|
||||
if(isitoutlier.lt.1.or.isitoutlier.gt.nsamp)return
|
||||
! outlier detected
|
||||
numoutliers=numoutliers+1
|
||||
xoutliers(numoutliers)=x(isitoutlier)
|
||||
youtliers(numoutliers)=y(isitoutlier)
|
||||
x(isitoutlier)=x(nsamp)
|
||||
y(isitoutlier)=y(nsamp)
|
||||
nsamp=nsamp-1
|
||||
if(nsamp.le.2)then
|
||||
write(*,*)'No enough good data left'
|
||||
stop
|
||||
endif
|
||||
goto 50
|
||||
return
|
||||
end
|
||||
|
||||
! orthogonal linear regression
|
||||
subroutine orthlinreg(nsamp,x,y,slope0,fintcpt0,
|
||||
& dx,dy,rtmnsquare)
|
||||
implicit none
|
||||
integer nsamp
|
||||
double precision x(nsamp),y(nsamp),dx1(nsamp),
|
||||
& dy1(nsamp),slope(2),fintcpt(2),dx2(nsamp),
|
||||
& dy2(nsamp),slope0,fintcpt0,dx(nsamp),dy(nsamp)
|
||||
integer i,j
|
||||
double precision w,u,v,xbar,ybar,root1,root2,
|
||||
& a,b,c,rtmnsquare1,rtmnsquare2,rtmnsquare
|
||||
|
||||
|
||||
|
||||
xbar=0.0d0
|
||||
ybar=0.0d0
|
||||
w=0.0d0
|
||||
u=0.0d0
|
||||
v=0.0d0
|
||||
do i=1,nsamp
|
||||
xbar=xbar+x(i)
|
||||
ybar=ybar+y(i)
|
||||
w=w+x(i)*x(i)
|
||||
u=u+y(i)*y(i)
|
||||
v=v+x(i)*y(i)
|
||||
enddo
|
||||
xbar=xbar/dble(nsamp)
|
||||
ybar=ybar/dble(nsamp)
|
||||
w=w/dble(nsamp)
|
||||
u=u/dble(nsamp)
|
||||
v=v/dble(nsamp)
|
||||
a=v-xbar*ybar
|
||||
b=w-u-xbar*xbar+ybar*ybar
|
||||
c=xbar*ybar-v
|
||||
call quadraticroots(a,b,c,root1,root2)
|
||||
slope(1)=root1
|
||||
slope(2)=root2
|
||||
fintcpt(1)=ybar-slope(1)*xbar
|
||||
fintcpt(2)=ybar-slope(2)*xbar
|
||||
rtmnsquare1=0.0d0
|
||||
rtmnsquare2=0.0d0
|
||||
do i=1,nsamp
|
||||
dx1(i)=(y(i)-fintcpt(1)-x(i)*slope(1))*
|
||||
& slope(1)/(1.0d0+slope(1)*slope(1))
|
||||
dy1(i)=-(y(i)-fintcpt(1)-x(i)*slope(1))/
|
||||
& (1.0d0+slope(1)*slope(1))
|
||||
rtmnsquare1=rtmnsquare1+dx1(i)**2+dy1(i)**2
|
||||
|
||||
dx2(i)=(y(i)-fintcpt(2)-x(i)*slope(2))*
|
||||
& slope(2)/(1.0d0+slope(2)*slope(2))
|
||||
dy2(i)=-(y(i)-fintcpt(2)-x(i)*slope(2))/
|
||||
& (1.0d0+slope(2)*slope(2))
|
||||
rtmnsquare2=rtmnsquare2+dx2(i)**2+dy2(i)**2
|
||||
enddo
|
||||
rtmnsquare1=dsqrt(rtmnsquare1/dble(nsamp))
|
||||
rtmnsquare2=dsqrt(rtmnsquare2/dble(nsamp))
|
||||
if(rtmnsquare1.gt.rtmnsquare2)then
|
||||
rtmnsquare=rtmnsquare2
|
||||
slope0=slope(2)
|
||||
fintcpt0=fintcpt(2)
|
||||
do i=1,nsamp
|
||||
dx(i)=dx2(i)
|
||||
dy(i)=dy2(i)
|
||||
enddo
|
||||
else
|
||||
rtmnsquare=rtmnsquare1
|
||||
slope0=slope(1)
|
||||
fintcpt0=fintcpt(1)
|
||||
do i=1,nsamp
|
||||
dx(i)=dx1(i)
|
||||
dy(i)=dy1(i)
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
!
|
||||
subroutine OrthSoilRespRegres(npoints,x0,y0,slope,fintcpt)
|
||||
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=50000,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
|
||||
double precision x0(npoints),y0(npoints),slope,fintcpt
|
||||
|
||||
|
||||
|
||||
EXTERNAL OrthRespFCN
|
||||
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=20
|
||||
NDIGIT = -1
|
||||
TAUFAC = -1.0D0
|
||||
SSTOL = -1.0D0
|
||||
PARTOL = -1.0D0
|
||||
MAXIT = -1
|
||||
! IPRINT = -1
|
||||
! IPRINT=0
|
||||
IPRINT=-1
|
||||
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 = 9
|
||||
LUNRPT = 9
|
||||
c
|
||||
N=npoints
|
||||
M=1
|
||||
NP=2
|
||||
NQ=1
|
||||
|
||||
|
||||
do I=1,N
|
||||
do i1=1,M
|
||||
X(I,i1)=x0(I)
|
||||
enddo
|
||||
Y(I,1)=y0(I)
|
||||
enddo
|
||||
BETA(1)=slope
|
||||
BETA(2)=fintcpt
|
||||
|
||||
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(OrthRespFCN,
|
||||
+ 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)
|
||||
|
||||
slope=BETA(1)
|
||||
fintcpt=BETA(2)
|
||||
return
|
||||
END
|
||||
c
|
||||
SUBROUTINE OrthRespFCN(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)
|
||||
|
||||
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
|
||||
F(I,L)=BETA(2)+BETA(1)*XPLUSD(I,1)
|
||||
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)=XPLUSD(I,1)
|
||||
FJACB(I,2,L)=1.0d0
|
||||
200 CONTINUE
|
||||
210 CONTINUE
|
||||
ENDIF
|
||||
|
||||
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(1)
|
||||
300 CONTINUE
|
||||
310 CONTINUE
|
||||
|
||||
END IF
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
Reference in New Issue
Block a user