Initial commit
This commit is contained in:
@@ -0,0 +1,114 @@
|
||||
!This file contains gaussian functions even though the subroutine names are sigmoid
|
||||
double precision function sigmoidfunc(y0,a,b,c,x0,x)
|
||||
implicit none
|
||||
!y=y0+a*exp(-((x-x0)/b)**c)) for x > x0 or y=y0+a*exp(-((x0-x)/b)**c)) for x < x0
|
||||
double precision y0,a,b,c,x0,x
|
||||
if(x.gt.x0)then
|
||||
sigmoidfunc=y0+a*dexp(-((x-x0)/b)**c)
|
||||
else
|
||||
sigmoidfunc=y0+a*dexp(-((x0-x)/b)**c)
|
||||
endif
|
||||
return
|
||||
end
|
||||
!-------------------------------------------------------------------
|
||||
subroutine gradsigmoidfunc(y0,a,b,c,x0,x,grad)
|
||||
implicit none
|
||||
double precision y0,a,b,c,x0,x,grad(6),term,term1
|
||||
|
||||
! a<->grad(1)
|
||||
! b<->grad(2)
|
||||
! c<->grad(3)
|
||||
! x0<->grad(4)
|
||||
! y0<->grad(5)
|
||||
! x<->grad(6)
|
||||
grad(5)=1.0d0
|
||||
if(x.gt.x0)then
|
||||
term=dexp(-((x-x0)/b)**c)
|
||||
term1=-((x-x0)/b)**(c-1.0d0)
|
||||
grad(1)=term
|
||||
grad(6)=term*c*term1/b
|
||||
grad(4)=-term*c*term1/b
|
||||
grad(2)=-term*c*term1*(x-x0)/(b*b)
|
||||
grad(3)=term*(-((x-x0)/b)**c)*dlog((x-x0)/b)
|
||||
else
|
||||
term=dexp(-((x0-x)/b)**c)
|
||||
term1=-((x0-x)/b)**(c-1.0d0)
|
||||
grad(1)=term
|
||||
grad(6)=-term*c*term1/b
|
||||
grad(4)=term*c*term1/b
|
||||
grad(2)=-term*c*term1*(x0-x)/(b*b)
|
||||
grad(3)=term*(-((x0-x)/b)**c)*dlog((x0-x)/b)
|
||||
endif
|
||||
return
|
||||
end
|
||||
!--------------------------------------------------------------------
|
||||
double precision function twoexpfunc(y0,a1,b1,c1,x01,
|
||||
&a2,b2,c2,x02,x)
|
||||
implicit none
|
||||
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,sigmoidfunc,
|
||||
&x0,a,b,c
|
||||
!In Asymmetrical Gaussians, c1 and c2 have no use.
|
||||
!y=y0+a1*exp(-((x-x01)/b1)**a2)) for x > x01 or y=y0+a1*exp(-((x01-x)/b2)**x02)) for x < x01
|
||||
x0=x01
|
||||
a=a1
|
||||
if(x.gt.x01)then
|
||||
b=b1
|
||||
c=a2
|
||||
else
|
||||
b=b2
|
||||
c=x02
|
||||
endif
|
||||
twoexpfunc=sigmoidfunc(y0,a,b,c,x0,x)
|
||||
return
|
||||
end
|
||||
!---------------------------------------------------------------------
|
||||
subroutine gradtwoexp(y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad)
|
||||
implicit none
|
||||
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad(10),grad6(6),
|
||||
&x0,a,b,c
|
||||
integer i
|
||||
! a1<->grad(1)
|
||||
! b1<->grad(2)
|
||||
! c1<->grad(3)
|
||||
! x01<->grad(4)
|
||||
! y0<->grad(5)
|
||||
! x<->grad(6)
|
||||
! a2<->grad(7)
|
||||
! b2<->grad(8)
|
||||
! c2<->grad(9)
|
||||
! x02<->grad(10)
|
||||
do i=1,10
|
||||
grad(i)=0.0d0
|
||||
enddo
|
||||
x0=x01
|
||||
a=a1
|
||||
if(x.gt.x01)then
|
||||
b=b1
|
||||
c=a2
|
||||
call gradsigmoidfunc(y0,a,b,c,x0,x,grad6)
|
||||
! a<->grad6(1)
|
||||
! b<->grad6(2)
|
||||
! c<->grad6(3)
|
||||
! x0<->grad6(4)
|
||||
! y0<->grad6(5)
|
||||
! x<->grad6(6)
|
||||
grad(1)=grad6(1)
|
||||
grad(2)=grad6(2)
|
||||
grad(4)=grad6(4)
|
||||
grad(5)=grad6(5)
|
||||
grad(6)=grad6(6)
|
||||
grad(7)=grad6(3)
|
||||
else
|
||||
b=b2
|
||||
c=x02
|
||||
call gradsigmoidfunc(y0,a,b,c,x0,x,grad6)
|
||||
grad(1)=grad6(1)
|
||||
grad(4)=grad6(4)
|
||||
grad(5)=grad6(5)
|
||||
grad(6)=grad6(6)
|
||||
grad(8)=grad6(2)
|
||||
grad(10)=grad6(3)
|
||||
endif
|
||||
return
|
||||
end
|
||||
!------------------------------------------------------------------------------
|
||||
@@ -0,0 +1,126 @@
|
||||
subroutine CharToNumeric(astring,f)
|
||||
implicit none
|
||||
!
|
||||
! transform a string consisting all numbers in time representation (1234 or 12:34 or
|
||||
! 12:23:15,or 12.19) into a number
|
||||
character*20 astring
|
||||
character*1,c
|
||||
character*2,HH,MM,SS
|
||||
character*4 MMSS
|
||||
|
||||
double precision f,f11,f22,f33
|
||||
integer ipos1,ipos2,ideci,k,j,ndigit,i
|
||||
|
||||
ipos1=1
|
||||
190 if(astring(ipos1:ipos1).ne.' ')goto 200
|
||||
ipos1=ipos1+1
|
||||
goto 190
|
||||
200 ipos2=ipos1+1
|
||||
202 if(astring(ipos2:ipos2).eq.' ')goto 204
|
||||
ipos2=ipos2+1
|
||||
goto 202
|
||||
204 ipos2=ipos2-1
|
||||
|
||||
if(astring(ipos1:ipos1).eq.'-')then
|
||||
ipos1=ipos1+1
|
||||
endif
|
||||
|
||||
ideci=index(astring,'.')
|
||||
if(ideci.eq.0)then
|
||||
!1234 or 12:34 or 12:34:50 type
|
||||
f=-9999.0d0
|
||||
if(index(astring,':').eq.0)then
|
||||
! an integer number
|
||||
ndigit=ipos2-ipos1+1
|
||||
if(ndigit.ge.3.and.ndigit.le.6)then
|
||||
f33=-99.0d0
|
||||
c=astring(ipos2:ipos2)
|
||||
f11=dble(ichar(c)-48)
|
||||
c=astring(ipos2-1:ipos2-1)
|
||||
f11=f11+dble((ichar(c)-48)*10)
|
||||
|
||||
c=astring(ipos2-2:ipos2-2)
|
||||
f22=dble(ichar(c)-48)
|
||||
if(ndigit.ge.4)then
|
||||
c=astring(ipos2-3:ipos2-3)
|
||||
f22=f22+dble((ichar(c)-48)*10)
|
||||
endif
|
||||
|
||||
if(ndigit.ge.5)then
|
||||
c=astring(ipos2-4:ipos2-4)
|
||||
f33=dble(ichar(c)-48)
|
||||
endif
|
||||
|
||||
if(ndigit.eq.6)then
|
||||
c=astring(ipos2-5:ipos2-5)
|
||||
f33=f33+dble((ichar(c)-48)*10)
|
||||
endif
|
||||
|
||||
if(f33.lt.0.0d0)then
|
||||
if(f11.le.60.0d0.and.f22.le.24.0d0)then
|
||||
f=f22+f11/60.0d0
|
||||
endif
|
||||
else
|
||||
if(f33.le.24.0d0.and.f22.le.60.0d0.and.
|
||||
& f11.le.60.0d0)then
|
||||
f=f33+f22/60.0d0+f11/3600.0d0
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
else
|
||||
!HH:MM or HH:MM:SS type
|
||||
k=index(astring,':')
|
||||
HH=astring(ipos1:k-1)
|
||||
MMSS=astring(k+1:ipos2)
|
||||
j=index(MMSS,':')
|
||||
if(j.eq.0)then
|
||||
MM=MMSS
|
||||
else
|
||||
MM=MMSS(1:j-1)
|
||||
SS=MMSS(j+1:)
|
||||
endif
|
||||
|
||||
f33=dble((ichar(HH(1:1))-48))
|
||||
if(HH(2:2).ne.' ')then
|
||||
f33=f33*10.0d0+dble(ichar(HH(2:2))-48)
|
||||
endif
|
||||
|
||||
f22=dble((ichar(MM(1:1))-48))
|
||||
if(MM(2:2).ne.' ')then
|
||||
f22=f22*10.0d0+dble(ichar(MM(2:2))-48)
|
||||
endif
|
||||
|
||||
if(j.ne.0)then
|
||||
f11=dble((ichar(SS(1:1))-48))
|
||||
if(SS(2:2).ne.' ')then
|
||||
f11=f11*10.0d0+dble(ichar(SS(2:2))-48)
|
||||
endif
|
||||
endif
|
||||
|
||||
if(f33.le.24.0d0.and.f22.le.60.0d0)then
|
||||
f=f33+f22/60.0d0
|
||||
if(j.ne.0)then
|
||||
if(f11.le.60.0d0)then
|
||||
f=f+f11/3600.0d0
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
else
|
||||
!18.27 type of character
|
||||
f=0.0d0
|
||||
do i=ipos1,ideci-1
|
||||
c=astring(i:i)
|
||||
f=f+dble(ichar(c)-48)*
|
||||
& dble(10**(ideci-ipos1-(i-ipos1)-1))
|
||||
enddo
|
||||
do i=ideci+1,ipos2
|
||||
c=astring(i:i)
|
||||
f=f+dble(ichar(c)-48)/dble(10**(i-ideci))
|
||||
enddo
|
||||
endif
|
||||
if(index(astring,'-').ne.0)then
|
||||
f=-f
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,30 @@
|
||||
subroutine NumberToChar(numitis,numchar,acharitis)
|
||||
implicit none
|
||||
!Convert the number numitis to a character whose units are the digits in numitis
|
||||
!and whose length is numchar. if the number of digits in numitis is less than
|
||||
!numchar, pad with 0 in the front, e.g. 1 -> 001 and 23 -> 023 if numchar=3
|
||||
integer numitis,numchar
|
||||
character acharitis*(*)
|
||||
character*1 onechar(numchar)
|
||||
integer n,i,j,k(numchar)
|
||||
n=numitis
|
||||
i=0
|
||||
10 i=i+1
|
||||
k(i)=mod(n,10)
|
||||
n=(n-k(i))/10
|
||||
if(n.ne.0)goto 10
|
||||
if(i.lt.numchar)then
|
||||
do j=i+1,numchar
|
||||
k(j)=0
|
||||
enddo
|
||||
endif
|
||||
do j=1,numchar
|
||||
acharitis(numchar-j+1:numchar-j+1)=char(k(j)+48)
|
||||
enddo
|
||||
n=len(acharitis)
|
||||
do j=numchar+1,n
|
||||
acharitis(j:j)=''
|
||||
enddo
|
||||
acharitis=trim(acharitis)
|
||||
return
|
||||
end subroutine NumberToChar
|
||||
@@ -0,0 +1,190 @@
|
||||
C ***QUARTIC************************************************25.03.98
|
||||
C Solution of a quartic equation:
|
||||
|
||||
! dd(0)+dd(1)*z+dd(2)*z**2+dd(3)*z**3+dd(4)*z**4=0
|
||||
|
||||
C ref.: J. E. Hacke, Amer. Math. Monthly, Vol. 48, 327-328, (1941)
|
||||
C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING
|
||||
C ******************************************************************
|
||||
C dd(0:4) (i) vector containing the polynomial coefficients
|
||||
C sol(1:4) (o) results, real part
|
||||
C soli(1:4) (o) results, imaginary part
|
||||
C Nsol (o) number of real solutions
|
||||
C ==================================================================
|
||||
subroutine quartic(dd,sol,soli,Nsol)
|
||||
implicit double precision (a-h,o-z)
|
||||
dimension dd(0:4),sol(4),soli(4)
|
||||
dimension AA(0:3),z(3)
|
||||
C
|
||||
Nsol = 0
|
||||
a = dd(4)
|
||||
b = dd(3)
|
||||
c = dd(2)
|
||||
d = dd(1)
|
||||
e = dd(0)
|
||||
C
|
||||
if (dd(4).eq.0.0d+0) then
|
||||
write(*,*)'ERROR: NOT A QUARTIC EQUATION'
|
||||
return
|
||||
endif
|
||||
C
|
||||
p=-(3.0d0/8.0d0)*(b/a)*(b/a)+c/a
|
||||
q =(b/a)*(b/a)*(b/a)/8.0d0-(b/a)*(c/a)/2.0d0+d/a
|
||||
r =(-3.0d0/256.0d0)*(b/a)*(b/a)*(b/a)*(b/a)+
|
||||
& (b/a)*(b/a)*(c/a)/16.0d0-(b/a)*(d/a)/4.0d0+
|
||||
& e/a
|
||||
|
||||
!
|
||||
! solve cubic resolvent
|
||||
AA(3) = 8.0d0
|
||||
AA(2) = -4.0d0*p
|
||||
AA(1) = -8.0d0*r
|
||||
AA(0) = 4.0d0*p*r - q*q
|
||||
call cubic(AA,z,ncube)
|
||||
C
|
||||
zsol = -1.0d99
|
||||
do 5 i=1,ncube
|
||||
zsol = dmax1(zsol,z(i))
|
||||
5 continue
|
||||
z(1) = zsol
|
||||
xK2 = 2.0d0 * z(1) - p
|
||||
xK = dsqrt(xK2)
|
||||
C-----------------------------------------------
|
||||
if (xK.eq.0.0d0) then
|
||||
xL2 = z(1)*z(1) - r
|
||||
if (xL2.lt.0.0d0) then
|
||||
write(*,*)'Sorry, no solution'
|
||||
return
|
||||
endif
|
||||
xL = dsqrt(xL2)
|
||||
else
|
||||
xL = q/(2.0d0 * xK)
|
||||
endif
|
||||
C-----------------------------------------------
|
||||
sqp = xK2 - 4.0d0*(z(1) + xL)
|
||||
sqm = xK2 - 4.0d0*(z(1) - xL)
|
||||
C
|
||||
do 10 i=1,4
|
||||
soli(i) = 0.0d0
|
||||
10 continue
|
||||
if (sqp.ge.0.0d0 .and. sqm.ge.0.0d0) then
|
||||
sol(1) = 0.5d+0*( xK + dsqrt(sqp))
|
||||
sol(2) = 0.5d+0*( xK - dsqrt(sqp))
|
||||
sol(3) = 0.5d+0*(-xK + dsqrt(sqm))
|
||||
sol(4) = 0.5d+0*(-xK - dsqrt(sqm))
|
||||
Nsol = 4
|
||||
else if (sqp.ge.0.d+0 .and. sqm.lt.0.d+0) then
|
||||
sol(1) = 0.5d+0*(xK + dsqrt(sqp))
|
||||
sol(2) = 0.5d+0*(xK - dsqrt(sqp))
|
||||
sol(3) = -0.5d+0*xK
|
||||
sol(4) = -0.5d+0*xK
|
||||
soli(3) = dsqrt(-0.25d+0 * sqm)
|
||||
soli(4) = -dsqrt(-0.25d+0 * sqm)
|
||||
Nsol = 2
|
||||
else if (sqp.lt.0.d+0 .and. sqm.ge.0.d+0) then
|
||||
sol(1) = 0.5d+0*(-xK + dsqrt(sqm))
|
||||
sol(2) = 0.5d+0*(-xK - dsqrt(sqm))
|
||||
sol(3) = 0.5d+0*xK
|
||||
sol(4) = 0.5d+0*xK
|
||||
soli(3) = dsqrt(-0.25d+0 * sqp)
|
||||
soli(4) = -dsqrt(-0.25d+0 * sqp)
|
||||
Nsol = 2
|
||||
else if (sqp.lt.0.d+0 .and. sqm.lt.0.d+0) then
|
||||
sol(1) = -0.5d+0*xK
|
||||
sol(2) = -0.5d+0*xK
|
||||
soli(1) = dsqrt(-0.25d+0 * sqm)
|
||||
soli(2) = -dsqrt(-0.25d+0 * sqm)
|
||||
sol(3) = 0.5d+0*xK
|
||||
sol(4) = 0.5d+0*xK
|
||||
soli(3) = dsqrt(-0.25d+0 * sqp)
|
||||
soli(4) = -dsqrt(-0.25d+0 * sqp)
|
||||
Nsol = 0
|
||||
endif
|
||||
do 20 i=1,4
|
||||
sol(i) = sol(i) - b/(4.d+0*a)
|
||||
20 continue
|
||||
C
|
||||
return
|
||||
END
|
||||
|
||||
C ***CUBIC************************************************08.11.1986
|
||||
C Solution of a cubic equation
|
||||
C Equations of lesser degree are solved by the appropriate formulas.
|
||||
C The solutions are arranged in ascending order.
|
||||
C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING
|
||||
C ******************************************************************
|
||||
C A(0:3) (i) vector containing the polynomial coefficients
|
||||
C X(1:L) (o) results
|
||||
C L (o) number of valid solutions (beginning with X(1))
|
||||
C ==================================================================
|
||||
SUBROUTINE CUBIC(A,X,L)
|
||||
IMPLICIT DOUBLE PRECISION(A-H,O-Z)
|
||||
DIMENSION A(0:3),X(3),U(3)
|
||||
PARAMETER(PI=3.1415926535897932D+0,THIRD=1.D+0/3.D+0)
|
||||
INTRINSIC DMIN1,DMAX1,DACOS
|
||||
C
|
||||
C define cubic root as statement function
|
||||
CBRT(Z)=DSIGN(DABS(Z)**THIRD,Z)
|
||||
C
|
||||
C ==== determine the degree of the polynomial ====
|
||||
C
|
||||
IF (A(3).NE.0.D+0) THEN
|
||||
C
|
||||
C cubic problem
|
||||
W=A(2)/A(3)*THIRD
|
||||
P=(A(1)/A(3)*THIRD-W**2)**3
|
||||
Q=-.5D+0*(2.D+0*W**3-(A(1)*W-A(0))/A(3))
|
||||
DIS=Q**2+P
|
||||
IF (DIS.LT.0.D+0) THEN
|
||||
C three real solutions!
|
||||
C Confine the argument of ACOS to the interval [-1;1]!
|
||||
PHI=DACOS(DMIN1(1.D+0,DMAX1(-1.D+0,Q/DSQRT(-P))))
|
||||
P=2.D+0*(-P)**(5.D-1*THIRD)
|
||||
DO 100 I=1,3
|
||||
U(I)=P*DCOS((PHI+DBLE(2*I)*PI)*THIRD)-W
|
||||
100 continue
|
||||
X(1)=DMIN1(U(1),U(2),U(3))
|
||||
X(2)=DMAX1(DMIN1(U(1),U(2)),DMIN1(U(1),U(3)),DMIN1(U(2),U(3)))
|
||||
X(3)=DMAX1(U(1),U(2),U(3))
|
||||
L=3
|
||||
ELSE
|
||||
C only one real solution!
|
||||
DIS=DSQRT(DIS)
|
||||
X(1)=CBRT(Q+DIS)+CBRT(Q-DIS)-W
|
||||
L=1
|
||||
END IF
|
||||
C
|
||||
ELSE IF (A(2).NE.0.D+0) THEN
|
||||
C
|
||||
C quadratic problem
|
||||
P=5.D-1*A(1)/A(2)
|
||||
DIS=P**2-A(0)/A(2)
|
||||
IF (DIS.GE.0.D+0) THEN
|
||||
C two real solutions!
|
||||
X(1)=-P-DSQRT(DIS)
|
||||
X(2)=-P+DSQRT(DIS)
|
||||
L=2
|
||||
ELSE
|
||||
C no real solution!
|
||||
L=0
|
||||
END IF
|
||||
C
|
||||
ELSE IF (A(1).NE.0.D+0) THEN
|
||||
C
|
||||
C linear equation
|
||||
X(1)=-A(0)/A(1)
|
||||
L=1
|
||||
C
|
||||
ELSE
|
||||
C no equation
|
||||
L=0
|
||||
END IF
|
||||
C
|
||||
C ==== perform one step of a newton iteration in order to minimize
|
||||
C round-off errors ====
|
||||
DO 110 I=1,L
|
||||
X(I)=X(I)-(A(0)+X(I)*(A(1)+X(I)*(A(2)+X(I)*A(3))))
|
||||
* /(A(1)+X(I)*(2.D+0*A(2)+X(I)*3.D+0*A(3)))
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,125 @@
|
||||
subroutine VariabilityIndicies(nsamp,xvar,nthresh,threshold,
|
||||
&shannon,coefvar,xmean,total,unevenness,standunevenness,
|
||||
&arearatio,pvindex,meaninterval,maxinterval,xintensity)
|
||||
implicit none
|
||||
integer nsamp,i,nthresh,j,k
|
||||
double precision xvar(nsamp),shannon,coefvar,xmean,total,
|
||||
&unevenness,standunevenness,arearatio,cumline(nsamp),
|
||||
&evenline(nsamp),areacum,areaeven,trans(nsamp),avetrans,
|
||||
&pvindex,meaninterval(nthresh),maxinterval(nthresh),
|
||||
&finterval(nsamp),fstart,threshold(nthresh),recumline(nsamp),
|
||||
&repvi,retrans(nsamp),averetrans,xintensity
|
||||
!
|
||||
cumline(1)=xvar(1)
|
||||
recumline(1)=xvar(nsamp)
|
||||
k=0
|
||||
if(xvar(1).gt.0.0d0)k=1
|
||||
do i=2,nsamp
|
||||
cumline(i)=cumline(i-1)+xvar(i)
|
||||
recumline(i)=recumline(i-1)+xvar(nsamp-i+1)
|
||||
if(xvar(i).gt.0.0d0)k=k+1
|
||||
enddo
|
||||
total=cumline(nsamp)
|
||||
xmean=total/dble(nsamp)
|
||||
if(k.gt.0)then
|
||||
xintensity=total/dble(k)
|
||||
else
|
||||
xintensity=-9999.0d0
|
||||
endif
|
||||
if(nsamp.eq.1.or.total.le.0.0d0)then
|
||||
shannon=-9999.0d0
|
||||
coefvar=-9999.0d0
|
||||
unevenness=-9999.0d0
|
||||
standunevenness=-9999.0d0
|
||||
arearatio=-9999.0d0
|
||||
pvindex=-9999.0d0
|
||||
repvi=-9999.0d0
|
||||
do i=1,nthresh
|
||||
meaninterval(i)=-9999.0d0
|
||||
maxinterval(i)=-9999.0d0
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
do i=1,nsamp
|
||||
evenline(i)=xmean*dble(i)
|
||||
enddo
|
||||
unevenness=0.0d0
|
||||
shannon=0.0d0
|
||||
coefvar=0.0d0
|
||||
avetrans=0.0d0
|
||||
averetrans=0.0d0
|
||||
do i=1,nsamp
|
||||
unevenness=unevenness+(cumline(i)-evenline(i))*
|
||||
&(cumline(i)-evenline(i))
|
||||
trans(i)=(cumline(i)-evenline(i))/evenline(i)
|
||||
! trans(i)=2.0d0*(cumline(i)-evenline(i))/(xmean*dble((nsamp+1)))
|
||||
retrans(i)=(recumline(i)-evenline(i))/evenline(i)
|
||||
avetrans=avetrans+trans(i)
|
||||
averetrans=averetrans+retrans(i)
|
||||
if(dabs(xvar(i)).gt.1.0d-10)then
|
||||
shannon=shannon+(xvar(i)/total)*dlog(xvar(i)/total)
|
||||
endif
|
||||
coefvar=coefvar+(xvar(i)-xmean)*(xvar(i)-xmean)
|
||||
enddo
|
||||
|
||||
! avetrans=0.0d0
|
||||
! do i=1,nsamp
|
||||
! trans(i)=trans(i)*retrans(nsamp-i+1)
|
||||
! if(trans(i).lt.0.0d0)then
|
||||
! trans(i)=-dsqrt(-trans(i))
|
||||
! else
|
||||
! trans(i)=dsqrt(trans(i))
|
||||
! endif
|
||||
! avetrans=avetrans+trans(i)
|
||||
! enddo
|
||||
|
||||
coefvar=dsqrt(coefvar/dble(nsamp-1))/xmean
|
||||
unevenness=dsqrt(unevenness/dble(nsamp))
|
||||
standunevenness=unevenness/xmean
|
||||
shannon=-shannon/dlog(dble(nsamp))
|
||||
avetrans=avetrans/dble(nsamp)
|
||||
averetrans=averetrans/dble(nsamp)
|
||||
pvindex=0.0d0
|
||||
repvi=0.0d0
|
||||
do i=1,nsamp
|
||||
pvindex=pvindex+(trans(i)-avetrans)*(trans(i)-avetrans)
|
||||
repvi=repvi+(retrans(i)-averetrans)*(retrans(i)-averetrans)
|
||||
enddo
|
||||
pvindex=dsqrt(pvindex/dble(nsamp))
|
||||
repvi=dsqrt(repvi/dble(nsamp))
|
||||
|
||||
! pvindex=(pvindex+repvi)/2.0d0
|
||||
|
||||
areacum=0.0d0
|
||||
areaeven=0.0d0
|
||||
do i=2,nsamp
|
||||
areacum=areacum+(cumline(i)+cumline(i-1))*0.5d0
|
||||
areaeven=areaeven+(evenline(i)+evenline(i-1))*0.5d0
|
||||
enddo
|
||||
arearatio=areacum/areaeven
|
||||
!intervals
|
||||
do i=1,nthresh
|
||||
fstart=0.0d0
|
||||
k=1
|
||||
do j=1,nsamp
|
||||
if(xvar(j).ge.threshold(i))then
|
||||
finterval(k)=dble(j)-fstart-1.0d0
|
||||
fstart=dble(j)
|
||||
k=k+1
|
||||
endif
|
||||
enddo
|
||||
if((dble(nsamp)-fstart).gt.0.5d0)then
|
||||
finterval(k)=dble(nsamp)-fstart
|
||||
else
|
||||
k=k-1
|
||||
endif
|
||||
maxinterval(i)=finterval(1)
|
||||
meaninterval(i)=finterval(1)
|
||||
do j=2,k
|
||||
if(finterval(j).gt.maxinterval(i))maxinterval(i)=finterval(j)
|
||||
meaninterval(i)=meaninterval(i)+finterval(j)
|
||||
enddo
|
||||
meaninterval(i)=meaninterval(i)/dble(k)
|
||||
enddo
|
||||
return
|
||||
end subroutine VariabilityIndicies
|
||||
@@ -0,0 +1,75 @@
|
||||
c autocorrelation function
|
||||
c
|
||||
subroutine autocorr(nsamp,xvar,yvar,step,rcorr,ncorr)
|
||||
implicit none
|
||||
integer nsamp,ncorr
|
||||
double precision xvar(nsamp),yvar(nsamp),step(nsamp),
|
||||
& rcorr(nsamp)
|
||||
|
||||
double precision ymean,sum,hmin,sig0,crit
|
||||
integer i,j,k,n
|
||||
|
||||
sum=0.0d0
|
||||
do i=1,nsamp
|
||||
sum=sum+yvar(i)
|
||||
enddo
|
||||
ymean=sum/dble(nsamp)
|
||||
|
||||
step(1)=0.0d0
|
||||
rcorr(1)=1.0d0
|
||||
sum=0.0d0
|
||||
do i=1,nsamp
|
||||
sum=sum+(yvar(i)-ymean)*(yvar(i)-ymean)
|
||||
enddo
|
||||
sig0=sum/dble(nsamp)
|
||||
if(sig0.eq.0.0d0)then
|
||||
do i=1,nsamp
|
||||
step(i)=-9999.0d0
|
||||
rcorr(i)=-9999.0d0
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
|
||||
hmin=xvar(2)-xvar(1)
|
||||
do i=2,nsamp-1
|
||||
if((xvar(i+1)-xvar(i)).lt.hmin)then
|
||||
hmin=xvar(i+1)-xvar(i)
|
||||
endif
|
||||
enddo
|
||||
crit=0.01d0*hmin
|
||||
|
||||
|
||||
i=2
|
||||
step(i)=hmin
|
||||
|
||||
|
||||
10 j=1
|
||||
n=0
|
||||
sum=0.0d0
|
||||
100 do k=j+1,nsamp
|
||||
if((xvar(k)-xvar(j)).lt.(step(i)+crit).and.
|
||||
& (xvar(k)-xvar(j)).gt.(step(i)-crit))then
|
||||
n=n+1
|
||||
sum=sum+(yvar(k)-ymean)*(yvar(j)-ymean)
|
||||
endif
|
||||
enddo
|
||||
if(j.lt.nsamp-1)then
|
||||
j=j+1
|
||||
goto 100
|
||||
endif
|
||||
if(n.le.1)then
|
||||
step(i)=step(i)+hmin
|
||||
else
|
||||
! this form of autocorrelation has less bias
|
||||
rcorr(i)=sum/(dble(n)*sig0)
|
||||
|
||||
! but this form is more common in statistic literature because it has certain
|
||||
! desirable properties
|
||||
! rcorr(i)=sum/(dble(nsamp)*sig0)
|
||||
i=i+1
|
||||
step(i)=step(i-1)+hmin
|
||||
endif
|
||||
if((xvar(1)+step(i)).lt.xvar(nsamp))goto 10
|
||||
ncorr=i-1
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,84 @@
|
||||
!This subroutine fills gaps in the y variable based on neural network regression
|
||||
subroutine blockgapfilling(nx,nobs,xsamp,ysamp,nmax)
|
||||
implicit none
|
||||
!Gaps must be represented by -9999
|
||||
!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension
|
||||
!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used
|
||||
!in x may be different.
|
||||
integer nx,nobs,nmax
|
||||
double precision xsamp(1:nobs,1:nx),ysamp(1:nobs)
|
||||
!Locals
|
||||
integer i,j,k,n,idowhat,nh,nxfit,nobsfit,ixuse(nx),
|
||||
&iposdif,itakethis,iposfit(nobs),iuseit
|
||||
|
||||
parameter(nh=3)
|
||||
double precision w(1:nx,1:nh),bph(nh),q(nh),bend,c(nh),xnew(nx),
|
||||
&calvalue(nobs),fn9999,tiny,xfit(nobs,nx),yfit(nobs),rsq
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-6)
|
||||
!
|
||||
do i=1,nobs
|
||||
if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000
|
||||
!a gap
|
||||
nxfit=0
|
||||
do j=1,nx
|
||||
if(dabs(xsamp(i,j)-fn9999).lt.tiny)then
|
||||
!this x dimension is not used
|
||||
ixuse(j)=0
|
||||
else
|
||||
!this x dimension is used
|
||||
nxfit=nxfit+1
|
||||
xnew(nxfit)=xsamp(i,j)
|
||||
ixuse(j)=1
|
||||
endif
|
||||
enddo
|
||||
if(nxfit.eq.0)goto 1000
|
||||
!Fill this gap by choosing the nmax valid points that are closest to i for the fitting
|
||||
nobsfit=0
|
||||
10 iposdif=10000000
|
||||
do n=1,nobs
|
||||
if(n.ne.i.and.dabs(ysamp(n)-fn9999).gt.tiny)then
|
||||
iuseit=1
|
||||
!make sure it is not one that has been already selected
|
||||
do k=1,nobsfit
|
||||
if(n.eq.iposfit(k))iuseit=0
|
||||
enddo
|
||||
if(iuseit.eq.1)then
|
||||
!make sure it has the x dimensions needed
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
if(iuseit.eq.1)then
|
||||
!make sure the distance is smaller than the current miminum
|
||||
if(iabs(n-i).lt.iposdif)then
|
||||
iposdif=iabs(n-i)
|
||||
itakethis=n
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
nobsfit=nobsfit+1
|
||||
iposfit(nobsfit)=itakethis
|
||||
yfit(nobsfit)=ysamp(itakethis)
|
||||
n=0
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
n=n+1
|
||||
xfit(nobsfit,n)=xsamp(itakethis,j)
|
||||
endif
|
||||
enddo
|
||||
if(nobsfit.lt.nmax)goto 10
|
||||
idowhat=1
|
||||
call NeuralNetRegres(idowhat,nxfit,nobsfit,nh,
|
||||
&xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,c,xnew,ysamp(i))
|
||||
idowhat=2
|
||||
call NeuralNetRegres(idowhat,nxfit,1,nh,
|
||||
&xfit(1:1,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,c,xnew,ysamp(i))
|
||||
1000 continue
|
||||
enddo
|
||||
return
|
||||
end subroutine blockgapfilling
|
||||
@@ -0,0 +1,91 @@
|
||||
program main
|
||||
implicit none
|
||||
! integer C_flag1,C_flag2,TA1_flag1,TA1_flag2,TA1_flag3,
|
||||
! & Ta1_flag4,P_flag1,P_flag2,P_flag3,P_flag4
|
||||
! double precision Year,month,DoY,Hour,seq_day_90,seq_time_90,
|
||||
! & obs_NEE,obs_FCO2,fco2_corr,ustar,nee,Resp_e,gee,
|
||||
! & obs_Ta_27m,Ta_27m_filled,Ta_2_5m,Ta_2_5m_filled,
|
||||
! & PAR_28m,PAR_28m_filled
|
||||
double precision daycurrent,gppmax,dataraw(33),datapick(33),
|
||||
& work(50000,33),gppsamp(50),std,fmean
|
||||
integer i,j,ntotal,nwindow,nstart,nend
|
||||
|
||||
nwindow=7
|
||||
daycurrent=301.0d0
|
||||
gppmax=-1.0d+10
|
||||
open(unit=1,file='HF_9204_filled')
|
||||
read(1,*)
|
||||
read(1,*)
|
||||
read(1,*)
|
||||
read(1,*)
|
||||
open(unit=2,file='HF_9204_gppmax')
|
||||
10 read(1,*,end=100)dataraw
|
||||
if(dabs(daycurrent-dataraw(3)).lt.0.01d0)then
|
||||
dataraw(13)=dabs(dataraw(13))
|
||||
if(dataraw(13).lt.150.0d0)then
|
||||
if(dataraw(13).gt.gppmax)then
|
||||
gppmax=dataraw(13)
|
||||
do i=1,33
|
||||
datapick(i)=dataraw(i)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
else
|
||||
if(dabs(gppmax).lt.150.0d0)then
|
||||
write(2,310)datapick
|
||||
endif
|
||||
daycurrent=dataraw(3)
|
||||
dataraw(13)=dabs(dataraw(13))
|
||||
if(dataraw(13).lt.150.0d0)then
|
||||
gppmax=dataraw(13)
|
||||
do i=1,33
|
||||
datapick(i)=dataraw(i)
|
||||
enddo
|
||||
else
|
||||
gppmax=-1.0d+10
|
||||
endif
|
||||
endif
|
||||
goto 10
|
||||
100 write(2,310)datapick
|
||||
close(1)
|
||||
close(2)
|
||||
open(unit=1,file='HF_9204_gppmax')
|
||||
open(unit=2,file='HF_9204_gppmax_clean')
|
||||
i=1
|
||||
110 read(1,*,end=200)(work(i,j),j=1,33)
|
||||
i=i+1
|
||||
goto 110
|
||||
200 close(1)
|
||||
ntotal=i-1
|
||||
do i=1,ntotal
|
||||
nstart=i-nwindow/2
|
||||
if(nstart.lt.1)then
|
||||
nstart=1
|
||||
endif
|
||||
nend=i+nwindow/2
|
||||
if(nend.gt.ntotal)then
|
||||
nend=ntotal
|
||||
endif
|
||||
if((nend-nstart+1).lt.nwindow)then
|
||||
if(nstart.eq.1)then
|
||||
nend=nend+nwindow-(nend-nstart+1)
|
||||
else
|
||||
nstart=nstart-(nwindow-(nend-nstart+1))
|
||||
endif
|
||||
endif
|
||||
fmean=0.0d0
|
||||
do j=nstart,nend
|
||||
fmean=fmean+work(j,13)
|
||||
enddo
|
||||
fmean=fmean/dble(nwindow)
|
||||
std=0.0d0
|
||||
do j=nstart,nend
|
||||
std=std+(work(j,13)-fmean)*(work(j,13)-fmean)
|
||||
enddo
|
||||
std=dsqrt(std/dble(nwindow-1))
|
||||
if((fmean-work(i,13)).lt.std.or.work(i,13).lt.1.0d-8)then
|
||||
write(2,310)(work(i,j),j=1,33)
|
||||
endif
|
||||
enddo
|
||||
310 format(33f15.7)
|
||||
end
|
||||
@@ -0,0 +1,103 @@
|
||||
subroutine charlineparser(longchar,nmax,charvars,n)
|
||||
implicit none
|
||||
!7 Sept 2013, revised version
|
||||
!parse a long line of chars into char variables with the following assumptions:
|
||||
!1. Each cell is separated by a separating character which can be either a ',', blank space(s) or anything
|
||||
!with the ASCII code less than and including 032 or larger than and including 127
|
||||
!2. Any separating characters at the end of the line are discarded, i.e.
|
||||
! '1,2,3,4,a,b,c,,,,,,,,,, ,'='1,2,3,4,a,b,c'
|
||||
!3. If there is no entry between two non-comma separating characters,these two separating characters are treated as one.
|
||||
! i.e. '1 2 3 4 a b c'='1,2,3,4,a,b,c'
|
||||
!4. If there is no entry between two commas that are not positioned in the end of the line, a missing value is assumed to
|
||||
!exist between these two commas and this missing value is denoted with -9999, i.e.
|
||||
! i.e. '1,,3,4,a,b,c'='1,-9999,3,4,a,b,c'
|
||||
!5. Comma has priotity as a separating characer. E.g commas and blank spaces are not used simultaneously as
|
||||
! separating characters in a single line. When both commas and blank spaces appear in the line, comma is
|
||||
! the saparating character and blank spaces are repalced with '_'
|
||||
integer nmax,n
|
||||
character longchar*(*),charvars(nmax+100)*50
|
||||
integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma
|
||||
!
|
||||
leng=LEN_TRIM(longchar)
|
||||
i=leng
|
||||
5 k=ichar(longchar(i:i))
|
||||
if(k.eq.44.or.k.le.32.or.k.ge.127)then
|
||||
longchar(i:i)=char(32)
|
||||
i=i-1
|
||||
if(i.gt.1)goto 5
|
||||
!empty line
|
||||
n=0
|
||||
return
|
||||
endif
|
||||
leng=i
|
||||
|
||||
itiscomma=0
|
||||
do i=1,leng
|
||||
if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
|
||||
enddo
|
||||
if(itiscomma.gt.0)then
|
||||
!If the line contains at least one comma, it is assumed a comma separated line
|
||||
n=0
|
||||
do i=1,leng
|
||||
if(ichar(longchar(i:i)).eq.44)then
|
||||
n=n+1
|
||||
posindex(n)=i
|
||||
endif
|
||||
enddo
|
||||
n=n+1
|
||||
posindex(0)=0
|
||||
posindex(n)=leng+1
|
||||
do i=1,n
|
||||
pos1=posindex(i-1)+1
|
||||
pos2=posindex(i)-1
|
||||
If(pos1.gt.pos2)goto 50
|
||||
30 if(ichar(longchar(pos1:pos1)).ge.33.and.
|
||||
&ichar(longchar(pos1:pos1)).le.126)goto 40
|
||||
if(pos1.lt.pos2)then
|
||||
pos1=pos1+1
|
||||
goto 30
|
||||
endif
|
||||
!pos1=pos2 and missing entry
|
||||
pos1=pos2+1
|
||||
goto 50
|
||||
40 if(ichar(longchar(pos2:pos2)).ge.33.and.
|
||||
&ichar(longchar(pos2:pos2)).le.126)goto 50
|
||||
if(pos2.gt.pos1)then
|
||||
pos2=pos2-1
|
||||
goto 40
|
||||
endif
|
||||
pos1=pos2+1
|
||||
50 If(pos1.gt.pos2)then
|
||||
charvars(i)='-9999'
|
||||
else
|
||||
do k=pos1+1,pos2-1
|
||||
if(ichar(longchar(k:k)).le.32.or.
|
||||
&ichar(longchar(k:k)).ge.127)longchar(k:k)='_'
|
||||
enddo
|
||||
charvars(i)=longchar(pos1:pos2)
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
!non-comma separated file
|
||||
n=0
|
||||
pos1=0
|
||||
10 pos1=pos1+1
|
||||
if(pos1.gt.leng)return
|
||||
if(ichar(longchar(pos1:pos1)).le.32.or.
|
||||
&ichar(longchar(pos1:pos1)).ge.127)goto 10
|
||||
!pos1 is the first character in the character variable.
|
||||
!now locate the end character
|
||||
pos2=pos1
|
||||
20 pos2=pos2+1
|
||||
if(ichar(longchar(pos2:pos2)).ge.33.and.
|
||||
&ichar(longchar(pos2:pos2)).le.126)then
|
||||
if(pos2.le.leng)goto 20
|
||||
endif
|
||||
pos2=pos2-1
|
||||
n=n+1
|
||||
charvars(n)=longchar(pos1:pos2)
|
||||
pos1=pos2
|
||||
goto 10
|
||||
return
|
||||
end subroutine charlineparser
|
||||
@@ -0,0 +1,159 @@
|
||||
subroutine testclustering
|
||||
implicit none
|
||||
integer nsamp,ndim,i,ibelong(20),ngroups
|
||||
double precision value(20,20),stdvalue(20,20),critdist
|
||||
value(1,1)=2.105d0
|
||||
value(1,2)=2.301d0
|
||||
value(2,1)=1.902d0
|
||||
value(2,2)=1.8203d0
|
||||
value(3,1)=2.202d0
|
||||
value(3,2)=1.9508d0
|
||||
value(4,1)=1.861111d0
|
||||
value(4,2)=2.05232323d0
|
||||
|
||||
value(5,1)=1.1d0
|
||||
value(5,2)=1.3d0
|
||||
value(6,1)=0.9d0
|
||||
value(6,2)=0.82d0
|
||||
value(7,1)=1.2d0
|
||||
value(7,2)=0.95d0
|
||||
value(8,1)=0.86d0
|
||||
value(8,2)=1.05d0
|
||||
|
||||
value(9,1)=10.1d0
|
||||
value(9,2)=10.3d0
|
||||
value(10,1)=10.9d0
|
||||
value(10,2)=0.82d0
|
||||
value(11,1)=-11.2d0
|
||||
value(11,2)=0.95d0
|
||||
value(12,1)=-20.85d0
|
||||
value(12,2)=1.05d0
|
||||
critdist=0.5d0
|
||||
nsamp=12
|
||||
ndim=2
|
||||
|
||||
call clustering(nsamp,ndim,value(1:nsamp,1:ndim),
|
||||
&critdist,ngroups,ibelong)
|
||||
call aftercluster(nsamp,ndim,value(1:nsamp,1:ndim),
|
||||
&ngroups,ibelong,stdvalue(1:ngroups,1:ndim))
|
||||
do i=1,ngroups
|
||||
write(*,*)i,value(i,1),value(i,2)
|
||||
enddo
|
||||
write(*,*)i
|
||||
do i=1,ngroups
|
||||
write(*,*)i,stdvalue(i,1),stdvalue(i,2)
|
||||
enddo
|
||||
|
||||
end
|
||||
|
||||
!Cluster points with values differing less than a critical distance value
|
||||
subroutine clustering(nsamp,ndim,value,critdist,ngroups,ibelong)
|
||||
implicit none
|
||||
integer nsamp,ndim,ibelong(nsamp),ngroups
|
||||
double precision value(nsamp,ndim),critdist
|
||||
!critdist: critical distance. if negative, the criterion is a percentage value
|
||||
! from the origin (%)
|
||||
!outputs:
|
||||
!ngroups: the number of groups in the input data (value)
|
||||
!ibelong: which group a point belongs
|
||||
integer i,j,k,matrix(nsamp,nsamp),nsum(nsamp)
|
||||
double precision dif,radius(nsamp)
|
||||
|
||||
ngroups=nsamp
|
||||
if(nsamp.le.1)return
|
||||
|
||||
do i=1,nsamp
|
||||
ibelong(i)=-9999
|
||||
if(critdist.lt.0.0d0)then
|
||||
radius(i)=0.0d0
|
||||
do j=1,ndim
|
||||
radius(i)=radius(i)+value(i,j)**2
|
||||
enddo
|
||||
radius(i)=dsqrt(radius(i))*(-critdist*0.01d0)
|
||||
else
|
||||
radius(i)=critdist
|
||||
endif
|
||||
enddo
|
||||
do i=1,nsamp
|
||||
do j=1,nsamp
|
||||
matrix(i,j)=0
|
||||
if(i.ne.j)then
|
||||
dif=0.0d0
|
||||
do k=1,ndim
|
||||
dif=dif+(value(i,k)-value(j,k))**2
|
||||
enddo
|
||||
dif=dsqrt(dif)
|
||||
if(dif.le.radius(i))matrix(i,j)=1
|
||||
endif
|
||||
enddo
|
||||
nsum(i)=0
|
||||
do j=1,nsamp
|
||||
nsum(i)=nsum(i)+matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
ngroups=0
|
||||
!finding the point with the most crowded neighbors
|
||||
50 k=1
|
||||
do i=2,nsamp
|
||||
if(nsum(i).gt.nsum(k))k=i
|
||||
enddo
|
||||
if(nsum(k).eq.0)goto 100
|
||||
ngroups=ngroups+1
|
||||
ibelong(k)=ngroups
|
||||
do i=1,nsamp
|
||||
if(matrix(k,i).ne.0)then
|
||||
ibelong(i)=ngroups
|
||||
do j=1,nsamp
|
||||
matrix(i,j)=0
|
||||
enddo
|
||||
matrix(k,i)=0
|
||||
endif
|
||||
enddo
|
||||
do i=1,nsamp
|
||||
nsum(i)=0
|
||||
do j=1,nsamp
|
||||
nsum(i)=nsum(i)+matrix(i,j)
|
||||
enddo
|
||||
enddo
|
||||
goto 50
|
||||
100 do i=1,nsamp
|
||||
if(ibelong(i).lt.0)then
|
||||
ngroups=ngroups+1
|
||||
ibelong(i)=ngroups
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
subroutine aftercluster(nsamp,ndim,value,ngroups,ibelong,stdvalue)
|
||||
implicit none
|
||||
integer nsamp,ndim,ibelong(nsamp),ngroups
|
||||
double precision value(nsamp,ndim),stdvalue(ngroups,ndim)
|
||||
!ngroups: the number of groups in the input data (value)
|
||||
!ibelong: which group a point belongs
|
||||
!replace the first ngroups in value by the group means and store std in stdvalue
|
||||
integer i,j,k,n
|
||||
double precision fn9999,vector(nsamp),fmean(ngroups,ndim),
|
||||
&xmin,xmax
|
||||
parameter(fn9999=-9999.0d0)
|
||||
do i=1,ngroups
|
||||
do j=1,ndim
|
||||
n=0
|
||||
do k=1,nsamp
|
||||
if(ibelong(k).eq.i)then
|
||||
n=n+1
|
||||
vector(n)=value(k,j)
|
||||
endif
|
||||
enddo
|
||||
call
|
||||
&stdmaxmeanmin(n,vector,stdvalue(i,j),fmean(i,j),xmin,xmax)
|
||||
enddo
|
||||
enddo
|
||||
do i=1,ngroups
|
||||
do j=1,ndim
|
||||
value(i,j)=fmean(i,j)
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,173 @@
|
||||
subroutine curvecrossing(ncurves,nsamp,maxnsamp,xdata,ydata,
|
||||
¶ms,xcross,ycross)
|
||||
implicit none
|
||||
!fit ncurves curves from ncurves pairs of datasets and estimate the mean crossings of the curves
|
||||
integer ncurves,nsamp(ncurves),maxnsamp,i,j,k,n,m,ndim,
|
||||
&iderivative,INFO
|
||||
double precision xdata(ncurves,maxnsamp),ydata(ncurves,maxnsamp),
|
||||
&xcross,ycross,x(maxnsamp),y(maxnsamp),a(ncurves),b(ncurves),
|
||||
&c(ncurves),d(ncurves),beta(10),betamin(10),betamax(10),
|
||||
&weitx(maxnsamp),weity(maxnsamp),xmin(maxnsamp),xmax(maxnsamp),
|
||||
&y_pred(maxnsamp),x_pred(maxnsamp),sumsquare,
|
||||
¶ms(ncurves,4)
|
||||
|
||||
k=0
|
||||
do i=1,ncurves
|
||||
do j=1,4
|
||||
params(i,j)=-9999.0d0
|
||||
enddo
|
||||
n=0
|
||||
do j=1,nsamp(i)
|
||||
if(dabs(xdata(i,j)+9999.0d0).gt.1.0d-8.and.
|
||||
&dabs(ydata(i,j)+9999.0d0).gt.1.0d-8)then
|
||||
n=n+1
|
||||
x(n)=xdata(i,j)
|
||||
y(n)=ydata(i,j)
|
||||
endif
|
||||
enddo
|
||||
if(n.gt.1)then
|
||||
k=k+1
|
||||
beta(1)=30.0d0
|
||||
betamin(1)=0.0d0
|
||||
betamax(1)=200.0d0
|
||||
beta(2)=-4.0d0
|
||||
betamin(2)=-100.0d0
|
||||
betamax(2)=0.0d0
|
||||
beta(3)=8.0d0
|
||||
betamin(3)=0.0d0
|
||||
betamax(3)=200.0d0
|
||||
beta(4)=-0.5d0
|
||||
betamin(4)=-10.0d0
|
||||
betamax(4)=0.0d0
|
||||
do j=1,n
|
||||
weitx(j)=1.0d0
|
||||
weity(j)=1.0d0
|
||||
xmin(j)=0.0d0
|
||||
xmax(j)=x(j)+20.0d0
|
||||
enddo
|
||||
ndim=4
|
||||
iderivative=1
|
||||
call GenericRegres(n,1,y,1,x,weity,weitx,ndim,beta,betamin,
|
||||
&betamax,xmin,xmax,iderivative,0,y_pred,x_pred,sumsquare)
|
||||
a(k)=beta(1)
|
||||
b(k)=beta(2)
|
||||
c(k)=beta(3)
|
||||
d(k)=beta(4)
|
||||
do j=1,ndim
|
||||
params(i,j)=beta(j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
if(k.gt.0)then
|
||||
call curmeancrossing(k,a,b,c,d,xcross,ycross)
|
||||
else
|
||||
xcross=-9999.0d0
|
||||
ycross=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
subroutine curmeancrossing(ncurves,a,b,c,d,xcross,ycross)
|
||||
implicit none
|
||||
!calculate the average crossing point of the ncurves curves.
|
||||
integer ncurves,i,j,k
|
||||
double precision a(ncurves),b(ncurves),c(ncurves),d(ncurves),
|
||||
&xcross,ycross,x(ncurves),y(ncurves),a1,b1,c1,d1,a2,b2,c2,d2,
|
||||
&p,q,u,root1,root2,small,term,x1_root1,x2_root1,x1_root2,x2_root2,
|
||||
&x_root1,x_root2
|
||||
parameter(small=1.0d-7)
|
||||
k=0
|
||||
do i=1,ncurves-1
|
||||
do j=i+1,ncurves
|
||||
a1=a(i)
|
||||
b1=b(i)
|
||||
c1=c(i)
|
||||
d1=d(i)
|
||||
a2=a(j)
|
||||
b2=b(j)
|
||||
c2=c(j)
|
||||
d2=d(j)
|
||||
term=dabs(a1-a2)+dabs(b1-b2)+dabs(c1-c2)
|
||||
if(term.lt.small)goto 100
|
||||
p=a1-a2+d1-d2
|
||||
q=a1*(c2+b1)-a2*(c1+b2)+(d1-d2)*(c2+c1)
|
||||
u=a1*b1*c2-a2*b2*c1+(d1-d2)*c1*c2
|
||||
call quadraticroots(p,q,u,root1,root2)
|
||||
if(root1.gt.0.0d0.or.root2.gt.0.0d0)then
|
||||
k=k+1
|
||||
if(root1.gt.0.0d0.and.root2.gt.0.0d0)then
|
||||
x(k)=root1
|
||||
else
|
||||
if(root1.gt.0.0d0)then
|
||||
x(k)=root1
|
||||
else
|
||||
x(k)=root2
|
||||
endif
|
||||
endif
|
||||
y(k)=a1*(x(k)+b1)/(x(k)+c1)+d1
|
||||
else
|
||||
if(dabs(b1-c1).gt.small)then
|
||||
term=a2*(b2-c2)/(a1*(b1-c1))
|
||||
if(term.ge.0.0d0)then
|
||||
term=dsqrt(term)
|
||||
root1=((d1+a1)*term+d2+a2)/(term+1.0d0)
|
||||
if(dabs(term-1.0d0).gt.small)then
|
||||
root2=((d1+a1)*term-d2-a2)/(term-1.0d0)
|
||||
else
|
||||
root2=-9999.0d0
|
||||
endif
|
||||
x1_root1=-c1+a1*(b1-c1)/(root1-d1-a1)
|
||||
x2_root1=-c2+a2*(b2-c2)/(root1-d2-a2)
|
||||
if(dabs(root2+9999.0d0).gt.small)then
|
||||
x1_root2=-c1+a1*(b1-c1)/(root2-d1-a1)
|
||||
x2_root2=-c2+a2*(b2-c2)/(root2-d2-a2)
|
||||
else
|
||||
x1_root2=-9999.0d0
|
||||
x2_root2=-9999.0d0
|
||||
endif
|
||||
if(x1_root1.gt.0.0d0.and.x2_root1.gt.0.0d0)then
|
||||
x_root1=(x1_root1+x2_root1)/2.0d0
|
||||
else
|
||||
x_root1=-9999.0d0
|
||||
endif
|
||||
if(x1_root2.gt.0.0d0.and.x2_root2.gt.0.0d0)then
|
||||
x_root2=(x1_root2+x2_root2)/2.0d0
|
||||
else
|
||||
x_root2=-9999.0d0
|
||||
endif
|
||||
if(x_root1.gt.0.0d0.or.x_root2.gt.0.0d0)then
|
||||
k=k+1
|
||||
if(x_root1.gt.0.0d0.and.x_root2.gt.0.0d0)then
|
||||
x(k)=x_root2
|
||||
y(k)=root2
|
||||
else
|
||||
if(x_root1.gt.0.0d0)then
|
||||
x(k)=x_root1
|
||||
y(k)=root1
|
||||
else
|
||||
x(k)=x_root2
|
||||
y(k)=root2
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
100 continue
|
||||
enddo
|
||||
enddo
|
||||
if(k.gt.0)then
|
||||
xcross=0.0d0
|
||||
ycross=0.0d0
|
||||
do i=1,k
|
||||
xcross=xcross+x(i)
|
||||
ycross=ycross+y(i)
|
||||
enddo
|
||||
xcross=xcross/dble(k)
|
||||
ycross=ycross/dble(k)
|
||||
else
|
||||
xcross=-9999.0d0
|
||||
ycross=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,32 @@
|
||||
subroutine doy_to_monthday(month,monthday,year,idoy)
|
||||
!extract month,day of month from year and day of year
|
||||
implicit none
|
||||
integer month,monthday,year,idoy,isitaleapyear,
|
||||
&i,j,k,ndays(12)
|
||||
ndays(1)=31
|
||||
ndays(2)=28+isitaleapyear(year)
|
||||
ndays(3)=31
|
||||
ndays(4)=30
|
||||
ndays(5)=31
|
||||
ndays(6)=30
|
||||
ndays(7)=31
|
||||
ndays(8)=31
|
||||
ndays(9)=30
|
||||
ndays(10)=31
|
||||
ndays(11)=30
|
||||
ndays(12)=31
|
||||
k=0
|
||||
do i=1,12
|
||||
do j=1,ndays(i)
|
||||
k=k+1
|
||||
if(k.eq.idoy)then
|
||||
month=i
|
||||
monthday=j
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
month=-9999
|
||||
monthday=-9999
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,190 @@
|
||||
subroutine extCharToFloatNum(numchar0,cpastring,f,ierr)
|
||||
implicit none
|
||||
!Transform a string of length numchar consisting all numbers (e.g. 1234 or 12.19, .123,
|
||||
!or 12.89d+5 or 12.89d-5, d could have been D, e, or E) into a double precision float
|
||||
!number.
|
||||
!ierr=0, successful conversion
|
||||
! =1, conversion failed
|
||||
character astring*50,cpastring*(*),c*1,d*1
|
||||
double precision f,fsign,factor
|
||||
integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
|
||||
& numchar,ierr,ispartnum,nlength
|
||||
|
||||
nlength=len(trim(cpastring))
|
||||
!
|
||||
!return error with empty string
|
||||
if(nlength.eq.0)then
|
||||
f=-9999.0d0
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
if(index(cpastring,'n').ne.0)then
|
||||
!in case of 'nan'
|
||||
f=-9999.0d0
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
if(index(cpastring,'N').ne.0)then
|
||||
!in case of 'NAN'
|
||||
f=-9999.0d0
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
!First remove space and change '.123' to '0.123'
|
||||
ipos1=0
|
||||
numchar=0
|
||||
i=0
|
||||
10 i=i+1
|
||||
if(numchar.eq.nlength)goto 11
|
||||
c=cpastring(i:i)
|
||||
if(ispartnum(c).eq.1)then
|
||||
if(ipos1.eq.0)ipos1=i
|
||||
numchar=numchar+1
|
||||
goto 10
|
||||
else
|
||||
if(numchar.eq.0)goto 10
|
||||
endif
|
||||
11 astring=cpastring(ipos1:(ipos1+numchar-1))
|
||||
if(astring(numchar:numchar).eq.'.')then
|
||||
astring=astring(1:numchar)//'0'
|
||||
numchar=numchar+1
|
||||
endif
|
||||
if(astring(1:1).eq.'.')then
|
||||
astring='0'//astring(1:numchar)
|
||||
numchar=numchar+1
|
||||
endif
|
||||
if(astring(1:2).eq.'-.')then
|
||||
astring='-0.'//astring(3:numchar)
|
||||
numchar=numchar+1
|
||||
endif
|
||||
if(astring(1:2).eq.'+.')then
|
||||
astring='0.'//astring(3:numchar)
|
||||
endif
|
||||
ierr=1
|
||||
f=-9999.0d0
|
||||
fsign=1.0d0
|
||||
ipos1=1
|
||||
190 c=astring(ipos1:ipos1)
|
||||
if(ispartnum(c).eq.1)goto 200
|
||||
ipos1=ipos1+1
|
||||
goto 190
|
||||
200 ipos2=ipos1+numchar-1
|
||||
if(astring(ipos1:ipos1).eq.'-')then
|
||||
ipos1=ipos1+1
|
||||
fsign=-1.0d0
|
||||
else
|
||||
if(astring(ipos1:ipos1).eq.'+')ipos1=ipos1+1
|
||||
endif
|
||||
ideci=index(astring,'.')
|
||||
if(ideci.eq.0)then
|
||||
!1234, 1234e+6, 1234e-6,1234e6, e can be E, d, or D
|
||||
m=ipos2
|
||||
else
|
||||
m=ideci-1
|
||||
endif
|
||||
factor=1.0d0
|
||||
k=0
|
||||
j=0
|
||||
i=m
|
||||
210 c=astring(i:i)
|
||||
if(c.eq.'+'.or.c.eq.'-')then
|
||||
if(i.eq.m)return
|
||||
if(i.gt.(ipos1+1))then
|
||||
i=i-1
|
||||
d=astring(i:i)
|
||||
if(d.eq.'e'.or.d.eq.'E'.or.d.eq.'d'.or.d.eq.'D')then
|
||||
if(c.eq.'+')then
|
||||
factor=10.0d0**(dble(k))
|
||||
else
|
||||
factor=10.0d0**(dble(-k))
|
||||
endif
|
||||
else
|
||||
return
|
||||
endif
|
||||
k=0
|
||||
j=0
|
||||
else
|
||||
return
|
||||
endif
|
||||
else
|
||||
if(c.eq.'e'.or.c.eq.'E'.or.c.eq.'d'.or.c.eq.'D')then
|
||||
if(i.eq.m)return
|
||||
if(i.gt.ipos1)then
|
||||
factor=10.0d0**(dble(k))
|
||||
k=0
|
||||
j=0
|
||||
else
|
||||
return
|
||||
endif
|
||||
else
|
||||
if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then
|
||||
k=k+(ichar(c)-48)*(10**j)
|
||||
j=j+1
|
||||
else
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if(i.gt.ipos1)then
|
||||
i=i-1
|
||||
goto 210
|
||||
endif
|
||||
f=dble(k)*factor
|
||||
k=0
|
||||
if(ideci.gt.0)then
|
||||
!18.27 type of character
|
||||
i=ideci+1
|
||||
220 c=astring(i:i)
|
||||
if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then
|
||||
k=k+1
|
||||
f=f+dble(ichar(c)-48)*(10.0d0**(-k))
|
||||
if(i.lt.ipos2)then
|
||||
i=i+1
|
||||
goto 220
|
||||
endif
|
||||
else
|
||||
if(c.eq.'e'.or.c.eq.'E'.or.c.eq.'d'.or.c.eq.'D')then
|
||||
if(i.eq.ipos2)return
|
||||
if(astring(ipos2:ipos2).eq.'+'.or.
|
||||
& astring(ipos2:ipos2).eq.'-')return
|
||||
i=i+1
|
||||
c=astring(i:i)
|
||||
ipos1=i+1
|
||||
if(c.eq.'-')then
|
||||
m=0
|
||||
else
|
||||
m=1
|
||||
if(c.ne.'+')then
|
||||
if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then
|
||||
ipos1=i
|
||||
else
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
k=0
|
||||
j=0
|
||||
do i=ipos2,ipos1,-1
|
||||
c=astring(i:i)
|
||||
if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then
|
||||
k=k+(ichar(c)-48)*(10**j)
|
||||
j=j+1
|
||||
else
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
if(m.eq.0)then
|
||||
f=f/(10.0d0**dble(k))
|
||||
else
|
||||
f=f*(10.0d0**dble(k))
|
||||
endif
|
||||
else
|
||||
return
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
f=f*fsign
|
||||
ierr=0
|
||||
return
|
||||
end subroutine extCharToFloatNum
|
||||
|
||||
@@ -0,0 +1,305 @@
|
||||
!Identifying the flat portion of a curve by computing the mean slope of
|
||||
!all possible pairs. Data must be ranked with xvar from low to high
|
||||
subroutine findplateau(npoints,xvar,yvar,iflat,
|
||||
& flatmean,radius)
|
||||
implicit none
|
||||
integer npoints,iflat(npoints),isoutlier_1side
|
||||
double precision xvar(npoints),yvar(npoints),
|
||||
& flatmean,radius,t0,ymax
|
||||
integer i,j,k,m,n,nstart,nend,isslopezero,no1,no2,
|
||||
& no3,nset
|
||||
double precision der(npoints*(npoints-1)/2),std,term,
|
||||
& student_t,slopemin,Sign_Level,coeffvar,coeffvarmin,
|
||||
& xx(npoints),yy(npoints),ainter,bslope,r,eps
|
||||
parameter(Sign_Level=0.90d0,eps=1.0d-6,nset=3)
|
||||
|
||||
do i=1,npoints
|
||||
iflat(i)=1
|
||||
enddo
|
||||
nend=-9999
|
||||
nstart=0
|
||||
slopemin=1.0d+9
|
||||
coeffvarmin=1.0d+9
|
||||
flatmean=-9999.0d0
|
||||
radius=-9999.0d0
|
||||
|
||||
ymax=0.0d0
|
||||
do i=1,nset
|
||||
ymax=ymax+yvar(i)
|
||||
enddo
|
||||
ymax=ymax/dble(nset)
|
||||
nstart=1
|
||||
do i=2,npoints-nset+1
|
||||
term=0.0d0
|
||||
do j=i,i+nset-1
|
||||
term=term+yvar(j)
|
||||
enddo
|
||||
term=term/dble(nset)
|
||||
if(term.ge.ymax)then
|
||||
ymax=term
|
||||
nstart=i
|
||||
endif
|
||||
enddo
|
||||
no1=nstart
|
||||
do i=nstart+1,nstart+nset-1
|
||||
if(yvar(i).ge.yvar(no1))then
|
||||
no1=i
|
||||
endif
|
||||
enddo
|
||||
nstart=1
|
||||
500 k=no1-nstart+1
|
||||
if(k.lt.3)then
|
||||
nstart=no1
|
||||
goto 510
|
||||
endif
|
||||
do i=nstart,no1
|
||||
xx(i-nstart+1)=xvar(i)
|
||||
yy(i-nstart+1)=yvar(i)
|
||||
enddo
|
||||
call linregres(k,xx,yy,Sign_Level,ainter,
|
||||
& bslope,r,radius,isslopezero)
|
||||
if(isslopezero.eq.-1)then
|
||||
nstart=nstart+1
|
||||
goto 500
|
||||
endif
|
||||
510 nend=no1
|
||||
if((nend-nstart+1).le.4)then
|
||||
k=nstart
|
||||
do i=1,k-1
|
||||
do j=k,nend
|
||||
if(yvar(j).lt.yvar(i))then
|
||||
nstart=no1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
nend=npoints
|
||||
600 k=nend-no1+1
|
||||
if(k.lt.3)then
|
||||
nend=no1
|
||||
goto 610
|
||||
endif
|
||||
do i=no1,nend
|
||||
xx(i-no1+1)=xvar(i)
|
||||
yy(i-no1+1)=yvar(i)
|
||||
enddo
|
||||
call linregres(k,xx,yy,Sign_Level,ainter,
|
||||
& bslope,r,radius,isslopezero)
|
||||
if(isslopezero.eq.-1)then
|
||||
nend=nend-1
|
||||
goto 600
|
||||
endif
|
||||
610 if((nend-no1+1).le.4)then
|
||||
k=nend
|
||||
do i=k+1,npoints
|
||||
do j=no1,k
|
||||
if(yvar(j).lt.yvar(i))then
|
||||
nend=no1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
if((nend-nstart).eq.0)then
|
||||
if(no1.eq.npoints)return
|
||||
if(no1.eq.1)then
|
||||
do i=1,npoints
|
||||
iflat(i)=3
|
||||
enddo
|
||||
return
|
||||
endif
|
||||
nstart=no1-1
|
||||
nend=no1
|
||||
endif
|
||||
goto 100
|
||||
|
||||
!find the three largest value in yvar
|
||||
if(yvar(1).lt.yvar(2))then
|
||||
no1=2
|
||||
no2=1
|
||||
else
|
||||
no1=1
|
||||
no2=2
|
||||
endif
|
||||
if(yvar(3).ge.yvar(no1))then
|
||||
no3=no2
|
||||
no2=no1
|
||||
no1=3
|
||||
else
|
||||
if(yvar(3).lt.yvar(no2))then
|
||||
no3=3
|
||||
else
|
||||
no3=no2
|
||||
no2=3
|
||||
endif
|
||||
endif
|
||||
do i=4,npoints
|
||||
if(yvar(i).ge.yvar(no1))then
|
||||
no3=no2
|
||||
no2=no1
|
||||
no1=i
|
||||
else
|
||||
if(yvar(i).ge.yvar(no2))then
|
||||
no3=no2
|
||||
no2=i
|
||||
else
|
||||
if(yvar(i).ge.yvar(no3))then
|
||||
no3=i
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
If(no1.gt.no2.and.no1.gt.no3)then
|
||||
nend=no1
|
||||
if(no2.gt.no3)then
|
||||
nstart=no3
|
||||
else
|
||||
nstart=no2
|
||||
endif
|
||||
endif
|
||||
If(no2.gt.no1.and.no2.gt.no3)then
|
||||
nend=no2
|
||||
if(no1.gt.no3)then
|
||||
nstart=no3
|
||||
else
|
||||
nstart=no1
|
||||
endif
|
||||
endif
|
||||
If(no3.gt.no1.and.no3.gt.no2)then
|
||||
nend=no3
|
||||
if(no1.gt.no2)then
|
||||
nstart=no2
|
||||
else
|
||||
nstart=no1
|
||||
endif
|
||||
endif
|
||||
if(nstart.gt.1)then
|
||||
i=1
|
||||
2 if(dabs(yvar(i)-yvar(no1)).lt.eps.or.
|
||||
& dabs(yvar(i)-yvar(no2)).lt.eps.or.
|
||||
& dabs(yvar(i)-yvar(no3)).lt.eps)then
|
||||
nstart=i
|
||||
goto 1
|
||||
endif
|
||||
i=i+1
|
||||
if(i.eq.nstart)goto 1
|
||||
goto 2
|
||||
endif
|
||||
1 if(nend.lt.npoints)then
|
||||
i=nend+1
|
||||
3 if(dabs(yvar(i)-yvar(no1)).lt.eps.or.
|
||||
& dabs(yvar(i)-yvar(no2)).lt.eps.or.
|
||||
& dabs(yvar(i)-yvar(no3)).lt.eps)then
|
||||
nend=i
|
||||
endif
|
||||
if(i.eq.npoints)goto 4
|
||||
i=i+1
|
||||
goto 3
|
||||
endif
|
||||
4 do i=nstart,nend
|
||||
xx(i-nstart+1)=xvar(i)
|
||||
yy(i-nstart+1)=yvar(i)
|
||||
enddo
|
||||
k=nend-nstart+1
|
||||
call linregres(k,xx,yy,Sign_Level,ainter,
|
||||
& bslope,r,radius,isslopezero)
|
||||
if(isslopezero.eq.-1)then
|
||||
if(no1.eq.npoints)return
|
||||
if(no1.eq.nstart)then
|
||||
nstart=no1
|
||||
nend=no1
|
||||
goto 100
|
||||
endif
|
||||
if(no1.gt.no2)then
|
||||
nstart=no2
|
||||
nend=no1
|
||||
else
|
||||
nstart=no1
|
||||
nend=no2
|
||||
endif
|
||||
goto 100
|
||||
endif
|
||||
slopemin=dabs(bslope)
|
||||
call stdmean(k,yy,std,flatmean)
|
||||
coeffvarmin=std/flatmean
|
||||
10 if(nend.eq.npoints)goto 50
|
||||
if(no1.eq.nend)then
|
||||
if(dabs(yvar(nend+1)-yvar(no1)).lt.eps.or.
|
||||
& dabs(yvar(nend+1)-yvar(no2)).lt.eps.or.
|
||||
& dabs(yvar(nend+1)-yvar(no3)).lt.eps)then
|
||||
nend=nend+1
|
||||
goto 10
|
||||
else
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
do k=no1,nend+1
|
||||
xx(k-no1+1)=xvar(k)
|
||||
yy(k-no1+1)=yvar(k)
|
||||
enddo
|
||||
k=nend+1-no1+1
|
||||
call linregres(k,xx,yy,Sign_Level,ainter,bslope,
|
||||
& r,radius,isslopezero)
|
||||
if(isslopezero.eq.-1)goto 50
|
||||
call stdmean(k,yy,std,flatmean)
|
||||
coeffvar=std/flatmean
|
||||
nend=nend+1
|
||||
goto 10
|
||||
50 if(nstart.eq.1)goto 100
|
||||
if(no1.eq.nstart)then
|
||||
if(dabs(yvar(nstart-1)-yvar(no1)).lt.eps.or.
|
||||
& dabs(yvar(nstart-1)-yvar(no2)).lt.eps.or.
|
||||
& dabs(yvar(nstart-1)-yvar(no3)).lt.eps)then
|
||||
nstart=nstart-1
|
||||
goto 50
|
||||
else
|
||||
goto 100
|
||||
endif
|
||||
endif
|
||||
do k=nstart-1,no1
|
||||
xx(k-nstart+1+1)=xvar(k)
|
||||
yy(k-nstart+1+1)=yvar(k)
|
||||
enddo
|
||||
k=no1-(nstart-1)+1
|
||||
call linregres(k,xx,yy,Sign_Level,ainter,bslope,
|
||||
& r,radius,isslopezero)
|
||||
if(isslopezero.eq.-1)goto 100
|
||||
call stdmean(k,yy,std,flatmean)
|
||||
coeffvar=std/flatmean
|
||||
nstart=nstart-1
|
||||
goto 50
|
||||
|
||||
100 if(nstart.le.nend)then
|
||||
n=0
|
||||
do i=nstart,nend
|
||||
n=n+1
|
||||
der(n)=yvar(i)
|
||||
enddo
|
||||
if(n.gt.1)then
|
||||
call stdmean(n,der,std,flatmean)
|
||||
t0=student_t(n-1,Sign_Level)
|
||||
radius=t0*std/dsqrt(dble(n))
|
||||
else
|
||||
flatmean=der(1)
|
||||
radius=-9999.0d0
|
||||
endif
|
||||
do i=1,nstart-1
|
||||
iflat(i)=1
|
||||
enddo
|
||||
do i=nstart,nend
|
||||
iflat(i)=2
|
||||
enddo
|
||||
do i=nend+1,npoints
|
||||
iflat(i)=3
|
||||
enddo
|
||||
if(n.gt.2)then
|
||||
k=isoutlier_1side(n,der,-1)
|
||||
if(k.eq.1)then
|
||||
iflat(nstart)=1
|
||||
endif
|
||||
if(k.eq.n)then
|
||||
iflat(nend)=3
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,11 @@
|
||||
subroutine fortranswap(n,x1,x2)
|
||||
implicit none
|
||||
integer n,i
|
||||
double precision x1(n),x2(n),term
|
||||
do i=1,n
|
||||
term=x1(i)
|
||||
x1(i)=x2(i)
|
||||
x2(i)=term
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,110 @@
|
||||
subroutine ftest(data1,n1,data2,n2,f,prob)
|
||||
implicit none
|
||||
integer n1,n2
|
||||
double precision f,prob,data1(n1),data2(n2)
|
||||
!given the arrays data1 and data2, this routine returns the value of f
|
||||
!and the significance as prob. Small values of prob indicate that the
|
||||
!two arrays have significantly different variances
|
||||
double precision ave1,ave2,df1,df2,var1,var2,betai,
|
||||
&xmin,xmax
|
||||
call stdmaxmeanmin(n1,data1,var1,ave1,xmin,xmax)
|
||||
var1=var1*var1
|
||||
call stdmaxmeanmin(n2,data2,var2,ave2,xmin,xmax)
|
||||
var2=var2*var2
|
||||
if(var1.gt.var2)then
|
||||
f=var1/var2
|
||||
df1=dble(n1-1)
|
||||
df2=dble(n2-1)
|
||||
else
|
||||
f=var2/var1
|
||||
df1=dble(n2-1)
|
||||
df2=dble(n1-1)
|
||||
endif
|
||||
prob=2.0d0*betai(0.5d0*df2,0.5d0*df1,df2/(df2+df1*f))
|
||||
if(prob.gt.1.0d0)prob=2.0d0-prob
|
||||
return
|
||||
end
|
||||
|
||||
c####################################################################
|
||||
subroutine ftestrsq_rms(ymeas,ypred,n0,nparams,rsq,rms,agrind,
|
||||
&rmse_norm,rmse_perc,aic,aicc,f,prob)
|
||||
implicit double precision (a-h,l,o-z)
|
||||
dimension ymeas(n0),ypred(n0),y1(n0),y2(n0)
|
||||
fn9999=-9999.0d0
|
||||
tiny=1.0d-7
|
||||
n=0
|
||||
do i=1,n0
|
||||
if(dabs(ymeas(i)-fn9999).gt.tiny.and.
|
||||
&dabs(ypred(i)-fn9999).gt.tiny)then
|
||||
n=n+1
|
||||
y1(n)=ymeas(i)
|
||||
y2(n)=ypred(i)
|
||||
endif
|
||||
enddo
|
||||
ymin=y1(1)
|
||||
ymax=y1(1)
|
||||
do i=2,n
|
||||
if(y1(i).lt.ymin)ymin=y1(i)
|
||||
if(y1(i).gt.ymax)ymax=y1(i)
|
||||
enddo
|
||||
sum=0.0d0
|
||||
rmse_perc=0.0d0
|
||||
do 10 i=1,n
|
||||
sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i))
|
||||
rmse_perc=rmse_perc+(y1(i)-y2(i))*(y1(i)-y2(i))/(y2(i)*y2(i))
|
||||
10 continue
|
||||
rms=dsqrt(sum/dble(n))
|
||||
if(nparams.gt.0)then
|
||||
aic=dble(n)*dlog(rms*rms)+2.0d0*dble(nparams)
|
||||
aicc=aic+2.0d0*dble(nparams*(nparams+1))/dble(n-nparams-1)
|
||||
else
|
||||
aic=-9999.0d0
|
||||
aicc=-9999.0d0
|
||||
endif
|
||||
rmse_norm=rms/(ymax-ymin)
|
||||
rmse_perc=100.0d0*dsqrt(rmse_perc/dble(n))
|
||||
ymean1=0.0d0
|
||||
ymean2=0.0d0
|
||||
do 20 i=1,n
|
||||
ymean1=ymean1+y1(i)
|
||||
ymean2=ymean2+y2(i)
|
||||
20 continue
|
||||
ymean1=ymean1/dble(n)
|
||||
ymean2=ymean2/dble(n)
|
||||
sum1=0.0d0
|
||||
sum2=0.0d0
|
||||
sum3=0.0d0
|
||||
sum4=0.0d0
|
||||
sum5=0.0d0
|
||||
do 30 i=1,n
|
||||
sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1
|
||||
sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2
|
||||
sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3
|
||||
sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4
|
||||
sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))*
|
||||
&(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5
|
||||
sum6=sum6+(y2(i)-ymean1)*(y2(i)-ymean1)
|
||||
30 continue
|
||||
if((sum2*sum3).eq.0.0d0)then
|
||||
rsq=-9999.0d0
|
||||
else
|
||||
rsq=sum1/dsqrt(sum2*sum3)
|
||||
rsq=rsq*rsq
|
||||
endif
|
||||
if(sum5.eq.0.0d0)then
|
||||
agrind=-9999.0d0
|
||||
else
|
||||
agrind=1.0d0-sum4/sum5
|
||||
endif
|
||||
if(rsq.gt.0.0d0)then
|
||||
df1=dble(nparams-1)
|
||||
df2=dble(n-nparams)
|
||||
f=(sum6/df1)/(sum4/df2)
|
||||
prob=betai(0.5d0*df2,0.5d0*df1,df2/(df2+df1*f))
|
||||
else
|
||||
f=-9999.0d0
|
||||
prob=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
!####################################################################
|
||||
@@ -0,0 +1,148 @@
|
||||
!This subroutine fills gaps in the y variable based on neural network regression
|
||||
subroutine gapfilling(nx,nobs,xsamp,ysamp,nmax,maxdist)
|
||||
implicit none
|
||||
!Gaps must be represented by -9999
|
||||
!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension
|
||||
!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used
|
||||
!in x may be different.
|
||||
!If a gap is less than maxdist points away from a previous gap for which a fit was conducted and if
|
||||
!the dimension is the same, then the previous fit is used (a new fit is not conducted)
|
||||
integer nx,nobs,nmax
|
||||
double precision xsamp(1:nobs,1:nx),ysamp(1:nobs)
|
||||
!Locals
|
||||
integer i,j,k,n,idowhat,nh,nxfit,nobsfit,negobsfit,ixuse(nx),
|
||||
&ipregap,iposfit(-nmax:nmax),iuseit,ixuse_pre(nx),maxdist
|
||||
parameter(nh=15)
|
||||
double precision w(1:nx,1:nh),bph(nh),q(nh),bend,
|
||||
&xnew(nx),calvalue(nobs),fn9999,tiny,xfit(-nmax:nmax,nx),
|
||||
&yfit(-nmax:nmax),rsq,ysamppred(nobs)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-6)
|
||||
!
|
||||
bend=fn9999
|
||||
ipregap=-100000
|
||||
do i=1,nobs
|
||||
ysamppred(i)=ysamp(i)
|
||||
if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000
|
||||
!a gap
|
||||
nxfit=0
|
||||
do j=1,nx
|
||||
if(dabs(xsamp(i,j)-fn9999).lt.tiny)then
|
||||
!this x dimension is not used
|
||||
ixuse(j)=0
|
||||
else
|
||||
!this x dimension is used
|
||||
nxfit=nxfit+1
|
||||
xnew(nxfit)=xsamp(i,j)
|
||||
ixuse(j)=1
|
||||
endif
|
||||
enddo
|
||||
if(nxfit.eq.0)goto 1000
|
||||
if((i-ipregap).lt.maxdist)then
|
||||
iuseit=1
|
||||
do j=1,nx
|
||||
if(ixuse(j).ne.ixuse_pre(j))iuseit=0
|
||||
enddo
|
||||
if(iuseit.eq.1)goto 30
|
||||
endif
|
||||
|
||||
!Fill this gap by choosing the nmax valid points that are closest to i for the fitting
|
||||
!First pick up nmax points from the lower side, index positive
|
||||
nobsfit=0
|
||||
n=i-1
|
||||
1 if(n.lt.1)goto 2
|
||||
if(dabs(ysamp(n)-fn9999).gt.tiny)then
|
||||
iuseit=1
|
||||
!make sure it has the x dimensions needed
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0
|
||||
endif
|
||||
enddo
|
||||
if(iuseit.eq.1)then
|
||||
nobsfit=nobsfit+1
|
||||
yfit(nobsfit)=ysamp(n)
|
||||
iposfit(nobsfit)=n
|
||||
k=0
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
k=k+1
|
||||
xfit(nobsfit,k)=xsamp(n,j)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
if(nobsfit.lt.nmax)then
|
||||
n=n-1
|
||||
goto 1
|
||||
endif
|
||||
!
|
||||
!now pick up nmax points form the higher side, index negative
|
||||
2 negobsfit=1
|
||||
n=i+1
|
||||
3 if(n.gt.nobs)goto 4
|
||||
if(dabs(ysamp(n)-fn9999).gt.tiny)then
|
||||
iuseit=1
|
||||
!make sure it has the x dimensions needed
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0
|
||||
endif
|
||||
enddo
|
||||
if(iuseit.eq.1)then
|
||||
negobsfit=negobsfit-1
|
||||
yfit(negobsfit)=ysamp(n)
|
||||
iposfit(negobsfit)=n
|
||||
k=0
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
k=k+1
|
||||
xfit(negobsfit,k)=xsamp(n,j)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
if(negobsfit.gt.-nmax)then
|
||||
n=n+1
|
||||
goto 3
|
||||
endif
|
||||
|
||||
!finally pick up the nmax closest points
|
||||
4 if((nobsfit-negobsfit+1).le.nmax)goto 10
|
||||
if((i-iposfit(nobsfit)).gt.(iposfit(negobsfit)-i))then
|
||||
nobsfit=nobsfit-1
|
||||
else
|
||||
negobsfit=negobsfit+1
|
||||
endif
|
||||
goto 4
|
||||
10 do n=negobsfit,0
|
||||
nobsfit=nobsfit+1
|
||||
yfit(nobsfit)=yfit(n)
|
||||
do j=1,nxfit
|
||||
xfit(nobsfit,j)=xfit(n,j)
|
||||
enddo
|
||||
enddo
|
||||
idowhat=1
|
||||
call NeuralNetRegres(idowhat,nxfit,nobsfit,nh,
|
||||
&xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i))
|
||||
|
||||
do j=1,nobsfit
|
||||
write(122,*)j,yfit(j),calvalue(j)
|
||||
enddo
|
||||
|
||||
ipregap=i
|
||||
do j=1,nxfit
|
||||
ixuse_pre(j)=ixuse(j)
|
||||
enddo
|
||||
30 idowhat=2
|
||||
call NeuralNetRegres(idowhat,nxfit,1,nh,
|
||||
&xfit(1:1,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i))
|
||||
1000 continue
|
||||
enddo
|
||||
do i=1,nobs
|
||||
ysamp(i)=ysamppred(i)
|
||||
enddo
|
||||
300 format(10f16.8)
|
||||
return
|
||||
end subroutine gapfilling
|
||||
@@ -0,0 +1,103 @@
|
||||
!This subroutine fills gaps in the y variable based on neural network regression
|
||||
subroutine gapfilling(nx,nobs,xsamp,ysamp,nmax)
|
||||
implicit none
|
||||
!Gaps must be represented by -9999
|
||||
!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension
|
||||
!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used
|
||||
!in x may be different.
|
||||
integer nx,nobs,nmax
|
||||
double precision xsamp(1:nobs,1:nx),ysamp(1:nobs)
|
||||
!Locals
|
||||
integer i,j,k,n,idowhat,nh,nxfit,nobsfit,ixuse(nx),
|
||||
&iposdif,itakethis,iposfit(nobs),iuseit
|
||||
parameter(nh=5)
|
||||
double precision w(1:nx,1:nh),bph(nh),q(nh),bend,
|
||||
&xnew(nx),calvalue(nobs),fn9999,tiny,xfit(nobs,nx),
|
||||
&yfit(nobs),rsq,x1pre(nmax),ysamppred(nobs)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-6)
|
||||
!
|
||||
do i=1,nmax
|
||||
x1pre(i)=fn9999
|
||||
enddo
|
||||
bend=fn9999
|
||||
do i=1,nobs
|
||||
ysamppred(i)=ysamp(i)
|
||||
if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000
|
||||
!a gap
|
||||
nxfit=0
|
||||
do j=1,nx
|
||||
if(dabs(xsamp(i,j)-fn9999).lt.tiny)then
|
||||
!this x dimension is not used
|
||||
ixuse(j)=0
|
||||
else
|
||||
!this x dimension is used
|
||||
nxfit=nxfit+1
|
||||
xnew(nxfit)=xsamp(i,j)
|
||||
ixuse(j)=1
|
||||
endif
|
||||
enddo
|
||||
if(nxfit.eq.0)goto 1000
|
||||
!Fill this gap by choosing the nmax valid points that are closest to i for the fitting
|
||||
nobsfit=0
|
||||
10 iposdif=10000000
|
||||
do n=1,nobs
|
||||
if(n.ne.i.and.dabs(ysamp(n)-fn9999).gt.tiny)then
|
||||
iuseit=1
|
||||
!make sure it is not one that has been already selected
|
||||
do k=1,nobsfit
|
||||
if(n.eq.iposfit(k))iuseit=0
|
||||
enddo
|
||||
if(iuseit.eq.1)then
|
||||
!make sure it has the x dimensions needed
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
if(iuseit.eq.1)then
|
||||
!make sure the distance is smaller than the current miminum
|
||||
if(iabs(n-i).lt.iposdif)then
|
||||
iposdif=iabs(n-i)
|
||||
itakethis=n
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
nobsfit=nobsfit+1
|
||||
iposfit(nobsfit)=itakethis
|
||||
yfit(nobsfit)=ysamp(itakethis)
|
||||
n=0
|
||||
do j=1,nx
|
||||
if(ixuse(j).eq.1)then
|
||||
n=n+1
|
||||
xfit(nobsfit,n)=xsamp(itakethis,j)
|
||||
endif
|
||||
enddo
|
||||
if(nobsfit.lt.nmax)goto 10
|
||||
!We test to see if the same set has been used in the
|
||||
!fitting before.
|
||||
do n=1,nobsfit
|
||||
if(dabs(xfit(n,1)-x1pre(n)).gt.tiny)goto 20
|
||||
enddo
|
||||
!this set has been fit in the previous step
|
||||
goto 30
|
||||
20 idowhat=1
|
||||
call NeuralNetRegres(idowhat,nxfit,nobsfit,nh,
|
||||
&xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i))
|
||||
do n=1,nobsfit
|
||||
x1pre(n)=xfit(n,1)
|
||||
enddo
|
||||
30 idowhat=2
|
||||
call NeuralNetRegres(idowhat,nxfit,1,nh,
|
||||
&xfit(1:1,1:nxfit),yfit,calvalue,rsq,
|
||||
&w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i))
|
||||
1000 continue
|
||||
enddo
|
||||
do i=1,nobs
|
||||
ysamp(i)=ysamppred(i)
|
||||
enddo
|
||||
300 format(10f16.8)
|
||||
return
|
||||
end subroutine gapfilling
|
||||
@@ -0,0 +1,109 @@
|
||||
! program main
|
||||
! implicit none
|
||||
! double precision gasdev2,x(2000),std1,fmean1,
|
||||
! & std2,fmean2,gasdev
|
||||
! integer idum,i,n
|
||||
! idum=-1
|
||||
! do i=5,2000
|
||||
! do n=1,i
|
||||
! x(n)=gasdev2()
|
||||
! enddo
|
||||
! call stdmean(i,x,std1,fmean1)
|
||||
! do n=1,i
|
||||
! x(n)=gasdev(idum)
|
||||
! enddo
|
||||
! call stdmean(i,x,std2,fmean2)
|
||||
! write(2,310)i,std1,fmean1,std2,fmean2
|
||||
! enddo
|
||||
!310 format(1x,i8,4f15.10)
|
||||
! end
|
||||
!
|
||||
double precision function gasdev2()
|
||||
implicit none
|
||||
!
|
||||
! Return a normally distributed deviate with zero mean and unit variance,
|
||||
!
|
||||
integer iset
|
||||
double precision fac,gset,rsq,v1,v2,ran2
|
||||
save iset,gset
|
||||
data iset/0/
|
||||
|
||||
if(iset.eq.0)then
|
||||
1 v1=2.0d0*ran2()-1.0d0
|
||||
v2=2.0d0*ran2()-1.0d0
|
||||
rsq=v1*v1+v2*v2
|
||||
if(rsq.ge.1.0d0.or.rsq.eq.0.0d0)goto 1
|
||||
fac=dsqrt(-2.0d0*dlog(rsq)/rsq)
|
||||
gset=v1*fac
|
||||
gasdev2=v2*fac
|
||||
iset=1
|
||||
else
|
||||
gasdev2=gset
|
||||
iset=0
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
double precision function gasdev(idum)
|
||||
implicit none
|
||||
integer idum
|
||||
!
|
||||
! Return a normally distributed deviate with zero mean and unit variance,
|
||||
! using ran1(idum) as the source of uniform deviates
|
||||
integer iset
|
||||
double precision fac,gset,rsq,v1,v2,ran1
|
||||
save iset,gset
|
||||
data iset/0/
|
||||
if(idum.lt.0)iset=0
|
||||
if(iset.eq.0)then
|
||||
1 v1=2.0d0*ran1(idum)-1.0d0
|
||||
v2=2.0d0*ran1(idum)-1.0d0
|
||||
rsq=v1*v1+v2*v2
|
||||
if(rsq.ge.1.0d0.or.rsq.eq.0.0d0)goto 1
|
||||
fac=dsqrt(-2.0d0*dlog(rsq)/rsq)
|
||||
gset=v1*fac
|
||||
gasdev=v2*fac
|
||||
iset=1
|
||||
else
|
||||
gasdev=gset
|
||||
iset=0
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
double precision function ran1(idum)
|
||||
implicit none
|
||||
integer idum,IA,IM,IQ,IR,NTAB,NDIV
|
||||
double precision AM,EPS,RNMX
|
||||
PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
|
||||
& IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
|
||||
& RNMX=1.0d0-EPS)
|
||||
!
|
||||
! Minimal random number generator of Park and Miller with Bays-Durham shuffle and
|
||||
! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive
|
||||
! of the endpoint values. Call with idum a negative integer to initilize;
|
||||
! thereafter, do not alter idum between successive deviates in a sequence. RNMX
|
||||
! should approximate the largest floating value that is less than 1.
|
||||
!
|
||||
integer j,k,iv(NTAB),iy
|
||||
save iv,iy
|
||||
data iv /NTAB*0/,iy /0/
|
||||
if(idum.le.0.or.iy.eq.0)then
|
||||
idum=max(-idum,1)
|
||||
do j=NTAB+8,1,-1
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if(idum.lt.0)idum=idum+IM
|
||||
if(j.le.NTAB)iv(j)=idum
|
||||
enddo
|
||||
iy=iv(1)
|
||||
endif
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if(idum.lt.0)idum=idum+IM
|
||||
j=1+iy/NDIV
|
||||
iy=iv(j)
|
||||
iv(j)=idum
|
||||
ran1=dmin1(AM*iy,RNMX)
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,128 @@
|
||||
subroutine gridsampling(sampfunc,ihowsamp,nparams,
|
||||
& msect0,bestguess,yatguess,guessconfid0,bmax,bmin)
|
||||
implicit none
|
||||
!
|
||||
integer nparams,msect0,ihowsamp
|
||||
double precision bestguess(nparams),guessconfid0,
|
||||
& bmax(nparams),bmin(nparams),params(nparams,msect0+1),
|
||||
& guessconfid,yatguess,beta(nparams),fatbeta
|
||||
integer i,nright,nleft,j,k,n,msect,m
|
||||
double precision accum,x1,delta,eps
|
||||
|
||||
logical resetran2
|
||||
common /ran2reset/resetran2
|
||||
|
||||
parameter(eps=1.0d-9)
|
||||
external sampfunc
|
||||
!
|
||||
resetran2=.true.
|
||||
!
|
||||
msect=msect0
|
||||
! call sampfunc(nparams,bestguess,yatguess)
|
||||
!assume calculation already done for initial guess
|
||||
guessconfid=dmax1(1.0d0,guessconfid0)
|
||||
j=0
|
||||
do i=1,nparams
|
||||
if(bestguess(i).lt.bmin(i).or.bestguess(i).gt.
|
||||
& bmax(i))then
|
||||
j=1
|
||||
if(bestguess(i).lt.bmin(i))then
|
||||
bestguess(i)=bmin(i)
|
||||
else
|
||||
bestguess(i)=bmax(i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if(j.eq.1)call sampfunc(nparams,bestguess,yatguess)
|
||||
do i=1,nparams
|
||||
if(dabs(bmax(i)-bestguess(i)).lt.eps)then
|
||||
nright=0
|
||||
nleft=msect+1
|
||||
else
|
||||
if(dabs(bestguess(i)-bmin(i)).lt.eps)then
|
||||
nright=msect+1
|
||||
nleft=0
|
||||
else
|
||||
if(mod(msect,2).eq.0)then
|
||||
nright=msect/2+1
|
||||
nleft=msect/2+1
|
||||
else
|
||||
nright=msect/2+1+1
|
||||
nleft=msect/2+1
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
!first divide the right
|
||||
if(nright.gt.0)then
|
||||
x1=2.0d0*(bmax(i)-bestguess(i))/
|
||||
& (dble(nright)*(guessconfid+1.0d0))
|
||||
delta=x1*(guessconfid-1.0d0)/dble(nright-1)
|
||||
accum=0.0d0
|
||||
do j=1,nright-1
|
||||
accum=accum+x1+dble(j-1)*delta
|
||||
params(i,j)=accum+bestguess(i)
|
||||
enddo
|
||||
endif
|
||||
!then divide the left
|
||||
if(nleft.gt.0)then
|
||||
x1=2.0d0*(bestguess(i)-bmin(i))/
|
||||
& (dble(nleft)*(guessconfid+1.0d0))
|
||||
delta=x1*(guessconfid-1.0d0)/dble(nleft-1)
|
||||
accum=0.0d0
|
||||
do j=1,nleft-1
|
||||
accum=accum+x1+dble(j-1)*delta
|
||||
if(nright.eq.0)then
|
||||
params(i,j)=bestguess(i)-accum
|
||||
else
|
||||
params(i,j+nright-1)=bestguess(i)-accum
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
do i=1,nparams
|
||||
params(i,msect+1)=bestguess(i)
|
||||
enddo
|
||||
msect=msect+1
|
||||
if(ihowsamp.eq.1)then
|
||||
!Using random permutation
|
||||
call randpermut_dim_samp(msect,nparams,
|
||||
& params(1:nparams,1:msect))
|
||||
do i=1,msect
|
||||
call sampfunc(nparams,params(1:nparams,i:i),fatbeta)
|
||||
if(fatbeta.lt.yatguess)then
|
||||
yatguess=fatbeta
|
||||
do j=1,nparams
|
||||
bestguess(j)=params(j,i)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
if(ihowsamp.eq.2)then
|
||||
!uniform grid sampling
|
||||
do i=1,msect**nparams
|
||||
do j=1,nparams
|
||||
!the size of the larger repeated unit is msect**(nparams-j+1)
|
||||
k=i/(msect**(nparams-j+1))
|
||||
n=mod(i,(msect**(nparams-j+1)))
|
||||
if(n.eq.0)k=k-1
|
||||
!k is the number of repeated units before i (not include the unit i is in)
|
||||
k=i-k*(msect**(nparams-j+1))
|
||||
!now k is the position in the larger repeated unit
|
||||
!
|
||||
!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect
|
||||
m=(msect**(nparams-j+1))/msect
|
||||
n=k/m
|
||||
if(mod(k,m).ne.0)n=n+1
|
||||
beta(j)=params(j,n)
|
||||
enddo
|
||||
call sampfunc(nparams,beta,fatbeta)
|
||||
if(fatbeta.lt.yatguess)then
|
||||
yatguess=fatbeta
|
||||
do j=1,nparams
|
||||
bestguess(j)=beta(j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end subroutine gridsampling
|
||||
@@ -0,0 +1,26 @@
|
||||
!creating uniform grids
|
||||
program test
|
||||
implicit none
|
||||
integer i,j,k,msect,nparams,ip(10),n,m
|
||||
msect=4
|
||||
nparams=3
|
||||
do i=1,msect**nparams
|
||||
do j=1,nparams
|
||||
!the size of the larger repeated unit is msect**(nparams-j+1)
|
||||
k=i/(msect**(nparams-j+1))
|
||||
n=mod(i,(msect**(nparams-j+1)))
|
||||
if(n.eq.0)k=k-1
|
||||
!k is the number of repeated units before i (not include the unit i is in)
|
||||
k=i-k*(msect**(nparams-j+1))
|
||||
!now k is the position in the larger repeated unit
|
||||
!
|
||||
!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect
|
||||
m=(msect**(nparams-j+1))/msect
|
||||
n=k/m
|
||||
if(mod(k,m).ne.0)n=n+1
|
||||
ip(j)=n
|
||||
enddo
|
||||
write(1,210)(ip(j),j=1,nparams)
|
||||
enddo
|
||||
210 format(1x,10i3)
|
||||
end
|
||||
@@ -0,0 +1,74 @@
|
||||
! optimally group a gappy order time series into different sections with an average
|
||||
! length
|
||||
subroutine grouping(numpoints,time,windowsize,minnum,
|
||||
×tart,timeend,nsections,nrange,confirmvar,rangemin)
|
||||
implicit none
|
||||
integer numpoints,nsections,minnum,n,i,ipass,j,nrange
|
||||
double precision time(numpoints),timestart(numpoints),
|
||||
& timeend(numpoints),gap,windowsize,diff,fmin(nrange),
|
||||
& fmax(nrange),confirmvar(nrange,numpoints),rangemin(nrange)
|
||||
|
||||
! the first mark is always time(1)-1.0d-9*time(1). time must be ordered from
|
||||
! low to high
|
||||
! rangemin is the minimum range of a variable in a section
|
||||
|
||||
nsections=1
|
||||
n=0
|
||||
timestart(nsections)=time(1)-1.0d-9*time(1)
|
||||
do j=1,nrange
|
||||
fmin(j)=confirmvar(j,1)
|
||||
fmax(j)=confirmvar(j,1)
|
||||
enddo
|
||||
do i=2,numpoints
|
||||
gap=time(i)-time(i-1)
|
||||
if(gap.ge.windowsize.and.nsections.gt.1)then
|
||||
! there is a large gap. Put all members in the current section into the previous
|
||||
! section and start the current section from time(i)
|
||||
timeend(nsections-1)=time(i-1)
|
||||
timestart(nsections)=time(i)
|
||||
n=0
|
||||
do j=1,nrange
|
||||
fmin(j)=confirmvar(j,i)
|
||||
fmax(j)=confirmvar(j,i)
|
||||
enddo
|
||||
else
|
||||
diff=time(i)-timestart(nsections)
|
||||
do j=1,nrange
|
||||
if(fmin(j).gt.confirmvar(j,i))then
|
||||
fmin(j)=confirmvar(j,i)
|
||||
endif
|
||||
if(fmax(j).lt.confirmvar(j,i))then
|
||||
fmax(j)=confirmvar(j,i)
|
||||
endif
|
||||
enddo
|
||||
ipass=1
|
||||
if(diff.lt.windowsize)then
|
||||
ipass=0
|
||||
endif
|
||||
do j=1,nrange
|
||||
if((fmax(j)-fmin(j)).lt.rangemin(j))then
|
||||
ipass=0
|
||||
endif
|
||||
enddo
|
||||
if(ipass.eq.0)then
|
||||
n=n+1
|
||||
else
|
||||
if(n.ge.minnum)then
|
||||
timeend(nsections)=time(i)
|
||||
nsections=nsections+1
|
||||
timestart(nsections)=time(i)
|
||||
n=0
|
||||
do j=1,nrange
|
||||
fmin(j)=confirmvar(j,i)
|
||||
fmax(j)=confirmvar(j,i)
|
||||
enddo
|
||||
else
|
||||
n=n+1
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
nsections=nsections-1
|
||||
timeend(nsections)=time(numpoints)
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,83 @@
|
||||
subroutine histogram(npoints,datalabel,datavalue,ngroup,
|
||||
&grouplabel,nhistmark,histmark,nfreq,ncumumark,cumumark,
|
||||
&ncumu)
|
||||
implicit none
|
||||
!npoints: the total number of points of the whole series
|
||||
!datalabel: the lable of each datum
|
||||
!datavalue: the value of each datum
|
||||
!ngroup: the number of different data labeles, each label represents a group
|
||||
!grouplabel: the label of each group
|
||||
!nhistmark: the number of histogram band marks in each group
|
||||
!histmark: the value of each histogram mark
|
||||
!nfreq: the number of points in each histogram bands
|
||||
!ncumumark: the number of marks for cumulative distribution
|
||||
!cumumark: the marks for the cumulative distribution
|
||||
!ncumu: the cumulative distribution in each group
|
||||
integer npoints,ngroup,nfreq(ngroup,npoints),nhistmark(ngroup),
|
||||
&ncumumark(ngroup),ncumu(ngroup,npoints),iorder(npoints),i,j,n
|
||||
character*50 datalabel(npoints),grouplabel(ngroup)
|
||||
double precision datavalue(npoints),histmark(ngroup,npoints),
|
||||
&cumumark(ngroup,npoints),vector(npoints)
|
||||
do i=1,ngroup
|
||||
do j=1,npoints
|
||||
nfreq(i,j)=0
|
||||
ncumu(i,j)=0
|
||||
enddo
|
||||
ncumumark(i)=0
|
||||
enddo
|
||||
do k=1,npoints
|
||||
do i=1,ngroup
|
||||
if(trim(datalabel(k)).eq.trim(grouplabel(i))then
|
||||
!initially we set the ncumumark to the total number of points in each group. Later we will
|
||||
!merge points with the same value
|
||||
ncumumark(i)=ncumumark(i)+1
|
||||
cumumark(i,ncumumark(i))=datavalue(k)
|
||||
goto 10
|
||||
endif
|
||||
enddo
|
||||
10 continue
|
||||
enddo
|
||||
do i=1,ngroup
|
||||
call sort_shell(ncumumark(i),cumumark(i:i,1:ncumumark(i)),
|
||||
&iorder)
|
||||
do k=1,ncumumark(i)
|
||||
do j=1,nhistmark(i)-1
|
||||
if(j.eq.(nhistmark(i)-1))then
|
||||
if(cumumark(i,k).ge.histmark(i,j).and.cumumark(i,k).le.
|
||||
&histmark(i,j+1))then
|
||||
nfreq(i,j)=nfreq(i,j)+1
|
||||
goto 20
|
||||
else
|
||||
if(cumumark(i,k).ge.histmark(i,j).and.cumumark(i,k).lt.
|
||||
&histmark(i,j+1))then
|
||||
nfreq(i,j)=nfreq(i,j)+1
|
||||
goto 20
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
20 continue
|
||||
enddo
|
||||
!cumulative distribution. we have to merge points with equal values
|
||||
do j=1,ncumumark(i)
|
||||
vector(j)=cumumark(i,j)
|
||||
enddo
|
||||
k=ncumumark(i)
|
||||
ncumumark(i)=1
|
||||
cumumark(i,1)=vector(1)
|
||||
do j=2,k
|
||||
if(vector(j).ne.cumumark(i,ncumumark(i)))then
|
||||
ncumumark(i)=ncumumark(i)+1
|
||||
cumumark(i,ncumumark(i))=vector(j)
|
||||
endif
|
||||
enddo
|
||||
do j=1,ncumumark(i)
|
||||
ncumu(i,j)=0
|
||||
do n=1,k
|
||||
if(ivector(n).le.cumumark(i,j))then
|
||||
ncumu(i,j)=ncumu(i,j)+1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,17 @@
|
||||
!determine if year is a leap year
|
||||
integer function isitaleapyear(year)
|
||||
!isitaleapyear =0, not a leap year (365 days)
|
||||
! =1, leap year (366 days)
|
||||
implicit none
|
||||
integer year
|
||||
isitaleapyear=0
|
||||
if((mod(year,4).eq.0).and.(mod(year,100).gt.0))
|
||||
&isitaleapyear=1
|
||||
if((mod(year,4).eq.0).and.(mod(year,100).eq.0))then
|
||||
if(mod(year,400).eq.0)isitaleapyear=1
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,19 @@
|
||||
integer function ispartnum(c)
|
||||
implicit none
|
||||
!ispartnum = 1, c is one of the following: 0 to 9, +, -, ., d, D, E, e, N, n, a, and A.
|
||||
! = 0, otherwise
|
||||
character c*1
|
||||
integer i
|
||||
!
|
||||
ispartnum=0
|
||||
i=ichar(c)
|
||||
if(i.ge.48.and.i.le.57)ispartnum=1
|
||||
if(i.eq.43.or.i.eq.45.or.i.eq.46.or.i.eq.68.or.
|
||||
&i.eq.69.or.i.eq.100.or.i.eq.101)ispartnum=1
|
||||
if(c.eq.'.'.or.c.eq.'+'.or.c.eq.'-')ispartnum=1
|
||||
if(c.eq.'d'.or.c.eq.'D'.or.c.eq.'e'.or.c.eq.'E')
|
||||
&ispartnum=1
|
||||
if(c.eq.'n'.or.c.eq.'N'.or.c.eq.'a'.or.c.eq.'A')
|
||||
&ispartnum=1
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,288 @@
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine jbtest(nsamp,x,alpha,h,p,jbstat,cv,hb)
|
||||
implicit none
|
||||
|
||||
double precision fn9999
|
||||
parameter(fn9999=-9999.0d0)
|
||||
integer nsiglev
|
||||
parameter(nsiglev=17)
|
||||
|
||||
integer nsamp,h,hb
|
||||
!h=1, reject the hypothesis of normal distribution
|
||||
!h=0, fail to reject the nul hypothesis
|
||||
|
||||
integer i,k
|
||||
integer iorder(nsiglev)
|
||||
|
||||
double precision x(nsamp),alpha,p,jbstat,cv,
|
||||
&zscores(nsamp),skew,kurt,fstd,fmean,fmin,fmax
|
||||
|
||||
double precision cvs(nsiglev),alphas(nsiglev),tmpy2(nsiglev),
|
||||
&alphasort(nsiglev)
|
||||
|
||||
data alphas/0.001, 0.0016681,0.0027826,0.0046416,0.0077426,
|
||||
& 0.01, 0.012915, 0.021544, 0.025, 0.035938,
|
||||
& 0.05, 0.059948, 0.1, 0.15, 0.2,
|
||||
& 0.25, 0.50/
|
||||
|
||||
if (nsamp .lt. 2) then
|
||||
write(*,*) 'stats:jbtest:NotEnoughData,
|
||||
&Sample vector X must have at
|
||||
&least 2 valid observations.'
|
||||
h = fn9999
|
||||
p = fn9999
|
||||
jbstat = fn9999
|
||||
cv = fn9999
|
||||
hb=fn9999
|
||||
|
||||
elseif (nsamp .eq. 2) then
|
||||
write(*,*) 'The J-B stat is a constant
|
||||
&when the sample size is 2'
|
||||
h = 0
|
||||
p = 1.0
|
||||
jbstat = 1.0/3.0
|
||||
cv = fn9999
|
||||
hb = 1
|
||||
else
|
||||
|
||||
skew = 0.0
|
||||
kurt = 0.0
|
||||
|
||||
call stdmaxmeanmin(nsamp,x,fstd,fmean,fmin,fmax)
|
||||
|
||||
! readjust sample size from (n-1) to n according to matlab
|
||||
|
||||
fstd = dsqrt(fstd*fstd*dble(nsamp-1)/dble(nsamp))
|
||||
do i=1,nsamp
|
||||
zscores(i) = (x(i)-fmean)/fstd
|
||||
enddo
|
||||
|
||||
do i=1,nsamp
|
||||
skew = skew + zscores(i)*zscores(i)*zscores(i)
|
||||
kurt = kurt + zscores(i)*zscores(i)*zscores(i)*zscores(i)
|
||||
enddo
|
||||
|
||||
skew = skew/dble(nsamp)
|
||||
kurt = kurt/dble(nsamp) - 3
|
||||
jbstat = nsamp*(skew*skew/6 + kurt*kurt/24)
|
||||
|
||||
|
||||
! Get a row of the critical value table for the current sample size
|
||||
call cvtbl(nsamp,cvs)
|
||||
|
||||
! 1-D interpolation into the tabulated quantiles.
|
||||
call SPLINE(alphas,cvs,nsiglev,1.0d+31,1.0d+31,tmpy2)
|
||||
call SPLINT(alphas,cvs,tmpy2,nsiglev,alpha,cv)
|
||||
|
||||
! Compute the P-value. Warn if the P-value is not found within the
|
||||
! available 'alphas' of the table and return one of the extremes.
|
||||
|
||||
if (jbstat < cvs(nsiglev)) then ! smallest critval at end
|
||||
write(*,*) 'P is greater than the largest tabulated value'
|
||||
p = alphas(nsiglev)
|
||||
hb=1
|
||||
elseif (cvs(1) < jbstat) then ! largest critval at beginning
|
||||
write(*,*) 'P is less than the smallest tabulated value'
|
||||
p = alphas(1)
|
||||
hb=1
|
||||
else
|
||||
|
||||
call sort_shell(nsiglev,cvs,iorder)
|
||||
do k=1,nsiglev
|
||||
alphasort(k) = alphas(iorder(k))
|
||||
enddo
|
||||
call SPLINE(cvs,alphasort,nsiglev,1.0d+31,1.0d+31,tmpy2)
|
||||
call SPLINT(cvs,alphasort,tmpy2,nsiglev,jbstat,p)
|
||||
|
||||
hb=0
|
||||
if(jbstat .gt. cv) then
|
||||
h=1
|
||||
else
|
||||
h=0
|
||||
endif
|
||||
|
||||
endif
|
||||
endif
|
||||
|
||||
return
|
||||
end
|
||||
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine cvtbl(n,cvs)
|
||||
implicit none
|
||||
|
||||
integer n,nsiglev,nsamples,i,j,k
|
||||
parameter(nsiglev=17,nsamples=32)
|
||||
integer sampleSizes(nsamples) !Sample sizes
|
||||
double precision criticalValues(nsamples,nsiglev) !Critical value
|
||||
double precision cvs(nsiglev)
|
||||
|
||||
double precision x(nsamples),y(nsamples),y2(nsamples),
|
||||
& ysort(nsamples),tmp(nsamples)
|
||||
integer iorder(nsamples)
|
||||
|
||||
data sampleSizes/3, 4, 5, 10, 15, 20, 25, 30, 35,
|
||||
& 40, 45, 50, 60, 70, 80, 90, 100, 125,
|
||||
& 150, 175, 200, 250, 300, 400, 500, 800, 1000,
|
||||
& 1200,1400,1600,1800,2000/
|
||||
|
||||
data criticalValues/ 0.5312, 0.9606, 1.8289,10.9719,
|
||||
& 19.5425,25.0722,28.4885,30.6106,
|
||||
& 31.9343,32.7514,33.2273,33.4825,
|
||||
& 33.5009,33.2610,32.8742,32.3418,
|
||||
& 31.8884,30.6089,29.4290,28.4225,
|
||||
& 27.5140,26.0239,24.8353,23.0771,
|
||||
& 21.8170,19.5539,18.6707,18.0126,
|
||||
& 17.5190,17.1305,16.8158,16.5585,
|
||||
& 0.5312, 0.9590, 1.8053, 9.8430,
|
||||
& 16.7207,21.0001,23.6332,25.2501,
|
||||
& 26.2695,26.9025,27.2686,27.4765,
|
||||
& 27.5458,27.3738,27.0975,26.7278,
|
||||
& 26.3990,25.4748,24.6043,23.8582,
|
||||
& 23.1914,22.0764,21.1758,19.8542,
|
||||
& 18.9068,17.1748,16.4879,15.9830,
|
||||
& 15.6036,15.3029,15.0600,14.8633,
|
||||
& 0.5312, 0.9564, 1.7727, 8.6751,
|
||||
& 14.0454,17.2981,19.2818,20.5242,
|
||||
& 21.3105,21.8016,22.1030,22.2863,
|
||||
& 22.3790,22.2848,22.1135,21.8770,
|
||||
& 21.6407,21.0100,20.3979,19.8658,
|
||||
& 19.3922,18.5877,17.9384,16.9669,
|
||||
& 16.2666,14.9865,14.4745,14.0990,
|
||||
& 13.8149,13.5883,13.4102,13.2657,
|
||||
& 0.5312, 0.9520, 1.7276, 7.4815,
|
||||
& 11.5527,13.9762,15.4635,16.4088,
|
||||
& 17.0176,17.4145,17.6594,17.8172,
|
||||
& 17.9431,17.9209,17.8305,17.6977,
|
||||
& 17.5510,17.1460,16.7425,16.3846,
|
||||
& 16.0635,15.5123,15.0633,14.3843,
|
||||
& 13.8903,12.9765,12.6143,12.3493,
|
||||
& 12.1501,11.9883,11.8682,11.7666,
|
||||
& 0.5312, 0.9448, 1.6661, 6.2927,
|
||||
& 9.2814,11.0602,12.1658,12.8805,
|
||||
& 13.3572,13.6749,13.8848,14.0345,
|
||||
& 14.1788,14.2092,14.1911,14.1283,
|
||||
& 14.0491,13.8271,13.5878,13.3664,
|
||||
& 13.1643,12.8124,12.5206,12.0743,
|
||||
& 11.7469,11.1441,10.9072,10.7362,
|
||||
& 10.6072,10.5059,10.4296,10.3636,
|
||||
& 0.5312, 0.9396, 1.6275, 5.7077,
|
||||
& 8.2365, 9.7531,10.7058,11.3263,
|
||||
& 11.7488,12.0355,12.2302,12.3739,
|
||||
& 12.5255,12.5801,12.5841,12.5542,
|
||||
& 12.5067,12.3565,12.1804,12.0139,
|
||||
& 11.8602,11.5923,11.3653,11.0157,
|
||||
& 10.7604,10.2914,10.1106, 9.9803,
|
||||
& 9.8811, 9.8072, 9.7478, 9.6981,
|
||||
& 0.5311, 0.9329, 1.5828, 5.1350,
|
||||
& 7.2613, 8.5489, 9.3658, 9.9063,
|
||||
& 10.2818,10.5399,10.7201,10.8586,
|
||||
& 11.0182,11.0884,11.1155,11.1112,
|
||||
& 11.0882,10.9976,10.8779,10.7589,
|
||||
& 10.6494,10.4542,10.2839,10.0226,
|
||||
& 9.8318, 9.4852, 9.3521, 9.2587,
|
||||
& 9.1869, 9.1333, 9.0911, 9.0549,
|
||||
& 0.5310, 0.9133, 1.4723, 4.0456,
|
||||
& 5.5238, 6.4401, 7.0389, 7.4472,
|
||||
& 7.7395, 7.9520, 8.1098, 8.2340,
|
||||
& 8.3968, 8.4921, 8.5520, 8.5850,
|
||||
& 8.6004, 8.6020, 8.5719, 8.5307,
|
||||
& 8.4904, 8.4114, 8.3384, 8.2266,
|
||||
& 8.1454, 8.0027, 7.9501, 7.9127,
|
||||
& 7.8828, 7.8611, 7.8446, 7.8296,
|
||||
& 0.5309,0.9056,1.4343,3.7474,
|
||||
& 5.0729,5.8998,6.4463,6.8222,
|
||||
& 7.0942,7.2949,7.4469,7.5661,
|
||||
& 7.7287,7.8286,7.8938,7.9361,
|
||||
& 7.9589,7.9816,7.9718,7.9496,
|
||||
& 7.9259,7.8751,7.8276,7.7526,
|
||||
& 7.6984,7.6040,7.5691,7.5441,
|
||||
& 7.5239,7.5089,7.4979,7.4872,
|
||||
& 0.5305,0.8817,1.3294,3.0691,
|
||||
& 4.0773,4.7176,5.1501,5.4578,
|
||||
& 5.6856,5.8598,5.9945,6.1045,
|
||||
& 6.2620,6.3696,6.4462,6.5028,
|
||||
& 6.5429,6.6071,6.6387,6.6571,
|
||||
& 6.6688,6.6803,6.6842,6.6877,
|
||||
& 6.6882,6.6858,6.6847,6.6832,
|
||||
& 6.6800,6.6789,6.6777,6.6763,
|
||||
& 0.5297,0.8519,1.2185,2.5239,
|
||||
& 3.2985,3.8011,4.1494,4.4039,
|
||||
& 4.5973,4.7481,4.8689,4.9697,
|
||||
& 5.1203,5.2305,5.3134,5.3796,
|
||||
& 5.4314,5.5277,5.5919,5.6408,
|
||||
& 5.6783,5.7343,5.7728,5.8248,
|
||||
& 5.8581,5.9096,5.9282,5.9408,
|
||||
& 5.9482,5.9546,5.9600,5.9635,
|
||||
& 0.5290,0.8316,1.1516,2.2555,
|
||||
& 2.9215,3.3596,3.6684,3.8968,
|
||||
& 4.0734,4.2126,4.3258,4.4214,
|
||||
& 4.5688,4.6803,4.7662,4.8378,
|
||||
& 4.8957,5.0071,5.0863,5.1474,
|
||||
& 5.1957,5.2681,5.3194,5.3889,
|
||||
& 5.4336,5.5043,5.5296,5.5471,
|
||||
& 5.5587,5.5677,5.5755,5.5806,
|
||||
& 0.5251,0.7553,0.9442,1.6231,
|
||||
& 2.0533,2.3505,2.5707,2.7431,
|
||||
& 2.8827,2.9987,3.0973,3.1834,
|
||||
& 3.3246,3.4374,3.5292,3.6071,
|
||||
& 3.6730,3.8025,3.8987,3.9732,
|
||||
& 4.0327,4.1224,4.1873,4.2748,
|
||||
& 4.3320,4.4246,4.4580,4.4814,
|
||||
& 4.4979,4.5105,4.5214,4.5289,
|
||||
& 0.5176,0.6721,0.7945,1.2821,
|
||||
& 1.5965,1.8239,1.9986,2.1390,
|
||||
& 2.2547,2.3524,2.4361,2.5097,
|
||||
& 2.6316,2.7298,2.8104,2.8788,
|
||||
& 2.9372,3.0523,3.1384,3.2050,
|
||||
& 3.2584,3.3402,3.3988,3.4790,
|
||||
& 3.5318,3.6180,3.6500,3.6718,
|
||||
& 3.6876,3.6997,3.7101,3.7173,
|
||||
& 0.5074,0.6303,0.7302,1.1235,
|
||||
& 1.3779,1.5631,1.7063,1.8216,
|
||||
& 1.9172,1.9980,2.0674,2.1283,
|
||||
& 2.2297,2.3115,2.3789,2.4361,
|
||||
& 2.4851,2.5819,2.6543,2.7106,
|
||||
& 2.7559,2.8250,2.8749,2.9434,
|
||||
& 2.9886,3.0631,3.0907,3.1099,
|
||||
& 3.1237,3.1345,3.1433,3.1499,
|
||||
& 0.4946,0.5947,0.6878,1.0198,
|
||||
& 1.2336,1.3885,1.5079,1.6040,
|
||||
& 1.6835,1.7508,1.8085,1.8592,
|
||||
& 1.9434,2.0114,2.0674,2.1151,
|
||||
& 2.1557,2.2363,2.2964,2.3436,
|
||||
& 2.3812,2.4388,2.4808,2.5382,
|
||||
& 2.5760,2.6388,2.6624,2.6787,
|
||||
& 2.6904,2.6996,2.7072,2.7129,
|
||||
& 0.4063,0.4739,0.5285,0.6951,
|
||||
& 0.7916,0.8577,0.9071,0.9457,
|
||||
& 0.9771,1.0033,1.0256,1.0449,
|
||||
& 1.0768,1.1023,1.1231,1.1408,
|
||||
& 1.1557,1.1852,1.2072,1.2243,
|
||||
& 1.2382,1.2591,1.2744,1.2956,
|
||||
& 1.3097,1.3334,1.3421,1.3484,
|
||||
& 1.3530,1.3564,1.3595,1.3619/
|
||||
|
||||
|
||||
! Interpolate a row of critical values for the given sample size.
|
||||
do i=1,nsiglev
|
||||
do j=1,nsamples
|
||||
x(j) = 1.0/dble(sampleSizes(j))
|
||||
y(j) = criticalValues(j,i)
|
||||
enddo
|
||||
|
||||
call sort_shell(nsamples,x,iorder)
|
||||
do k=1,nsamples
|
||||
ysort(k) = y(iorder(k))
|
||||
enddo
|
||||
|
||||
call SPLINE(x,ysort,nsamples,1.0d+31,1.0d+31,y2)
|
||||
call SPLINT(x,ysort,y2,nsamples,1.0/dble(n),cvs(i))
|
||||
|
||||
enddo
|
||||
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,71 @@
|
||||
subroutine linecrossing(nlines,nsamp,maxnsamp,xdata,ydata,
|
||||
¶ms,xcross,ycross)
|
||||
implicit none
|
||||
!fit nlines lines from nlines pairs of datasets and estimate the mean crossings of the lines
|
||||
integer nlines,nsamp(nlines),maxnsamp,i,j,k,n,m
|
||||
double precision xdata(nlines,maxnsamp),ydata(nlines,maxnsamp),
|
||||
&xcross,ycross,x(maxnsamp),y(maxnsamp),intercepts(nlines),
|
||||
&slopes(nlines),params(nlines,2)
|
||||
|
||||
k=0
|
||||
do i=1,nlines
|
||||
n=0
|
||||
do j=1,nsamp(i)
|
||||
if(dabs(xdata(i,j)+9999.0d0).gt.1.0d-8.and.
|
||||
&dabs(ydata(i,j)+9999.0d0).gt.1.0d-8)then
|
||||
n=n+1
|
||||
x(n)=xdata(i,j)
|
||||
y(n)=ydata(i,j)
|
||||
endif
|
||||
enddo
|
||||
if(n.gt.1)then
|
||||
k=k+1
|
||||
call y_aPLUSbx(n,x,y,intercepts(k),slopes(k))
|
||||
params(i,1)=slopes(k)
|
||||
params(i,2)=intercepts(k)
|
||||
endif
|
||||
enddo
|
||||
if(k.gt.0)then
|
||||
call meancrossing(k,slopes,intercepts,xcross,ycross)
|
||||
else
|
||||
xcross=-9999.0d0
|
||||
ycross=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
subroutine meancrossing(nlines,slopes,intercepts,xcross,ycross)
|
||||
implicit none
|
||||
!calculate the average crossing point of the nlines lines. Parrell lines are excluded
|
||||
integer nlines,i,j,k
|
||||
double precision slopes(nlines),intercepts(nlines),xcross,ycross,
|
||||
&x(nlines),y(nlines),a1,b1,a2,b2
|
||||
k=0
|
||||
do i=1,nlines-1
|
||||
do j=i+1,nlines
|
||||
a1=slopes(i)
|
||||
b1=intercepts(i)
|
||||
a2=slopes(j)
|
||||
b2=intercepts(j)
|
||||
if(dabs(a1-a2).gt.1.0d-8)then
|
||||
k=k+1
|
||||
x(k)=(b2-b1)/(a1-a2)
|
||||
y(k)=a1*x(k)+b1
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
if(k.gt.0)then
|
||||
xcross=0.0d0
|
||||
ycross=0.0d0
|
||||
do i=1,k
|
||||
xcross=xcross+x(i)
|
||||
ycross=ycross+y(i)
|
||||
enddo
|
||||
xcross=xcross/dble(k)
|
||||
ycross=ycross/dble(k)
|
||||
else
|
||||
xcross=-9999.0d0
|
||||
ycross=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,54 @@
|
||||
subroutine linregres(npoints0,x0,y0,Sign_Level,a,b,
|
||||
&r,bradius,isslopezero)
|
||||
implicit none
|
||||
!fit for y=a+bx
|
||||
integer npoints0,isslopezero
|
||||
!isslopezero=-1, slope differs from zero
|
||||
!isslopezero=1, slope does not differ from zero
|
||||
double precision x0(npoints0),y0(npoints0),r,a,b,
|
||||
&bradius,Sign_Level
|
||||
integer i,npoints
|
||||
double precision xmean,ymean,lxx,lyy,lxy,seb,t0,
|
||||
&tstat,tstatr,student_t,fn9999,tiny,x(npoints0),y(npoints0)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
|
||||
npoints=0
|
||||
do i=1,npoints0
|
||||
if(dabs(x0(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y0(i)-fn9999).gt.tiny)then
|
||||
npoints=npoints+1
|
||||
x(npoints)=x0(i)
|
||||
y(npoints)=y0(i)
|
||||
endif
|
||||
enddo
|
||||
|
||||
xmean=0.0d0
|
||||
ymean=0.0d0
|
||||
do i=1,npoints
|
||||
xmean=xmean+x(i)
|
||||
ymean=ymean+y(i)
|
||||
enddo
|
||||
xmean=xmean/dble(npoints)
|
||||
ymean=ymean/dble(npoints)
|
||||
lxx=0.0d0
|
||||
lyy=0.0d0
|
||||
lxy=0.0d0
|
||||
do i=1,npoints
|
||||
lxx=lxx+(x(i)-xmean)**2
|
||||
lyy=lyy+(y(i)-ymean)**2
|
||||
lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
|
||||
enddo
|
||||
b=lxy/lxx
|
||||
a=ymean-b*xmean
|
||||
r=lxy/dsqrt(lxx*lyy)
|
||||
seb=dsqrt((lyy-b*lxy)/(lxx*dble(npoints-2)))
|
||||
t0=student_t(npoints-2,Sign_Level)
|
||||
bradius=seb*t0
|
||||
tstat=dabs(b/seb)
|
||||
if(tstat.gt.t0)then
|
||||
isslopezero=-1
|
||||
else
|
||||
isslopezero=1
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,47 @@
|
||||
subroutine linuncertainty(nsamp,a1_mean,a1_sigma,b1_mean,
|
||||
&b1_sigma,y1_mean,y1_sigma,a2_mean,a2_sigma,b2_mean,b2_sigma,
|
||||
&y2_mean,y2_sigma,x1,x2,x1_mean,x1_sigma,x2_mean,x2_sigma)
|
||||
implicit none
|
||||
!given:
|
||||
!y1=a1*x1+b1*x2
|
||||
!y2=a2*x1+b1*x2
|
||||
!y1 ~ (y1_mean, y1_sigma)
|
||||
!y2 ~ (y2_mean, y2_sigma)
|
||||
!a1 ~ (a1_mean, a1_sigma)
|
||||
!b1 ~ (b1_mean, b1_sigma)
|
||||
!a2 ~ (a2_mean, a2_sigma)
|
||||
!b2 ~ (b2_mean, b2_sigma)
|
||||
!find:
|
||||
!x1 ~ (x1_mean, x1_sigma)
|
||||
!x2 ~ (x2_mean, x2_sigma)
|
||||
integer nsamp,i
|
||||
double precision a1_mean,a1_sigma,b1_mean,b1_sigma,y1_mean,
|
||||
&y1_sigma,a2_mean,a2_sigma,b2_mean,b2_sigma,y2_mean,y2_sigma,
|
||||
&x1(nsamp),x2(nsamp),x1_mean,x1_sigma,x2_mean,x2_sigma,gasdev2,
|
||||
&a1,b1,a2,b2,y1,y2
|
||||
x1_mean=0.0d0
|
||||
x2_mean=0.0d0
|
||||
do i=1,nsamp
|
||||
y1=gasdev2()*y1_sigma+y1_mean
|
||||
y2=gasdev2()*y2_sigma+y2_mean
|
||||
a1=gasdev2()*a1_sigma+a1_mean
|
||||
b1=gasdev2()*b1_sigma+b1_mean
|
||||
a2=gasdev2()*a2_sigma+a2_mean
|
||||
b2=gasdev2()*b2_sigma+b2_mean
|
||||
x1(i)=(b2*y1-b1*y2)/(a1*b2-a2*b1)
|
||||
x2(i)=(a1*y2-a2*y1)/(a1*b2-a2*b1)
|
||||
x1_mean=x1_mean+x1(i)
|
||||
x2_mean=x2_mean+x2(i)
|
||||
enddo
|
||||
x1_mean=x1_mean/dble(nsamp)
|
||||
x2_mean=x2_mean/dble(nsamp)
|
||||
x1_sigma=0.0d0
|
||||
x2_sigma=0.0d0
|
||||
do i=1,nsamp
|
||||
x1_sigma=x1_sigma+(x1(i)-x1_mean)*(x1(i)-x1_mean)
|
||||
x2_sigma=x2_sigma+(x2(i)-x2_mean)*(x2(i)-x2_mean)
|
||||
enddo
|
||||
x1_sigma=x1_sigma/dble(nsamp)
|
||||
x2_sigma=x2_sigma/dble(nsamp)
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,59 @@
|
||||
subroutine meancyclegapfilling(nsamp,xvar,yvar0,nminno0)
|
||||
implicit none
|
||||
!Fill gaps in yvar with the mean cycle approach. xvar must be repeated cycles.
|
||||
integer nsamp,nminno0,nk,nminno
|
||||
double precision xvar(nsamp),yvar0(nsamp)
|
||||
integer i,j,k,m,n
|
||||
double precision yvector(nsamp),fn9999,tiny,yvar(nsamp)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
!
|
||||
do i=1,nsamp
|
||||
yvar(i)=yvar0(i)
|
||||
enddo
|
||||
do i=1,nsamp
|
||||
nminno=nminno0
|
||||
if(dabs(yvar(i)-fn9999).gt.tiny)goto 70
|
||||
7 n=0
|
||||
k=i-1
|
||||
nk=0
|
||||
10 if(k.eq.0)goto 30
|
||||
if(dabs(xvar(k)-xvar(i)).gt.tiny)goto 20
|
||||
nk=nk+1
|
||||
if(dabs(yvar0(k)-fn9999).lt.tiny)goto 20
|
||||
n=n+1
|
||||
yvector(n)=yvar0(k)
|
||||
if(nk.ge.nminno/2)goto 30
|
||||
20 k=k-1
|
||||
goto 10
|
||||
30 m=i+1
|
||||
nk=0
|
||||
40 if(m.gt.nsamp)goto 60
|
||||
if(dabs(xvar(m)-xvar(i)).gt.tiny)goto 50
|
||||
nk=nk+1
|
||||
if(dabs(yvar0(m)-fn9999).lt.tiny)goto 50
|
||||
n=n+1
|
||||
yvector(n)=yvar0(m)
|
||||
if(nk.ge.nminno/2)goto 60
|
||||
50 m=m+1
|
||||
goto 40
|
||||
60 if(n.lt.nminno0)then
|
||||
nminno=nminno+1
|
||||
goto 7
|
||||
endif
|
||||
yvar(i)=0.0d0
|
||||
do m=1,n
|
||||
yvar(i)=yvar(i)+yvector(m)
|
||||
enddo
|
||||
if(n.eq.0)then
|
||||
yvar(i)=-9.999d+199
|
||||
else
|
||||
yvar(i)=yvar(i)/dble(n)
|
||||
endif
|
||||
70 continue
|
||||
enddo
|
||||
do i=1,nsamp
|
||||
yvar0(i)=yvar(i)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
!####################################################################
|
||||
@@ -0,0 +1,43 @@
|
||||
subroutine meancyclepattern(nsamp,xvar,yvar,ncyc,xcyc,ycyc,ystd)
|
||||
implicit none
|
||||
!Calculate mean cycle pattern. xvar must be repeated cycles.
|
||||
integer nsamp,ncyc
|
||||
double precision xvar(nsamp),yvar(nsamp),xcyc(nsamp),
|
||||
&ycyc(nsamp),ystd(nsamp)
|
||||
integer i,j,k,m,n,iorder(nsamp)
|
||||
double precision yvector(nsamp),fn9999,tiny
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
!
|
||||
ncyc=1
|
||||
xcyc(ncyc)=xvar(1)
|
||||
do i=2,nsamp
|
||||
k=0
|
||||
do j=1,ncyc
|
||||
if(dabs(xcyc(j)-xvar(i)).lt.tiny)k=1
|
||||
enddo
|
||||
if(k.eq.0)then
|
||||
ncyc=ncyc+1
|
||||
xcyc(ncyc)=xvar(i)
|
||||
endif
|
||||
enddo
|
||||
call sort_shell(ncyc,xcyc,iorder)
|
||||
do j=1,ncyc
|
||||
k=0
|
||||
do i=1,nsamp
|
||||
if(dabs(xvar(i)-xcyc(j)).lt.tiny)then
|
||||
if(dabs(yvar(i)-fn9999).gt.tiny)then
|
||||
k=k+1
|
||||
yvector(k)=yvar(i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if(k.gt.2)then
|
||||
call stdmean(k,yvector,ystd(j),ycyc(j))
|
||||
else
|
||||
ycyc(j)=fn9999
|
||||
ystd(j)=fn9999
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
!####################################################################
|
||||
@@ -0,0 +1,344 @@
|
||||
subroutine meancycleoutliers(nsamp,xvar,yvar,nminno0)
|
||||
implicit none
|
||||
!Detect outliers in yvar with the mean cycle approach. Replace the detected
|
||||
!outliers with -9999. xvar must be repeated cycles
|
||||
integer nsamp,nminno0
|
||||
double precision xvar(nsamp),yvar(nsamp)
|
||||
integer i,j,k,m,n,noutliers,nk,nminno,ncyc
|
||||
double precision yvector(nsamp),std_clean,
|
||||
&fmean_clean(nsamp),fn9999,tiny,term
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-8)
|
||||
!
|
||||
!First remove the outliers for a given xvar value within a nminno window
|
||||
5 noutliers=0
|
||||
do i=1,nsamp
|
||||
nminno=nminno0
|
||||
if(dabs(yvar(i)-fn9999).gt.tiny)then
|
||||
7 n=0
|
||||
k=i
|
||||
nk=-1
|
||||
!The current value is the first value in yvector
|
||||
10 if(nk.ge.nminno/2)goto 30
|
||||
if(dabs(xvar(k)-xvar(i)).gt.tiny)goto 20
|
||||
nk=nk+1
|
||||
if(dabs(yvar(k)-fn9999).lt.tiny)goto 20
|
||||
n=n+1
|
||||
yvector(n)=yvar(k)
|
||||
20 k=k-1
|
||||
if(k.gt.0)goto 10
|
||||
30 nk=0
|
||||
m=i+1
|
||||
40 if(m.gt.nsamp)goto 60
|
||||
if(nk.ge.nminno/2)goto 60
|
||||
if(dabs(xvar(m)-xvar(i)).gt.tiny)goto 50
|
||||
nk=nk+1
|
||||
if(dabs(yvar(m)-fn9999).lt.tiny)goto 50
|
||||
n=n+1
|
||||
yvector(n)=yvar(m)
|
||||
50 m=m+1
|
||||
goto 40
|
||||
60 if(n.lt.nminno0)then
|
||||
nminno=nminno+1
|
||||
goto 7
|
||||
endif
|
||||
call whoareoutliers(n,yvector,std_clean,fmean_clean(i))
|
||||
if(dabs(yvector(1)-fn9999).lt.tiny)then
|
||||
noutliers=noutliers+1
|
||||
yvar(i)=fn9999
|
||||
else
|
||||
fmean_clean(i)=yvar(i)-fmean_clean(i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if(noutliers.gt.0)goto 5
|
||||
goto 190
|
||||
!
|
||||
!Then remove the outliers from the mean cycle out of nminno cycles
|
||||
105 noutliers=0
|
||||
do i=1,nsamp
|
||||
nminno=nminno0
|
||||
if(dabs(yvar(i)-fn9999).gt.tiny)then
|
||||
107 n=0
|
||||
nk=-1
|
||||
k=i
|
||||
!The current value is the first value in yvector
|
||||
110 if(dabs(xvar(k)-xvar(i)).lt.tiny)nk=nk+1
|
||||
if(nk.ge.nminno/2)goto 130
|
||||
if(dabs(yvar(k)-fn9999).lt.tiny)goto 120
|
||||
n=n+1
|
||||
yvector(n)=fmean_clean(k)
|
||||
120 k=k-1
|
||||
if(k.gt.0)goto 110
|
||||
130 m=i+1
|
||||
ncyc=nk
|
||||
nk=0
|
||||
140 if(m.gt.nsamp)goto 160
|
||||
if(dabs(xvar(m)-xvar(i)).lt.tiny)nk=nk+1
|
||||
if(nk.ge.nminno/2)goto 160
|
||||
if(dabs(yvar(m)-fn9999).lt.tiny)goto 150
|
||||
n=n+1
|
||||
yvector(n)=fmean_clean(m)
|
||||
150 m=m+1
|
||||
goto 140
|
||||
160 if((nk+ncyc).lt.nminno)then
|
||||
nminno=nminno+1
|
||||
goto 107
|
||||
endif
|
||||
call whoareoutliers(n,yvector,std_clean,term)
|
||||
if(dabs(yvector(1)-fn9999).lt.tiny)then
|
||||
noutliers=noutliers+1
|
||||
yvar(i)=fn9999
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
190 if(noutliers.gt.0)goto 5
|
||||
do i=2,nsamp-1
|
||||
if((yvar(i)-fn9999).gt.tiny)then
|
||||
if((yvar(i-1)-fn9999).lt.tiny.and.
|
||||
&(yvar(i+1)-fn9999).lt.tiny)yvar(i)=fn9999
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
!####################################################################
|
||||
subroutine whoareoutliers(nsamp0,xvar0,std_clean,fmean_clean)
|
||||
implicit none
|
||||
!Detect outliers. On exit, outliers are given as -9999
|
||||
integer nsamp,i,j,nsamp0,isoutlier_2sides,ivect(nsamp0)
|
||||
double precision xvar(nsamp0),std_clean,fmean_clean,
|
||||
& xvar0(nsamp0),gap
|
||||
parameter(gap=-9999.0d0)
|
||||
|
||||
10 nsamp=0
|
||||
do j=1,nsamp0
|
||||
if(dabs(xvar0(j)-gap).gt.1.0d-5)then
|
||||
nsamp=nsamp+1
|
||||
xvar(nsamp)=xvar0(j)
|
||||
ivect(nsamp)=j
|
||||
endif
|
||||
enddo
|
||||
if(nsamp.lt.2)then
|
||||
std_clean=gap
|
||||
fmean_clean=gap
|
||||
return
|
||||
endif
|
||||
i=isoutlier_2sides(nsamp,xvar)
|
||||
if(i.lt.0)goto 100
|
||||
xvar0(ivect(i))=gap
|
||||
goto 10
|
||||
|
||||
100 fmean_clean=0.0d0
|
||||
do j=1,nsamp
|
||||
fmean_clean=fmean_clean+xvar(j)
|
||||
enddo
|
||||
fmean_clean=fmean_clean/dble(nsamp)
|
||||
std_clean=0.0d0
|
||||
do j=1,nsamp
|
||||
std_clean=std_clean+(xvar(j)-fmean_clean)*(xvar(j)-fmean_clean)
|
||||
enddo
|
||||
std_clean=dsqrt(std_clean/dble(nsamp-1))
|
||||
return
|
||||
end
|
||||
|
||||
!####################################################################
|
||||
! detecting outliers using Grubb's
|
||||
integer function isoutlier_2sides(nsamp,yobs)
|
||||
implicit none
|
||||
! Detecting the outlier using the Grubb's test for two tails. If there is an outlier,
|
||||
! isoutlier is the index number of the outlier in the sequence yobs. If there
|
||||
! is no outlier, isoutlier is returned with -9999
|
||||
integer nsamp
|
||||
double precision yobs(nsamp)
|
||||
|
||||
integer i,imax
|
||||
double precision zc,std,fmean,dev,devmax,
|
||||
& alpha,grubbzc_2sides
|
||||
parameter(alpha=0.05d0)
|
||||
|
||||
isoutlier_2sides=-9999
|
||||
if(nsamp.le.2)then
|
||||
return
|
||||
endif
|
||||
call stdmean(nsamp,yobs,std,fmean)
|
||||
if(std.le.0.0d0)return
|
||||
devmax=dabs(yobs(1)-fmean)/std
|
||||
imax=1
|
||||
do i=2,nsamp
|
||||
dev=dabs(yobs(i)-fmean)/std
|
||||
if(dev.gt.devmax)then
|
||||
imax=i
|
||||
devmax=dev
|
||||
endif
|
||||
enddo
|
||||
zc=grubbzc_2sides(nsamp,alpha)
|
||||
if(devmax.ge.zc)then
|
||||
isoutlier_2sides=imax
|
||||
endif
|
||||
return
|
||||
end
|
||||
!*************************************************************
|
||||
integer function isoutlier_1side(nsamp,yobs,iwhichside)
|
||||
implicit none
|
||||
! Detecting the outlier using the Grubb's test for one tail. If there is an outlier,
|
||||
! isoutlier is the index number of the outlier in the sequence yobs. If there
|
||||
! is no outlier, isoutlier is returned with -9999
|
||||
! iwhichside < 0, detecting the outlier smaller than the mean
|
||||
! iwhichside > 0, detecting the outlier greater than the mean
|
||||
integer nsamp,iwhichside
|
||||
double precision yobs(nsamp)
|
||||
|
||||
integer i,imax
|
||||
double precision zc,std,fmean,dev,devmax,
|
||||
& alpha,grubbzc_1side
|
||||
parameter(alpha=0.05d0)
|
||||
|
||||
isoutlier_1side=-9999
|
||||
if(nsamp.le.2)then
|
||||
return
|
||||
endif
|
||||
call stdmean(nsamp,yobs,std,fmean)
|
||||
|
||||
devmax=-9999.0d0
|
||||
do i=1,nsamp
|
||||
dev=(yobs(i)-fmean)/std
|
||||
if(iwhichside.gt.0)then
|
||||
if(dev.gt.0.0d0.and.dev.gt.devmax)then
|
||||
imax=i
|
||||
devmax=dev
|
||||
endif
|
||||
else
|
||||
if(dev.lt.0.0d0.and.dabs(dev).gt.devmax)then
|
||||
imax=i
|
||||
devmax=dabs(dev)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
zc=grubbzc_1side(nsamp,alpha)
|
||||
if(devmax.ge.zc)then
|
||||
isoutlier_1side=imax
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
double precision function grubbzc_2sides(nsamp,alpha)
|
||||
implicit none
|
||||
integer nsamp
|
||||
double precision alpha
|
||||
|
||||
! Compute the critical Grubb Z valu
|
||||
! nsamp: the number of samples (not the degree of freedom)
|
||||
! alpha: the significance level (the sum of probabilities of
|
||||
! upper and lower tails)
|
||||
|
||||
double precision Sign_Level,tc,student_t
|
||||
integer Samples
|
||||
|
||||
Sign_Level=1.0d0-2.0d0*alpha/dble(2*nsamp)
|
||||
Samples=(nsamp-2)
|
||||
Samples=Samples+1
|
||||
tc=student_t(Samples,Sign_Level)
|
||||
|
||||
grubbzc_2sides=(dble(nsamp)-1.0d0)*tc/dsqrt(dble(nsamp))
|
||||
grubbzc_2sides=grubbzc_2sides/dsqrt(dble(nsamp-2)+tc*tc)
|
||||
return
|
||||
end
|
||||
|
||||
double precision function grubbzc_1side(nsamp,alpha)
|
||||
implicit none
|
||||
integer nsamp
|
||||
double precision alpha
|
||||
|
||||
! Compute the critical Grubb Z valu
|
||||
! nsamp: the number of samples (not the degree of freedom)
|
||||
! alpha: the significance level (one tail probability) upper and lower tails)
|
||||
|
||||
double precision Sign_Level,tc,student_t
|
||||
integer Samples
|
||||
|
||||
Sign_Level=1.0d0-2.0d0*alpha/dble(nsamp)
|
||||
Samples=(nsamp-2)
|
||||
Samples=Samples+1
|
||||
tc=student_t(Samples,Sign_Level)
|
||||
|
||||
grubbzc_1side=(dble(nsamp)-1.0d0)*tc/dsqrt(dble(nsamp))
|
||||
grubbzc_1side=grubbzc_1side/dsqrt(dble(nsamp-2)+tc*tc)
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
double precision function grubbzc_0_01(nsamp)
|
||||
implicit none
|
||||
integer nsamp,nlow,nhigh
|
||||
double precision zvalue(140),
|
||||
& a,b,x0,y0
|
||||
|
||||
if(nsamp.gt.140)then
|
||||
a=1903.0377d0
|
||||
b=-0.3756d0
|
||||
x0=1.0369d-7
|
||||
y0=-1898.8572d0
|
||||
grubbzc_0_01=y0+a/(1.0d0+(dble(nsamp)/x0)**b)
|
||||
else
|
||||
zvalue(3)=1.15d0
|
||||
zvalue(4)=1.48d0
|
||||
zvalue(5)=1.71d0
|
||||
zvalue(6)=1.89d0
|
||||
zvalue(7)=2.02d0
|
||||
zvalue(8)=2.13d0
|
||||
zvalue(9)=2.21d0
|
||||
zvalue(10)=2.29d0
|
||||
zvalue(11)=2.34d0
|
||||
zvalue(12)=2.41d0
|
||||
zvalue(13)=2.46d0
|
||||
zvalue(14)=2.51d0
|
||||
zvalue(15)=2.55d0
|
||||
zvalue(16)=2.59d0
|
||||
zvalue(17)=2.62d0
|
||||
zvalue(18)=2.65d0
|
||||
zvalue(19)=2.68d0
|
||||
zvalue(20)=2.71d0
|
||||
zvalue(21)=2.73d0
|
||||
zvalue(22)=2.76d0
|
||||
zvalue(23)=2.78d0
|
||||
zvalue(24)=2.8d0
|
||||
zvalue(25)=2.82d0
|
||||
zvalue(26)=2.84d0
|
||||
zvalue(27)=2.86d0
|
||||
zvalue(28)=2.88d0
|
||||
zvalue(29)=2.89d0
|
||||
zvalue(30)=2.91d0
|
||||
zvalue(31)=2.92d0
|
||||
zvalue(32)=2.94d0
|
||||
zvalue(33)=2.95d0
|
||||
zvalue(34)=2.97d0
|
||||
zvalue(35)=2.98d0
|
||||
zvalue(36)=2.99d0
|
||||
zvalue(37)=3.0d0
|
||||
zvalue(38)=3.01d0
|
||||
zvalue(39)=3.03d0
|
||||
zvalue(40)=3.04d0
|
||||
zvalue(50)=3.13d0
|
||||
zvalue(60)=3.2d0
|
||||
zvalue(70)=3.26d0
|
||||
zvalue(80)=3.31d0
|
||||
zvalue(90)=3.35d0
|
||||
zvalue(100)=3.38d0
|
||||
zvalue(110)=3.42d0
|
||||
zvalue(120)=3.44d0
|
||||
zvalue(130)=3.47d0
|
||||
zvalue(140)=3.49d0
|
||||
if(nsamp.le.40)then
|
||||
grubbzc_0_01=zvalue(nsamp)
|
||||
else
|
||||
if(nsamp.eq.140)then
|
||||
grubbzc_0_01=zvalue(140)
|
||||
else
|
||||
nlow=idint(dble(nsamp)/10.0d0)*10
|
||||
nhigh=10+idint(dble(nsamp)/10.0d0)*10
|
||||
grubbzc_0_01=zvalue(nlow)+(zvalue(nhigh)-zvalue(nlow))*
|
||||
& dble(nsamp-nlow)/dble(nhigh-nlow)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,973 @@
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine phenoindices(ivexcave,ndim,beta,phenofunc,step,
|
||||
&nmaxextre,tstart,tend,nphenocycl,timemark,ishape,gpprefsp,
|
||||
&gppreffl,gpprefspday,gpprefflday,spinitday,gppatspinitday,psdlin,
|
||||
&gppatpsdlin,pddlin,gppatpddlin,fltermday,gppatfltermday,centerday,
|
||||
&effgrowleng,assimpotindex,effmaxgpp,spmaxder,spmaxderday,
|
||||
&spmaxdergpp,flmaxder,flmaxderday,flmaxdergpp,extremegpp,
|
||||
&extremegppday,paramskewness,paramkurtosis,gppphase1,gppphase2,
|
||||
&gppphase3,gppphase4,gppphase5,bellarea,gppmin,gppmax,timegppmin,
|
||||
&timegppmax,nmingpp,nmaxgpp,offcenterday,offeffgrowleng,
|
||||
&offassimpotindex,offeffmaxgpp,offparamskewness,offparamkurtosis,
|
||||
&offgppphase1,offgppphase2,offgppphase3,offgppphase4,offgppphase5)
|
||||
implicit none
|
||||
!ivexcave =0, timemark provided for each pheno cycle, let the program determines the shape of each cycle
|
||||
! =1, do convex indices, use minuma as timemark
|
||||
! =2, do concave indices, use maxima as timemark
|
||||
integer ivexcave,ndim,nmaxextre,nmingpp,nmaxgpp,i,nphenocycl,
|
||||
&ishape(nmaxextre)
|
||||
double precision beta(ndim),tstart,tend,step,
|
||||
&timemark(nphenocycl+1),gpprefsp(nmaxextre),gppreffl(nmaxextre),
|
||||
&gpprefspday(nmaxextre),gpprefflday(nmaxextre),
|
||||
&spinitday(nmaxextre),gppatspinitday(nmaxextre),psdlin(nmaxextre),
|
||||
&gppatpsdlin(nmaxextre),pddlin(nmaxextre),gppatpddlin(nmaxextre),
|
||||
&fltermday(nmaxextre),gppatfltermday(nmaxextre),
|
||||
¢erday(nmaxextre),effgrowleng(nmaxextre),
|
||||
&assimpotindex(nmaxextre),effmaxgpp(nmaxextre),spmaxder(nmaxextre),
|
||||
&spmaxderday(nmaxextre),spmaxdergpp(nmaxextre),flmaxder(nmaxextre),
|
||||
&flmaxderday(nmaxextre),flmaxdergpp(nmaxextre),
|
||||
&extremegpp(nmaxextre),extremegppday(nmaxextre),
|
||||
¶mskewness(nmaxextre),paramkurtosis(nmaxextre),
|
||||
&gppphase1(nmaxextre),gppphase2(nmaxextre),gppphase3(nmaxextre),
|
||||
&gppphase4(nmaxextre),gppphase5(nmaxextre),bellarea(nmaxextre),
|
||||
&gppmin(nmaxextre),gppmax(nmaxextre),timegppmin(nmaxextre),
|
||||
&timegppmax(nmaxextre),offcenterday(nmaxextre),
|
||||
&offeffgrowleng(nmaxextre),offassimpotindex(nmaxextre),
|
||||
&offeffmaxgpp(nmaxextre),offparamskewness(nmaxextre),
|
||||
&offparamkurtosis(nmaxextre),offgppphase1(nmaxextre),
|
||||
&offgppphase2(nmaxextre),offgppphase3(nmaxextre),
|
||||
&offgppphase4(nmaxextre),offgppphase5(nmaxextre)
|
||||
external phenofunc
|
||||
call extremaviader(ndim,beta,phenofunc,step,nmaxextre,
|
||||
&tstart,tend,gppmin,gppmax,timegppmin,timegppmax,nmingpp,
|
||||
&nmaxgpp)
|
||||
if(ivexcave.eq.1.or.ivexcave.eq.2)then
|
||||
if(ivexcave.eq.1)then
|
||||
nphenocycl=nmingpp-1
|
||||
do i=1,nmingpp-1
|
||||
call bellindices(ndim,beta,phenofunc,timegppmin(i),
|
||||
&timegppmin(i+1),step,ishape(i),gpprefsp(i),gppreffl(i),
|
||||
&gpprefspday(i),gpprefflday(i),spinitday(i),
|
||||
&gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i),
|
||||
&gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i),
|
||||
&effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i),
|
||||
&spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i),
|
||||
&flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i),
|
||||
¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i),
|
||||
&gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i),
|
||||
&offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i),
|
||||
&offparamskewness(i),offparamkurtosis(i),offgppphase1(i),
|
||||
&offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i))
|
||||
enddo
|
||||
endif
|
||||
if(ivexcave.eq.2)then
|
||||
nphenocycl=nmaxgpp-1
|
||||
do i=1,nmaxgpp-1
|
||||
call bellindices(ndim,beta,phenofunc,timegppmax(i),
|
||||
&timegppmax(i+1),step,ishape(i),gpprefsp(i),gppreffl(i),
|
||||
&gpprefspday(i),gpprefflday(i),spinitday(i),
|
||||
&gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i),
|
||||
&gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i),
|
||||
&effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i),
|
||||
&spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i),
|
||||
&flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i),
|
||||
¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i),
|
||||
&gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i),
|
||||
&offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i),
|
||||
&offparamskewness(i),offparamkurtosis(i),offgppphase1(i),
|
||||
&offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i))
|
||||
enddo
|
||||
endif
|
||||
else
|
||||
do i=1,nphenocycl
|
||||
call bellindices(ndim,beta,phenofunc,timemark(i),
|
||||
&timemark(i+1),step,ishape(i),gpprefsp(i),gppreffl(i),
|
||||
&gpprefspday(i),gpprefflday(i),spinitday(i),
|
||||
&gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i),
|
||||
&gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i),
|
||||
&effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i),
|
||||
&spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i),
|
||||
&flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i),
|
||||
¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i),
|
||||
&gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i),
|
||||
&offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i),
|
||||
&offparamskewness(i),offparamkurtosis(i),offgppphase1(i),
|
||||
&offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i))
|
||||
enddo
|
||||
endif
|
||||
return
|
||||
end
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine bellindices(ndim,beta,phenofunc,firstday,lastday,
|
||||
&step,ishape,gpprefsp,gppreffl,gpprefspday,gpprefflday,
|
||||
&spinitday,gppatspinitday,psdlin,gppatpsdlin,pddlin,gppatpddlin,
|
||||
&fltermday,gppatfltermday,centerday,effgrowleng,assimpotindex,
|
||||
&effmaxgpp,spmaxder,spmaxderday,spmaxdergpp,flmaxder,flmaxderday,
|
||||
&flmaxdergpp,extremegpp,extremegppday,paramskewness,paramkurtosis,
|
||||
&gppphase1,gppphase2,gppphase3,gppphase4,gppphase5,bellarea,
|
||||
&offcenterday,offeffgrowleng,offassimpotindex,offeffmaxgpp,
|
||||
&offparamskewness,offparamkurtosis,offgppphase1,offgppphase2,
|
||||
&offgppphase3,offgppphase4,offgppphase5)
|
||||
implicit none
|
||||
integer ishape,ndim,nmaxextre
|
||||
parameter(nmaxextre=500)
|
||||
double precision beta(ndim),step,firstday,lastday,
|
||||
&gpprefsp,gppreffl,gpprefspday,gpprefflday,
|
||||
&spinitday,gppatspinitday,psdlin,gppatpsdlin,
|
||||
&pddlin,gppatpddlin,fltermday,gppatfltermday,centerday,
|
||||
&effgrowleng,assimpotindex,effmaxgpp,spmaxder,spmaxderday,
|
||||
&spmaxdergpp,flmaxder,flmaxderday,flmaxdergpp,extremegpp,
|
||||
&extremegppday,paramskewness,paramkurtosis,gppphase1,gppphase2,
|
||||
&gppphase3,gppphase4,gppphase5,bellarea,dydxp(ndim+1),
|
||||
&offcenterday,offeffgrowleng,offassimpotindex,offeffmaxgpp,
|
||||
&offparamskewness,offparamkurtosis,offgppphase1,offgppphase2,
|
||||
&offgppphase3,offgppphase4,offgppphase5
|
||||
double precision p1int,p2int,p3int,day,term,funcint,tfuncint,
|
||||
&sqtcentfunc,skewness,fkurtosis,fintercept,sigma,gppmin(nmaxextre),
|
||||
&gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre),
|
||||
&gppmin_der(nmaxextre),gppmax_der(nmaxextre),offset,
|
||||
&timegppmin_der(nmaxextre),timegppmax_der(nmaxextre)
|
||||
integer n,i,nmingpp,nmaxgpp,nmingpp_der,nmaxgpp_der
|
||||
external phenofunc
|
||||
!
|
||||
call extremaviader(ndim,beta,phenofunc,step,nmaxextre,
|
||||
&firstday,lastday,gppmin,gppmax,timegppmin,timegppmax,nmingpp,
|
||||
&nmaxgpp)
|
||||
call findextrema(1,ndim,beta,phenofunc,step,nmaxextre,
|
||||
&firstday,lastday,gppmin_der,gppmax_der,timegppmin_der,
|
||||
&timegppmax_der,nmingpp_der,nmaxgpp_der)
|
||||
!determine whether it is a convex (bell) shape or a concave (reverse-bess) shape.
|
||||
!A convex shape has the largest function value located between the sharpest ascend and the sharpest descend (ascend first).
|
||||
!A concave shape has the smallest fuction value located between the sharpest descend and the sharpest ascend (descend first).
|
||||
!largest function value
|
||||
extremegpp=gppmax(1)
|
||||
extremegppday=timegppmax(1)
|
||||
do i=2,nmaxgpp
|
||||
if(gppmax(i).gt.extremegpp)then
|
||||
extremegpp=gppmax(i)
|
||||
extremegppday=timegppmax(i)
|
||||
endif
|
||||
enddo
|
||||
!most positive derivative
|
||||
spmaxder=gppmax_der(1)
|
||||
spmaxderday=timegppmax_der(1)
|
||||
do i=2,nmaxgpp_der
|
||||
if(gppmax_der(i).gt.spmaxder)then
|
||||
spmaxder=gppmax_der(i)
|
||||
spmaxderday=timegppmax_der(i)
|
||||
endif
|
||||
enddo
|
||||
call phenofunc(1,spmaxdergpp,1,spmaxderday,ndim,beta,dydxp,0)
|
||||
!most negative derivative
|
||||
flmaxder=gppmin_der(1)
|
||||
flmaxderday=timegppmin_der(1)
|
||||
do i=2,nmingpp_der
|
||||
if(gppmin_der(i).lt.flmaxder)then
|
||||
flmaxder=gppmin_der(i)
|
||||
flmaxderday=timegppmin_der(i)
|
||||
endif
|
||||
enddo
|
||||
call phenofunc(1,flmaxdergpp,1,flmaxderday,ndim,beta,dydxp,0)
|
||||
if(flmaxderday.ge.extremegppday.and.
|
||||
&extremegppday.ge.spmaxderday)then
|
||||
!it is a convex
|
||||
ishape=1
|
||||
else
|
||||
!try concave
|
||||
!smallest function value
|
||||
extremegpp=gppmin(1)
|
||||
extremegppday=timegppmin(1)
|
||||
do i=2,nmingpp
|
||||
if(gppmin(i).lt.extremegpp)then
|
||||
extremegpp=gppmin(i)
|
||||
extremegppday=timegppmin(i)
|
||||
endif
|
||||
enddo
|
||||
call fortranswap(1,spmaxder,flmaxder)
|
||||
call fortranswap(1,spmaxderday,flmaxderday)
|
||||
call fortranswap(1,spmaxdergpp,flmaxdergpp)
|
||||
!now flmaxder is most positive and spmaxder is most negative
|
||||
if(flmaxderday.ge.extremegppday.and.
|
||||
&extremegppday.ge.spmaxderday)then
|
||||
!it is a concave
|
||||
ishape=2
|
||||
else
|
||||
!the general shape is unrecognized. use the local shape
|
||||
if(flmaxderday.lt.spmaxderday)then
|
||||
call fortranswap(1,spmaxder,flmaxder)
|
||||
call fortranswap(1,spmaxderday,flmaxderday)
|
||||
call fortranswap(1,spmaxdergpp,flmaxdergpp)
|
||||
!now spmaxder is most positive and flmaxder is most negative
|
||||
!a small bell
|
||||
ishape=-1
|
||||
else
|
||||
!a small revese-bell
|
||||
ishape=-2
|
||||
endif
|
||||
call extremaviader(ndim,beta,phenofunc,step,nmaxextre,
|
||||
&spmaxderday,flmaxderday,gppmin,gppmax,timegppmin,timegppmax,
|
||||
&nmingpp,nmaxgpp)
|
||||
if(ishape.eq.-1)then
|
||||
extremegpp=gppmax(1)
|
||||
extremegppday=timegppmax(1)
|
||||
do i=2,nmaxgpp
|
||||
if(gppmax(i).gt.extremegpp)then
|
||||
extremegpp=gppmax(i)
|
||||
extremegppday=timegppmax(i)
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
extremegpp=gppmin(1)
|
||||
extremegppday=timegppmin(1)
|
||||
do i=2,nmingpp
|
||||
if(gppmin(i).lt.extremegpp)then
|
||||
extremegpp=gppmin(i)
|
||||
extremegppday=timegppmin(i)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
!find reference gpp
|
||||
call extremaviader(ndim,beta,phenofunc,step,nmaxextre,firstday,
|
||||
&spmaxderday,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp)
|
||||
if(ishape.eq.1.or.ishape.eq.-1)then
|
||||
gpprefsp=gppmin(1)
|
||||
gpprefspday=timegppmin(1)
|
||||
do i=2,nmingpp
|
||||
if(gppmin(i).lt.gpprefsp)then
|
||||
gpprefsp=gppmin(i)
|
||||
gpprefspday=timegppmin(i)
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
gpprefsp=gppmax(1)
|
||||
gpprefspday=timegppmax(1)
|
||||
do i=2,nmaxgpp
|
||||
if(gppmax(i).lt.gpprefsp)then
|
||||
gpprefsp=gppmax(i)
|
||||
gpprefspday=timegppmax(i)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
call extremaviader(ndim,beta,phenofunc,step,nmaxextre,flmaxderday,
|
||||
&lastday,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp)
|
||||
if(ishape.eq.1.or.ishape.eq.-1)then
|
||||
gppreffl=gppmin(1)
|
||||
gpprefflday=timegppmin(1)
|
||||
do i=2,nmingpp
|
||||
if(gppmin(i).lt.gppreffl)then
|
||||
gppreffl=gppmin(i)
|
||||
gpprefflday=timegppmin(i)
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
gppreffl=gppmax(1)
|
||||
gpprefflday=timegppmax(1)
|
||||
do i=2,nmaxgpp
|
||||
if(gppmax(i).lt.gppreffl)then
|
||||
gppreffl=gppmax(i)
|
||||
gpprefflday=timegppmax(i)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
! spring
|
||||
180 fintercept=spmaxdergpp-spmaxder*spmaxderday
|
||||
spinitday=(gpprefsp-fintercept)/spmaxder
|
||||
call phenofunc(1,gppatspinitday,1,spinitday,ndim,beta,dydxp,0)
|
||||
psdlin=(extremegpp-fintercept)/spmaxder
|
||||
call phenofunc(1,gppatpsdlin,1,psdlin,ndim,beta,dydxp,0)
|
||||
! fall
|
||||
fintercept=flmaxdergpp-flmaxder*flmaxderday
|
||||
fltermday=(gppreffl-fintercept)/flmaxder
|
||||
call phenofunc(1,gppatfltermday,1,fltermday,ndim,beta,dydxp,0)
|
||||
pddlin=(extremegpp-fintercept)/flmaxder
|
||||
call phenofunc(1,gppatpddlin,1,pddlin,ndim,beta,dydxp,0)
|
||||
!
|
||||
!first no offset
|
||||
offset=0.0d0
|
||||
assimpotindex=funcint(ndim,beta,phenofunc,firstday,lastday,offset)
|
||||
p2int=tfuncint(ndim,beta,phenofunc,firstday,lastday,offset)
|
||||
centerday=p2int/assimpotindex
|
||||
p3int=sqtcentfunc(ndim,beta,phenofunc,firstday,lastday,centerday,
|
||||
&offset)
|
||||
sigma=dsqrt(p3int/assimpotindex)
|
||||
effgrowleng=2.0d0*dsqrt(3.0d0)*sigma
|
||||
effmaxgpp=assimpotindex/effgrowleng
|
||||
paramskewness=
|
||||
&skewness(ndim,beta,phenofunc,firstday,lastday,centerday,offset)
|
||||
paramskewness=paramskewness/
|
||||
& (assimpotindex*sigma*sigma*sigma)
|
||||
paramkurtosis=
|
||||
&fkurtosis(ndim,beta,phenofunc,firstday,lastday,centerday,offset)
|
||||
paramkurtosis=paramkurtosis/
|
||||
& (assimpotindex*sigma*sigma*sigma*sigma)
|
||||
paramkurtosis=paramkurtosis-3.0d0
|
||||
gppphase1=funcint(ndim,beta,phenofunc,firstday,spinitday,offset)
|
||||
gppphase2=funcint(ndim,beta,phenofunc,spinitday,psdlin,offset)
|
||||
gppphase3=funcint(ndim,beta,phenofunc,psdlin,pddlin,offset)
|
||||
gppphase4=funcint(ndim,beta,phenofunc,pddlin,fltermday,offset)
|
||||
gppphase5=funcint(ndim,beta,phenofunc,fltermday,lastday,offset)
|
||||
bellarea=funcint(ndim,beta,phenofunc,gpprefspday,gpprefflday,
|
||||
&offset)
|
||||
bellarea=bellarea-0.5d0*(gpprefsp+gppreffl)*
|
||||
&(gpprefflday-gpprefspday)
|
||||
!
|
||||
!with offset
|
||||
offset=0.5d0*(gpprefsp+gppreffl)
|
||||
offassimpotindex=funcint(ndim,beta,phenofunc,gpprefspday,
|
||||
&gpprefflday,offset)
|
||||
p2int=tfuncint(ndim,beta,phenofunc,gpprefspday,gpprefflday,offset)
|
||||
offcenterday=p2int/offassimpotindex
|
||||
p3int=sqtcentfunc(ndim,beta,phenofunc,gpprefspday,gpprefflday,
|
||||
&offcenterday,offset)
|
||||
sigma=dsqrt(p3int/offassimpotindex)
|
||||
offeffgrowleng=2.0d0*dsqrt(3.0d0)*sigma
|
||||
offeffmaxgpp=offassimpotindex/offeffgrowleng
|
||||
offparamskewness=
|
||||
&skewness(ndim,beta,phenofunc,gpprefspday,gpprefflday,
|
||||
&offcenterday,offset)
|
||||
offparamskewness=offparamskewness/
|
||||
&(offassimpotindex*sigma*sigma*sigma)
|
||||
offparamkurtosis=fkurtosis(ndim,beta,phenofunc,gpprefspday,
|
||||
&gpprefflday,offcenterday,offset)/
|
||||
&(offassimpotindex*sigma*sigma*sigma*sigma)-3.0d0
|
||||
offgppphase1=
|
||||
&funcint(ndim,beta,phenofunc,gpprefspday,spinitday,offset)
|
||||
offgppphase2=
|
||||
&funcint(ndim,beta,phenofunc,spinitday,psdlin,offset)
|
||||
offgppphase3=funcint(ndim,beta,phenofunc,psdlin,pddlin,offset)
|
||||
offgppphase4=funcint(ndim,beta,phenofunc,pddlin,fltermday,offset)
|
||||
offgppphase5=funcint(ndim,beta,phenofunc,fltermday,
|
||||
&gpprefflday,offset)
|
||||
return
|
||||
end
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
double precision function sqfuncint(ndim,beta,phenofunc,
|
||||
&day1st,dayend,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+func*func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
sqfuncint=sum
|
||||
return
|
||||
end
|
||||
c
|
||||
double precision function tsqfuncint(ndim,beta,phenofunc,
|
||||
&day1st,dayend,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+dayquad(n)*func*func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
tsqfuncint=sum
|
||||
return
|
||||
end
|
||||
|
||||
double precision function tfuncint(ndim,beta,phenofunc,
|
||||
&day1st,dayend,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+dayquad(n)*func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
tfuncint=sum
|
||||
return
|
||||
end
|
||||
c
|
||||
double precision function sqtcentsqfunc(ndim,beta,phenofunc,
|
||||
&day1st,dayend,daymid,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)*
|
||||
&func*func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
sqtcentsqfunc=sum
|
||||
return
|
||||
end
|
||||
|
||||
double precision function sqtcentfunc(ndim,beta,phenofunc,
|
||||
&day1st,dayend,daymid,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)*
|
||||
&func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
sqtcentfunc=sum
|
||||
return
|
||||
end
|
||||
|
||||
double precision function skewness(ndim,beta,phenofunc,
|
||||
&day1st,dayend,daymid,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)*
|
||||
& (dayquad(n)-daymid)*func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
skewness=sum
|
||||
return
|
||||
end
|
||||
c
|
||||
double precision function fkurtosis(ndim,beta,phenofunc,
|
||||
&day1st,dayend,daymid,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)*
|
||||
& (dayquad(n)-daymid)*(dayquad(n)-daymid)*
|
||||
& func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
fkurtosis=sum
|
||||
return
|
||||
end
|
||||
|
||||
double precision function funcint(ndim,beta,phenofunc,
|
||||
&day1st,dayend,offset)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1)
|
||||
parameter(nside=10000)
|
||||
external phenofunc
|
||||
c
|
||||
cell=(dayend-day1st)/dble(nside)
|
||||
sum = 0.0d0
|
||||
do 30 m = 1, nside
|
||||
day0 = day1st+dble(m-1)*cell
|
||||
day1 = day1st+dble(m)*cell
|
||||
call quadrat(day0, day1, dayquad, weit, fact1)
|
||||
do 40 n = 1, 8
|
||||
call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0)
|
||||
func=func-offset
|
||||
sum = sum+func*weit(n)*fact1
|
||||
40 continue
|
||||
30 continue
|
||||
funcint=sum
|
||||
return
|
||||
end
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine findextrema(idowhat,ndim,beta,phenofunc,step,
|
||||
&nmaxextre,tstart,tend,gppmin,gppmax,timegppmin,timegppmax,
|
||||
&nmingpp,nmaxgpp)
|
||||
implicit none
|
||||
!idowhat=0, function value extremes
|
||||
!idowhat=1, function devatives extrems
|
||||
integer idowhat,ndim,nmaxextre,nmingpp,nmaxgpp
|
||||
double precision beta(ndim),tstart,tend,step,gppmin(nmaxextre),
|
||||
&gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre),
|
||||
&gpp0,time,gpp1,t0,dydxp(ndim+1)
|
||||
integer istatus,iup,idn,iuptoflat,idntoflat
|
||||
parameter(iup=1,idn=2,iuptoflat=4,idntoflat=5)
|
||||
external phenofunc
|
||||
!------------------------------------------------------------------
|
||||
! find maxima and minima in gpp
|
||||
t0=tstart
|
||||
nmaxgpp=0
|
||||
nmingpp=0
|
||||
call phenofunc(1,gpp0,1,t0,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gpp0=dydxp(1)
|
||||
time=t0+step
|
||||
call phenofunc(1,gpp1,1,time,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gpp1=dydxp(1)
|
||||
if(gpp1.gt.gpp0)then
|
||||
! gpp increases so gpp0 must be a minimum
|
||||
nmingpp=1
|
||||
gppmin(1)=gpp0
|
||||
timegppmin(1)=t0
|
||||
istatus=iup
|
||||
else
|
||||
if(gpp1.lt.gpp0)then
|
||||
! gpp decreases so gpp0 must be a maximum
|
||||
nmaxgpp=1
|
||||
gppmax(1)=gpp0
|
||||
timegppmax(1)=t0
|
||||
istatus=idn
|
||||
else
|
||||
! gpp flat
|
||||
istatus=-9999
|
||||
endif
|
||||
endif
|
||||
50 gpp0=gpp1
|
||||
time=time+step
|
||||
call phenofunc(1,gpp1,1,time,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gpp1=dydxp(1)
|
||||
if(gpp1.gt.gpp0)then
|
||||
! increase
|
||||
if(istatus.eq.iup)then
|
||||
! still increase
|
||||
if(time.ge.tend)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
timegppmax(nmaxgpp)=tend
|
||||
goto 1000
|
||||
else
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
if(istatus.eq.idn)then
|
||||
! previous down but now up so a minimum is reached
|
||||
nmingpp=nmingpp+1
|
||||
gppmin(nmingpp)=gpp0
|
||||
timegppmin(nmingpp)=time-step
|
||||
if(time.ge.tend)then
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
!previous step flat
|
||||
if(istatus.eq.iuptoflat)then
|
||||
!going up to flat and then going up again. ignore this staircase.
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.idntoflat)then
|
||||
!going down to flat and then going up so the flat represents a minimum. set the time
|
||||
!stamp at the center of the flat. t0 is when the flat starts
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=(t0+time-step)/2.0d0
|
||||
call phenofunc(1,gppmin(nmingpp),1,timegppmin(nmingpp),
|
||||
&ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
if(time.ge.tend)then
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=iup
|
||||
goto 50
|
||||
else
|
||||
!flat begining of the curve and then going up so the begining is a minimum
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=t0
|
||||
call phenofunc(1,gppmin(nmingpp),1,t0,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
else
|
||||
if(gpp1.lt.gpp0)then
|
||||
! decrease
|
||||
if(istatus.eq.idn)then
|
||||
! still decrease
|
||||
if(time.ge.tend)then
|
||||
nmingpp=nmingpp+1
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
timegppmin(nmingpp)=tend
|
||||
goto 1000
|
||||
else
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
if(istatus.eq.iup)then
|
||||
! previous up but now down so a maximum is reached
|
||||
nmaxgpp=nmaxgpp+1
|
||||
gppmax(nmaxgpp)=gpp0
|
||||
timegppmax(nmaxgpp)=time-step
|
||||
if(time.ge.tend)then
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
! previous flat
|
||||
if(istatus.eq.idntoflat)then
|
||||
!going down to flat and then going down again. ignore this staircase
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.iuptoflat)then
|
||||
!going up to flat and then going down so the flat represents a maximum
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=(t0+time-step)/2.0d0
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
if(time.ge.tend)then
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=idn
|
||||
goto 50
|
||||
else
|
||||
!flat begining of the curve and then going down so the begining is a maximum
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=t0
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
else
|
||||
! a flat place
|
||||
if(istatus.eq.iup)then
|
||||
! up to flat
|
||||
if(time.ge.tend)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=iuptoflat
|
||||
t0=time-step
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.idn)then
|
||||
! down to flat
|
||||
if(time.ge.tend)then
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=idntoflat
|
||||
t0=time-step
|
||||
goto 50
|
||||
endif
|
||||
! remain on a flat. no information is recorded unless at the end.
|
||||
if(time.ge.tend)then
|
||||
if(istatus.eq.iuptoflat)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1)
|
||||
else
|
||||
if(istatus.eq.idntoflat)then
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat)
|
||||
if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1)
|
||||
else
|
||||
!a horizontal line
|
||||
return
|
||||
endif
|
||||
endif
|
||||
goto 1000
|
||||
endif
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
1000 return
|
||||
end
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
subroutine extremaviader(ndim,beta,phenofunc,step,nmaxextre,
|
||||
&tstart,tend,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp)
|
||||
implicit none
|
||||
!find function value extremes only via changes in derivatives.
|
||||
!Do not use this subroutine to find extremes of derivatives. use findextrema instead
|
||||
integer ndim,nmaxextre,nmingpp,nmaxgpp
|
||||
double precision beta(ndim),tstart,tend,step,gppmin(nmaxextre),
|
||||
&gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre),
|
||||
&gpp0,time,t0,dydxp(ndim+1)
|
||||
integer istatus,iup,idn,iuptoflat,idntoflat
|
||||
parameter(iup=1,idn=2,iuptoflat=4,idntoflat=5)
|
||||
external phenofunc
|
||||
!------------------------------------------------------------------
|
||||
! find maxima and minima in gpp
|
||||
time=tstart
|
||||
nmaxgpp=0
|
||||
nmingpp=0
|
||||
call phenofunc(1,gpp0,1,time,ndim,beta,dydxp,1)
|
||||
if(dydxp(1).gt.0.0d0)then
|
||||
! gpp increases so gpp0 must be a minimum
|
||||
nmingpp=1
|
||||
gppmin(1)=gpp0
|
||||
timegppmin(1)=time
|
||||
istatus=iup
|
||||
else
|
||||
if(dydxp(1).lt.0.0d0)then
|
||||
! gpp decreases so gpp0 must be a maximum
|
||||
nmaxgpp=1
|
||||
gppmax(1)=gpp0
|
||||
timegppmax(1)=time
|
||||
istatus=idn
|
||||
else
|
||||
! gpp flat in the begining
|
||||
istatus=-9999
|
||||
endif
|
||||
endif
|
||||
50 time=time+step
|
||||
call phenofunc(1,gpp0,1,time,ndim,beta,dydxp,1)
|
||||
if(dydxp(1).gt.0.0d0)then
|
||||
! increase
|
||||
if(istatus.eq.iup)then
|
||||
! still increase
|
||||
if(time.ge.tend)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0)
|
||||
timegppmax(nmaxgpp)=tend
|
||||
goto 1000
|
||||
else
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
if(istatus.eq.idn)then
|
||||
! previous down but now up so a minimum is reached
|
||||
nmingpp=nmingpp+1
|
||||
if(time.ge.tend)then
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
time=time-step/2.0d0
|
||||
timegppmin(nmingpp)=time
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,time,ndim,beta,dydxp,0)
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
!previous step flat
|
||||
if(istatus.eq.iuptoflat)then
|
||||
!going up to flat and then going up again. ignore this staircase.
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.idntoflat)then
|
||||
!going down to flat and then going up so the flat represents a minimum. set the time
|
||||
!stamp at the center of the flat. t0 is when the flat starts
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=(t0+time-step)/2.0d0
|
||||
call phenofunc(1,gppmin(nmingpp),1,timegppmin(nmingpp),
|
||||
&ndim,beta,dydxp,0)
|
||||
if(time.ge.tend)then
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=iup
|
||||
goto 50
|
||||
else
|
||||
!flat begining of the curve and then going up so the begining is a minimum
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=tstart
|
||||
call phenofunc(1,gppmin(nmingpp),1,tstart,ndim,beta,dydxp,0)
|
||||
istatus=iup
|
||||
goto 50
|
||||
endif
|
||||
else
|
||||
if(dydxp(1).lt.0.0d0)then
|
||||
! decrease
|
||||
if(istatus.eq.idn)then
|
||||
! still decrease
|
||||
if(time.ge.tend)then
|
||||
nmingpp=nmingpp+1
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0)
|
||||
timegppmin(nmingpp)=tend
|
||||
goto 1000
|
||||
else
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
if(istatus.eq.iup)then
|
||||
! previous up but now down so a maximum is reached
|
||||
nmaxgpp=nmaxgpp+1
|
||||
if(time.ge.tend)then
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
time=time-step/2.0d0
|
||||
timegppmax(nmaxgpp)=time
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,time,ndim,beta,dydxp,0)
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
! previous flat
|
||||
if(istatus.eq.idntoflat)then
|
||||
!going down to flat and then going down again. ignore this staircase
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.iuptoflat)then
|
||||
!going up to flat and then going down so the flat represents a maximum
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=(t0+time-step)/2.0d0
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,0)
|
||||
if(time.ge.tend)then
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=idn
|
||||
goto 50
|
||||
else
|
||||
!flat begining of the curve and then going down so the begining is a maximum
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=tstart
|
||||
call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp),
|
||||
&ndim,beta,dydxp,0)
|
||||
istatus=idn
|
||||
goto 50
|
||||
endif
|
||||
else
|
||||
! a flat place
|
||||
if(istatus.eq.iup)then
|
||||
! up to flat
|
||||
if(time.ge.tend)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=iuptoflat
|
||||
t0=time-step
|
||||
goto 50
|
||||
endif
|
||||
if(istatus.eq.idn)then
|
||||
! down to flat
|
||||
if(time.ge.tend)then
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0)
|
||||
goto 1000
|
||||
endif
|
||||
istatus=idntoflat
|
||||
t0=time-step
|
||||
goto 50
|
||||
endif
|
||||
! remain on a flat. no information is recorded unless at the end.
|
||||
if(time.ge.tend)then
|
||||
if(istatus.eq.iuptoflat)then
|
||||
nmaxgpp=nmaxgpp+1
|
||||
timegppmax(nmaxgpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0)
|
||||
else
|
||||
if(istatus.eq.idntoflat)then
|
||||
nmingpp=nmingpp+1
|
||||
timegppmin(nmingpp)=tend
|
||||
call
|
||||
&phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0)
|
||||
else
|
||||
!a horizontal line
|
||||
return
|
||||
endif
|
||||
endif
|
||||
goto 1000
|
||||
endif
|
||||
goto 50
|
||||
endif
|
||||
endif
|
||||
1000 return
|
||||
end
|
||||
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
|
||||
@@ -0,0 +1,52 @@
|
||||
subroutine removerepeat(nin,stringin,nout,stringout,ncounter)
|
||||
implicit none
|
||||
integer nin,nout,ncounter(nin,nin+1)
|
||||
character*100 stringin(nin),stringout(nin),term,
|
||||
&chari,charj
|
||||
character a*1
|
||||
integer i,j,k,n
|
||||
do i=1,nin
|
||||
do j=1,nin+1
|
||||
ncounter(i,j)=0
|
||||
enddo
|
||||
stringin(i)=trim(stringin(i))
|
||||
enddo
|
||||
nout=0
|
||||
do i=1,nin
|
||||
term=trim(stringin(i))
|
||||
n=len(term)
|
||||
chari=''
|
||||
do k=1,n
|
||||
a=term(k:k)
|
||||
if((ichar(a).ge.65.and.ichar(a).le.90).or.
|
||||
&(ichar(a).ge.97.and.ichar(a).le.122))then
|
||||
if(ichar(a).ge.97)a=char(ichar(a)-32)
|
||||
chari=trim(chari)//a
|
||||
endif
|
||||
enddo
|
||||
do j=1,nout
|
||||
term=trim(stringout(j))
|
||||
n=len(term)
|
||||
charj=''
|
||||
do k=1,n
|
||||
a=term(k:k)
|
||||
if((ichar(a).ge.65.and.ichar(a).le.90).or.
|
||||
&(ichar(a).ge.97.and.ichar(a).le.122))then
|
||||
if(ichar(a).ge.97)a=char(ichar(a)-32)
|
||||
charj=trim(charj)//a
|
||||
endif
|
||||
enddo
|
||||
if(trim(chari).eq.trim(charj))then
|
||||
ncounter(j,1)=ncounter(j,1)+1
|
||||
ncounter(j,i+1)=1
|
||||
goto 10
|
||||
endif
|
||||
enddo
|
||||
nout=nout+1
|
||||
stringout(nout)=trim(stringin(i))
|
||||
ncounter(nout,1)=ncounter(nout,1)+1
|
||||
ncounter(nout,i+1)=1
|
||||
10 continue
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,744 @@
|
||||
program main
|
||||
implicit none
|
||||
integer degree,i
|
||||
logical fail
|
||||
double precision op(4),zeror(4),zeroi(4)
|
||||
|
||||
op(1)=3.0d0
|
||||
op(2)=6.0d0
|
||||
op(3)=-123.0d0
|
||||
op(4)=-126.0d0
|
||||
op(5)=1080.0d0
|
||||
degree=4
|
||||
|
||||
call RPOLY(op,degree,zeror,zeroi,fail)
|
||||
write(*,*)degree,fail
|
||||
do i=1,4
|
||||
write(*,*)zeror(i),zeroi(i)
|
||||
enddo
|
||||
end
|
||||
|
||||
SUBROUTINE RPOLY(OP, DEGREE, ZEROR, ZEROI, RPO 10
|
||||
* FAIL)
|
||||
C FINDS THE ZEROS OF A REAL POLYNOMIAL
|
||||
C OP - DOUBLE PRECISION VECTOR OF COEFFICIENTS IN
|
||||
C ORDER OF DECREASING POWERS.
|
||||
C DEGREE - INTEGER DEGREE OF POLYNOMIAL.
|
||||
C ZEROR, ZEROI - OUTPUT DOUBLE PRECISION VECTORS OF
|
||||
C REAL AND IMAGINARY PARTS OF THE
|
||||
C ZEROS.
|
||||
C FAIL - OUTPUT LOGICAL PARAMETER, TRUE ONLY IF
|
||||
C LEADING COEFFICIENT IS ZERO OR IF RPOLY
|
||||
C HAS FOUND FEWER THAN DEGREE ZEROS.
|
||||
C IN THE LATTER CASE DEGREE IS RESET TO
|
||||
C THE NUMBER OF ZEROS FOUND.
|
||||
C TO CHANGE THE SIZE OF POLYNOMIALS WHICH CAN BE
|
||||
C SOLVED, RESET THE DIMENSIONS OF THE ARRAYS IN THE
|
||||
C COMMON AREA AND IN THE FOLLOWING DECLARATIONS.
|
||||
C THE SUBROUTINE USES SINGLE PRECISION CALCULATIONS
|
||||
C FOR SCALING, BOUNDS AND ERROR CALCULATIONS. ALL
|
||||
C CALCULATIONS FOR THE ITERATIONS ARE DONE IN DOUBLE
|
||||
C PRECISION.
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION OP(101), TEMP(101),
|
||||
* ZEROR(100), ZEROI(100), T, AA, BB, CC, DABS,
|
||||
* FACTOR
|
||||
REAL PT(101), LO, MAX, MIN, XX, YY, COSR,
|
||||
* SINR, XXX, X, SC, BND, XM, FF, DF, DX, INFIN,
|
||||
* SMALNO, BASE
|
||||
INTEGER DEGREE, CNT, NZ, I, J, JJ, NM1
|
||||
LOGICAL FAIL, ZEROK
|
||||
C THE FOLLOWING STATEMENTS SET MACHINE CONSTANTS USED
|
||||
C IN VARIOUS PARTS OF THE PROGRAM. THE MEANING OF THE
|
||||
C FOUR CONSTANTS ARE...
|
||||
C ETA THE MAXIMUM RELATIVE REPRESENTATION ERROR
|
||||
C WHICH CAN BE DESCRIBED AS THE SMALLEST
|
||||
C POSITIVE FLOATING POINT NUMBER SUCH THAT
|
||||
C 1.D0+ETA IS GREATER THAN 1.
|
||||
C INFINY THE LARGEST FLOATING-POINT NUMBER.
|
||||
C SMALNO THE SMALLEST POSITIVE FLOATING-POINT NUMBER
|
||||
C IF THE EXPONENT RANGE DIFFERS IN SINGLE AND
|
||||
C DOUBLE PRECISION THEN SMALNO AND INFIN
|
||||
C SHOULD INDICATE THE SMALLER RANGE.
|
||||
C BASE THE BASE OF THE FLOATING-POINT NUMBER
|
||||
C SYSTEM USED.
|
||||
C THE VALUES BELOW CORRESPOND TO THE BURROUGHS B6700
|
||||
BASE = 8.
|
||||
ETA = .5*BASE**(1-26)
|
||||
INFIN = 4.3E68
|
||||
SMALNO = 1.0E-45
|
||||
C ARE AND MRE REFER TO THE UNIT ERROR IN + AND *
|
||||
C RESPECTIVELY. THEY ARE ASSUMED TO BE THE SAME AS
|
||||
C ETA.
|
||||
ARE = ETA
|
||||
MRE = ETA
|
||||
LO = SMALNO/ETA
|
||||
C INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION
|
||||
XX = .70710678
|
||||
YY = -XX
|
||||
COSR = -.069756474
|
||||
SINR = .99756405
|
||||
FAIL = .FALSE.
|
||||
N = DEGREE
|
||||
NN = N + 1
|
||||
C ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO.
|
||||
IF (OP(1).NE.0.D0) GO TO 10
|
||||
FAIL = .TRUE.
|
||||
DEGREE = 0
|
||||
RETURN
|
||||
C REMOVE THE ZEROS AT THE ORIGIN IF ANY
|
||||
10 IF (OP(NN).NE.0.0D0) GO TO 20
|
||||
J = DEGREE - N + 1
|
||||
ZEROR(J) = 0.D0
|
||||
ZEROI(J) = 0.D0
|
||||
NN = NN - 1
|
||||
N = N - 1
|
||||
GO TO 10
|
||||
C MAKE A COPY OF THE COEFFICIENTS
|
||||
20 DO 30 I=1,NN
|
||||
P(I) = OP(I)
|
||||
30 CONTINUE
|
||||
C START THE ALGORITHM FOR ONE ZERO
|
||||
40 IF (N.GT.2) GO TO 60
|
||||
IF (N.LT.1) then
|
||||
RETURN
|
||||
endif
|
||||
|
||||
C CALCULATE THE FINAL ZERO OR PAIR OF ZEROS
|
||||
IF (N.EQ.2) GO TO 50
|
||||
ZEROR(DEGREE) = -P(2)/P(1)
|
||||
ZEROI(DEGREE) = 0.0D0
|
||||
RETURN
|
||||
50 CALL QUAD(P(1), P(2), P(3), ZEROR(DEGREE-1),
|
||||
* ZEROI(DEGREE-1), ZEROR(DEGREE), ZEROI(DEGREE))
|
||||
RETURN
|
||||
C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS.
|
||||
60 MAX = 0.
|
||||
MIN = INFIN
|
||||
DO 70 I=1,NN
|
||||
X = ABS(SNGL(P(I)))
|
||||
IF (X.GT.MAX) MAX = X
|
||||
IF (X.NE.0. .AND. X.LT.MIN) MIN = X
|
||||
70 CONTINUE
|
||||
C SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS
|
||||
C COMPUTES A SCALE FACTOR TO MULTIPLY THE
|
||||
C COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS DONE
|
||||
C TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW
|
||||
C INTERFERING WITH THE CONVERGENCE CRITERION.
|
||||
C THE FACTOR IS A POWER OF THE BASE
|
||||
SC = LO/MIN
|
||||
IF (SC.GT.1.0) GO TO 80
|
||||
IF (MAX.LT.10.) GO TO 110
|
||||
IF (SC.EQ.0.) SC = SMALNO
|
||||
GO TO 90
|
||||
80 IF (INFIN/SC.LT.MAX) GO TO 110
|
||||
90 L = ALOG(SC)/ALOG(BASE) + .5
|
||||
FACTOR = (BASE*1.0D0)**L
|
||||
IF (FACTOR.EQ.1.D0) GO TO 110
|
||||
DO 100 I=1,NN
|
||||
P(I) = FACTOR*P(I)
|
||||
100 CONTINUE
|
||||
C COMPUTE LOWER BOUND ON MODULI OF ZEROS.
|
||||
110 DO 120 I=1,NN
|
||||
PT(I) = ABS(SNGL(P(I)))
|
||||
120 CONTINUE
|
||||
PT(NN) = -PT(NN)
|
||||
C COMPUTE UPPER ESTIMATE OF BOUND
|
||||
X = EXP((ALOG(-PT(NN))-ALOG(PT(1)))/FLOAT(N))
|
||||
IF (PT(N).EQ.0.) GO TO 130
|
||||
C IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT.
|
||||
XM = -PT(NN)/PT(N)
|
||||
IF (XM.LT.X) X = XM
|
||||
C CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0
|
||||
130 XM = X*.1
|
||||
FF = PT(1)
|
||||
DO 140 I=2,NN
|
||||
FF = FF*XM + PT(I)
|
||||
140 CONTINUE
|
||||
IF (FF.LE.0.) GO TO 150
|
||||
X = XM
|
||||
GO TO 130
|
||||
150 DX = X
|
||||
C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO
|
||||
C DECIMAL PLACES
|
||||
160 IF (ABS(DX/X).LE..005) GO TO 180
|
||||
FF = PT(1)
|
||||
DF = FF
|
||||
DO 170 I=2,N
|
||||
FF = FF*X + PT(I)
|
||||
DF = DF*X + FF
|
||||
170 CONTINUE
|
||||
FF = FF*X + PT(NN)
|
||||
DX = FF/DF
|
||||
X = X - DX
|
||||
GO TO 160
|
||||
180 BND = X
|
||||
C COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL
|
||||
C AND DO 5 STEPS WITH NO SHIFT
|
||||
NM1 = N - 1
|
||||
DO 190 I=2,N
|
||||
K(I) = FLOAT(NN-I)*P(I)/FLOAT(N)
|
||||
190 CONTINUE
|
||||
K(1) = P(1)
|
||||
AA = P(NN)
|
||||
BB = P(N)
|
||||
ZEROK = K(N).EQ.0.D0
|
||||
DO 230 JJ=1,5
|
||||
CC = K(N)
|
||||
IF (ZEROK) GO TO 210
|
||||
C USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS
|
||||
C NONZERO
|
||||
T = -AA/CC
|
||||
DO 200 I=1,NM1
|
||||
J = NN - I
|
||||
K(J) = T*K(J-1) + P(J)
|
||||
200 CONTINUE
|
||||
K(1) = P(1)
|
||||
ZEROK = DABS(K(N)).LE.DABS(BB)*ETA*10.
|
||||
GO TO 230
|
||||
C USE UNSCALED FORM OF RECURRENCE
|
||||
210 DO 220 I=1,NM1
|
||||
J = NN - I
|
||||
K(J) = K(J-1)
|
||||
220 CONTINUE
|
||||
K(1) = 0.D0
|
||||
ZEROK = K(N).EQ.0.D0
|
||||
230 CONTINUE
|
||||
C SAVE K FOR RESTARTS WITH NEW SHIFTS
|
||||
DO 240 I=1,N
|
||||
TEMP(I) = K(I)
|
||||
240 CONTINUE
|
||||
C LOOP TO SELECT THE QUADRATIC CORRESPONDING TO EACH
|
||||
C NEW SHIFT
|
||||
DO 280 CNT=1,20
|
||||
C QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A
|
||||
C NON-REAL POINT AND ITS COMPLEX CONJUGATE. THE POINT
|
||||
C HAS MODULUS BND AND AMPLITUDE ROTATED BY 94 DEGREES
|
||||
C FROM THE PREVIOUS SHIFT
|
||||
XXX = COSR*XX - SINR*YY
|
||||
YY = SINR*XX + COSR*YY
|
||||
XX = XXX
|
||||
SR = BND*XX
|
||||
SI = BND*YY
|
||||
U = -2.0D0*SR
|
||||
V = BND
|
||||
C SECOND STAGE CALCULATION, FIXED QUADRATIC
|
||||
CALL FXSHFR(20*CNT, NZ)
|
||||
IF (NZ.EQ.0) GO TO 260
|
||||
C THE SECOND STAGE JUMPS DIRECTLY TO ONE OF THE THIRD
|
||||
C STAGE ITERATIONS AND RETURNS HERE IF SUCCESSFUL.
|
||||
C DEFLATE THE POLYNOMIAL, STORE THE ZERO OR ZEROS AND
|
||||
C RETURN TO THE MAIN ALGORITHM.
|
||||
J = DEGREE - N + 1
|
||||
ZEROR(J) = SZR
|
||||
ZEROI(J) = SZI
|
||||
NN = NN - NZ
|
||||
N = NN - 1
|
||||
DO 250 I=1,NN
|
||||
P(I) = QP(I)
|
||||
250 CONTINUE
|
||||
IF (NZ.EQ.1) GO TO 40
|
||||
ZEROR(J+1) = LZR
|
||||
ZEROI(J+1) = LZI
|
||||
GO TO 40
|
||||
C IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC
|
||||
C IS CHOSEN AFTER RESTORING K
|
||||
260 DO 270 I=1,N
|
||||
K(I) = TEMP(I)
|
||||
270 CONTINUE
|
||||
280 CONTINUE
|
||||
C RETURN WITH FAILURE IF NO CONVERGENCE WITH 20
|
||||
C SHIFTS
|
||||
FAIL = .TRUE.
|
||||
DEGREE = DEGREE - N
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE FXSHFR(L2, NZ) FXS 10
|
||||
C COMPUTES UP TO L2 FIXED SHIFT K-POLYNOMIALS,
|
||||
C TESTING FOR CONVERGENCE IN THE LINEAR OR QUADRATIC
|
||||
C CASE. INITIATES ONE OF THE VARIABLE SHIFT
|
||||
C ITERATIONS AND RETURNS WITH THE NUMBER OF ZEROS
|
||||
C FOUND.
|
||||
C L2 - LIMIT OF FIXED SHIFT STEPS
|
||||
C NZ - NUMBER OF ZEROS FOUND
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION SVU, SVV, UI, VI, S
|
||||
REAL BETAS, BETAV, OSS, OVV, SS, VV, TS, TV,
|
||||
* OTS, OTV, TVV, TSS
|
||||
INTEGER L2, NZ, TYPE, I, J, IFLAG
|
||||
LOGICAL VPASS, SPASS, VTRY, STRY
|
||||
NZ = 0
|
||||
BETAV = .25
|
||||
BETAS = .25
|
||||
OSS = SR
|
||||
OVV = V
|
||||
C EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION
|
||||
CALL QUADSD(NN, U, V, P, QP, A, B)
|
||||
CALL CALCSC(TYPE)
|
||||
DO 80 J=1,L2
|
||||
C CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V
|
||||
CALL NEXTK(TYPE)
|
||||
CALL CALCSC(TYPE)
|
||||
CALL NEWEST(TYPE, UI, VI)
|
||||
VV = VI
|
||||
C ESTIMATE S
|
||||
SS = 0.
|
||||
IF (K(N).NE.0.D0) SS = -P(NN)/K(N)
|
||||
TV = 1.
|
||||
TS = 1.
|
||||
IF (J.EQ.1 .OR. TYPE.EQ.3) GO TO 70
|
||||
C COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V
|
||||
C SEQUENCES
|
||||
IF (VV.NE.0.) TV = ABS((VV-OVV)/VV)
|
||||
IF (SS.NE.0.) TS = ABS((SS-OSS)/SS)
|
||||
C IF DECREASING, MULTIPLY TWO MOST RECENT
|
||||
C CONVERGENCE MEASURES
|
||||
TVV = 1.
|
||||
IF (TV.LT.OTV) TVV = TV*OTV
|
||||
TSS = 1.
|
||||
IF (TS.LT.OTS) TSS = TS*OTS
|
||||
C COMPARE WITH CONVERGENCE CRITERIA
|
||||
VPASS = TVV.LT.BETAV
|
||||
SPASS = TSS.LT.BETAS
|
||||
IF (.NOT.(SPASS .OR. VPASS)) GO TO 70
|
||||
C AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE
|
||||
C TEST. STORE VARIABLES BEFORE ITERATING
|
||||
SVU = U
|
||||
SVV = V
|
||||
DO 10 I=1,N
|
||||
SVK(I) = K(I)
|
||||
10 CONTINUE
|
||||
S = SS
|
||||
C CHOOSE ITERATION ACCORDING TO THE FASTEST
|
||||
C CONVERGING SEQUENCE
|
||||
VTRY = .FALSE.
|
||||
STRY = .FALSE.
|
||||
IF (SPASS .AND. ((.NOT.VPASS) .OR.
|
||||
* TSS.LT.TVV)) GO TO 40
|
||||
20 CALL QUADIT(UI, VI, NZ)
|
||||
IF (NZ.GT.0) RETURN
|
||||
C QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS
|
||||
C BEEN TRIED AND DECREASE THE CONVERGENCE CRITERION.
|
||||
VTRY = .TRUE.
|
||||
BETAV = BETAV*.25
|
||||
C TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND
|
||||
C THE S SEQUENCE IS CONVERGING
|
||||
IF (STRY .OR. (.NOT.SPASS)) GO TO 50
|
||||
DO 30 I=1,N
|
||||
K(I) = SVK(I)
|
||||
30 CONTINUE
|
||||
40 CALL REALIT(S, NZ, IFLAG)
|
||||
IF (NZ.GT.0) RETURN
|
||||
C LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN
|
||||
C TRIED AND DECREASE THE CONVERGENCE CRITERION
|
||||
STRY = .TRUE.
|
||||
BETAS = BETAS*.25
|
||||
IF (IFLAG.EQ.0) GO TO 50
|
||||
C IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL
|
||||
C ZERO ATTEMPT QUADRATIC INTERATION
|
||||
UI = -(S+S)
|
||||
VI = S*S
|
||||
GO TO 20
|
||||
C RESTORE VARIABLES
|
||||
50 U = SVU
|
||||
V = SVV
|
||||
DO 60 I=1,N
|
||||
K(I) = SVK(I)
|
||||
60 CONTINUE
|
||||
C TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED
|
||||
C AND THE V SEQUENCE IS CONVERGING
|
||||
IF (VPASS .AND. (.NOT.VTRY)) GO TO 20
|
||||
C RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE
|
||||
C SECOND STAGE
|
||||
CALL QUADSD(NN, U, V, P, QP, A, B)
|
||||
CALL CALCSC(TYPE)
|
||||
70 OVV = VV
|
||||
OSS = SS
|
||||
OTV = TV
|
||||
OTS = TS
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE QUADIT(UU, VV, NZ) QUA 10
|
||||
C VARIABLE-SHIFT K-POLYNOMIAL ITERATION FOR A
|
||||
C QUADRATIC FACTOR CONVERGES ONLY IF THE ZEROS ARE
|
||||
C EQUIMODULAR OR NEARLY SO.
|
||||
C UU,VV - COEFFICIENTS OF STARTING QUADRATIC
|
||||
C NZ - NUMBER OF ZERO FOUND
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION UI, VI, UU, VV, DABS
|
||||
REAL MS, MP, OMP, EE, RELSTP, T, ZM
|
||||
INTEGER NZ, TYPE, I, J
|
||||
LOGICAL TRIED
|
||||
NZ = 0
|
||||
TRIED = .FALSE.
|
||||
U = UU
|
||||
V = VV
|
||||
J = 0
|
||||
C MAIN LOOP
|
||||
10 CALL QUAD(1.D0, U, V, SZR, SZI, LZR, LZI)
|
||||
C RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT
|
||||
C CLOSE TO MULTIPLE OR NEARLY EQUAL AND OF OPPOSITE
|
||||
C SIGN
|
||||
IF (DABS(DABS(SZR)-DABS(LZR)).GT..01D0*
|
||||
* DABS(LZR)) RETURN
|
||||
C EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION
|
||||
CALL QUADSD(NN, U, V, P, QP, A, B)
|
||||
MP = DABS(A-SZR*B) + DABS(SZI*B)
|
||||
C COMPUTE A RIGOROUS BOUND ON THE ROUNDING ERROR IN
|
||||
C EVALUTING P
|
||||
ZM = SQRT(ABS(SNGL(V)))
|
||||
EE = 2.*ABS(SNGL(QP(1)))
|
||||
T = -SZR*B
|
||||
DO 20 I=2,N
|
||||
EE = EE*ZM + ABS(SNGL(QP(I)))
|
||||
20 CONTINUE
|
||||
EE = EE*ZM + ABS(SNGL(A)+T)
|
||||
EE = (5.*MRE+4.*ARE)*EE - (5.*MRE+2.*ARE)*
|
||||
* (ABS(SNGL(A)+T)+ABS(SNGL(B))*ZM) +
|
||||
* 2.*ARE*ABS(T)
|
||||
C ITERATION HAS CONVERGED SUFFICIENTLY IF THE
|
||||
C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
|
||||
IF (MP.GT.20.*EE) GO TO 30
|
||||
NZ = 2
|
||||
RETURN
|
||||
30 J = J + 1
|
||||
C STOP ITERATION AFTER 20 STEPS
|
||||
IF (J.GT.20) RETURN
|
||||
IF (J.LT.2) GO TO 50
|
||||
IF (RELSTP.GT..01 .OR. MP.LT.OMP .OR. TRIED)
|
||||
* GO TO 50
|
||||
C A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE.
|
||||
C FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V CLOSE
|
||||
C TO THE CLUSTER
|
||||
IF (RELSTP.LT.ETA) RELSTP = ETA
|
||||
RELSTP = SQRT(RELSTP)
|
||||
U = U - U*RELSTP
|
||||
V = V + V*RELSTP
|
||||
CALL QUADSD(NN, U, V, P, QP, A, B)
|
||||
DO 40 I=1,5
|
||||
CALL CALCSC(TYPE)
|
||||
CALL NEXTK(TYPE)
|
||||
40 CONTINUE
|
||||
TRIED = .TRUE.
|
||||
J = 0
|
||||
50 OMP = MP
|
||||
C CALCULATE NEXT K POLYNOMIAL AND NEW U AND V
|
||||
CALL CALCSC(TYPE)
|
||||
CALL NEXTK(TYPE)
|
||||
CALL CALCSC(TYPE)
|
||||
CALL NEWEST(TYPE, UI, VI)
|
||||
C IF VI IS ZERO THE ITERATION IS NOT CONVERGING
|
||||
IF (VI.EQ.0.D0) RETURN
|
||||
RELSTP = DABS((VI-V)/VI)
|
||||
U = UI
|
||||
V = VI
|
||||
GO TO 10
|
||||
END
|
||||
SUBROUTINE REALIT(SSS, NZ, IFLAG) REA 10
|
||||
C VARIABLE-SHIFT H POLYNOMIAL ITERATION FOR A REAL
|
||||
C ZERO.
|
||||
C SSS - STARTING ITERATE
|
||||
C NZ - NUMBER OF ZERO FOUND
|
||||
C IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR REAL
|
||||
C AXIS.
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION PV, KV, T, S, SSS, DABS
|
||||
REAL MS, MP, OMP, EE
|
||||
INTEGER NZ, IFLAG, I, J, NM1
|
||||
NM1 = N - 1
|
||||
NZ = 0
|
||||
S = SSS
|
||||
IFLAG = 0
|
||||
J = 0
|
||||
C MAIN LOOP
|
||||
10 PV = P(1)
|
||||
C EVALUATE P AT S
|
||||
QP(1) = PV
|
||||
DO 20 I=2,NN
|
||||
PV = PV*S + P(I)
|
||||
QP(I) = PV
|
||||
20 CONTINUE
|
||||
MP = DABS(PV)
|
||||
C COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING
|
||||
C P
|
||||
MS = DABS(S)
|
||||
EE = (MRE/(ARE+MRE))*ABS(SNGL(QP(1)))
|
||||
DO 30 I=2,NN
|
||||
EE = EE*MS + ABS(SNGL(QP(I)))
|
||||
30 CONTINUE
|
||||
C ITERATION HAS CONVERGED SUFFICIENTLY IF THE
|
||||
C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND
|
||||
IF (MP.GT.20.*((ARE+MRE)*EE-MRE*MP)) GO TO 40
|
||||
NZ = 1
|
||||
SZR = S
|
||||
SZI = 0.D0
|
||||
RETURN
|
||||
40 J = J + 1
|
||||
C STOP ITERATION AFTER 10 STEPS
|
||||
IF (J.GT.10) RETURN
|
||||
IF (J.LT.2) GO TO 50
|
||||
IF (DABS(T).GT..001*DABS(S-T) .OR. MP.LE.OMP)
|
||||
* GO TO 50
|
||||
C A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN
|
||||
C ENCOUNTERED RETURN WITH IFLAG SET TO INITIATE A
|
||||
C QUADRATIC ITERATION
|
||||
IFLAG = 1
|
||||
SSS = S
|
||||
RETURN
|
||||
C RETURN IF THE POLYNOMIAL VALUE HAS INCREASED
|
||||
C SIGNIFICANTLY
|
||||
50 OMP = MP
|
||||
C COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE
|
||||
KV = K(1)
|
||||
QK(1) = KV
|
||||
DO 60 I=2,N
|
||||
KV = KV*S + K(I)
|
||||
QK(I) = KV
|
||||
60 CONTINUE
|
||||
IF (DABS(KV).LE.DABS(K(N))*10.*ETA) GO TO 80
|
||||
C USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE
|
||||
C OF K AT S IS NONZERO
|
||||
T = -PV/KV
|
||||
K(1) = QP(1)
|
||||
DO 70 I=2,N
|
||||
K(I) = T*QK(I-1) + QP(I)
|
||||
70 CONTINUE
|
||||
GO TO 100
|
||||
C USE UNSCALED FORM
|
||||
80 K(1) = 0.0D0
|
||||
DO 90 I=2,N
|
||||
K(I) = QK(I-1)
|
||||
90 CONTINUE
|
||||
100 KV = K(1)
|
||||
DO 110 I=2,N
|
||||
KV = KV*S + K(I)
|
||||
110 CONTINUE
|
||||
T = 0.D0
|
||||
IF (DABS(KV).GT.DABS(K(N))*10.*ETA) T = -PV/KV
|
||||
S = S + T
|
||||
GO TO 10
|
||||
END
|
||||
SUBROUTINE CALCSC(TYPE) CAL 10
|
||||
C THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO
|
||||
C COMPUTE THE NEXT K POLYNOMIAL AND NEW ESTIMATES OF
|
||||
C THE QUADRATIC COEFFICIENTS.
|
||||
C TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE
|
||||
C CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION DABS
|
||||
INTEGER TYPE
|
||||
C SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V
|
||||
CALL QUADSD(N, U, V, K, QK, C, D)
|
||||
IF (DABS(C).GT.DABS(K(N))*100.*ETA) GO TO 10
|
||||
IF (DABS(D).GT.DABS(K(N-1))*100.*ETA) GO TO 10
|
||||
TYPE = 3
|
||||
C TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR
|
||||
C OF K
|
||||
RETURN
|
||||
10 IF (DABS(D).LT.DABS(C)) GO TO 20
|
||||
TYPE = 2
|
||||
C TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D
|
||||
E = A/D
|
||||
F = C/D
|
||||
G = U*B
|
||||
H = V*B
|
||||
A3 = (A+G)*E + H*(B/D)
|
||||
A1 = B*F - A
|
||||
A7 = (F+U)*A + H
|
||||
RETURN
|
||||
20 TYPE = 1
|
||||
C TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C
|
||||
E = A/C
|
||||
F = D/C
|
||||
G = U*E
|
||||
H = V*B
|
||||
A3 = A*E + (H/C+G)*B
|
||||
A1 = B - A*(D/C)
|
||||
A7 = A + G*D + H*F
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE NEXTK(TYPE) NEX 10
|
||||
C COMPUTES THE NEXT K POLYNOMIALS USING SCALARS
|
||||
C COMPUTED IN CALCSC
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION TEMP, DABS
|
||||
INTEGER TYPE
|
||||
IF (TYPE.EQ.3) GO TO 40
|
||||
TEMP = A
|
||||
IF (TYPE.EQ.1) TEMP = B
|
||||
IF (DABS(A1).GT.DABS(TEMP)*ETA*10.) GO TO 20
|
||||
C IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE
|
||||
C RECURRENCE
|
||||
K(1) = 0.D0
|
||||
K(2) = -A7*QP(1)
|
||||
DO 10 I=3,N
|
||||
K(I) = A3*QK(I-2) - A7*QP(I-1)
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
C USE SCALED FORM OF THE RECURRENCE
|
||||
20 A7 = A7/A1
|
||||
A3 = A3/A1
|
||||
K(1) = QP(1)
|
||||
K(2) = QP(2) - A7*QP(1)
|
||||
DO 30 I=3,N
|
||||
K(I) = A3*QK(I-2) - A7*QP(I-1) + QP(I)
|
||||
30 CONTINUE
|
||||
RETURN
|
||||
C USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3
|
||||
40 K(1) = 0.D0
|
||||
K(2) = 0.D0
|
||||
DO 50 I=3,N
|
||||
K(I) = QK(I-2)
|
||||
50 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE NEWEST(TYPE, UU, VV) NEW 10
|
||||
C COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS
|
||||
C USING THE SCALARS COMPUTED IN CALCSC.
|
||||
COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U,
|
||||
* V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G,
|
||||
* H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN
|
||||
DOUBLE PRECISION P(101), QP(101), K(101),
|
||||
* QK(101), SVK(101), SR, SI, U, V, A, B, C, D,
|
||||
* A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI,
|
||||
* LZR, LZI
|
||||
REAL ETA, ARE, MRE
|
||||
INTEGER N, NN
|
||||
DOUBLE PRECISION A4, A5, B1, B2, C1, C2, C3,
|
||||
* C4, TEMP, UU, VV
|
||||
INTEGER TYPE
|
||||
C USE FORMULAS APPROPRIATE TO SETTING OF TYPE.
|
||||
IF (TYPE.EQ.3) GO TO 30
|
||||
IF (TYPE.EQ.2) GO TO 10
|
||||
A4 = A + U*B + H*F
|
||||
A5 = C + (U+V*F)*D
|
||||
GO TO 20
|
||||
10 A4 = (A+G)*F + H
|
||||
A5 = (F+U)*C + V*D
|
||||
C EVALUATE NEW QUADRATIC COEFFICIENTS.
|
||||
20 B1 = -K(N)/P(NN)
|
||||
B2 = -(K(N-1)+B1*P(N))/P(NN)
|
||||
C1 = V*B2*A1
|
||||
C2 = B1*A7
|
||||
C3 = B1*B1*A3
|
||||
C4 = C1 - C2 - C3
|
||||
TEMP = A5 + B1*A4 - C4
|
||||
IF (TEMP.EQ.0.D0) GO TO 30
|
||||
UU = U - (U*(C3+C2)+V*(B1*A1+B2*A7))/TEMP
|
||||
VV = V*(1.+C4/TEMP)
|
||||
RETURN
|
||||
C IF TYPE=3 THE QUADRATIC IS ZEROED
|
||||
30 UU = 0.D0
|
||||
VV = 0.D0
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE QUADSD(NN, U, V, P, Q, A, B) QUA 10
|
||||
C DIVIDES P BY THE QUADRATIC 1,U,V PLACING THE
|
||||
C QUOTIENT IN Q AND THE REMAINDER IN A,B
|
||||
DOUBLE PRECISION P(NN), Q(NN), U, V, A, B, C
|
||||
INTEGER I
|
||||
B = P(1)
|
||||
Q(1) = B
|
||||
A = P(2) - U*B
|
||||
Q(2) = A
|
||||
DO 10 I=3,NN
|
||||
C = P(I) - U*A - V*B
|
||||
Q(I) = C
|
||||
B = A
|
||||
A = C
|
||||
10 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE QUAD(A, B1, C, SR, SI, LR, LI) QUA 10
|
||||
C CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C.
|
||||
C THE QUADRATIC FORMULA, MODIFIED TO AVOID
|
||||
C OVERFLOW, IS USED TO FIND THE LARGER ZERO IF THE
|
||||
C ZEROS ARE REAL AND BOTH ZEROS ARE COMPLEX.
|
||||
C THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE
|
||||
C PRODUCT OF THE ZEROS C/A.
|
||||
DOUBLE PRECISION A, B1, C, SR, SI, LR, LI, B,
|
||||
* D, E, DABS, DSQRT
|
||||
IF (A.NE.0.D0) GO TO 20
|
||||
SR = 0.D0
|
||||
IF (B1.NE.0.D0) SR = -C/B1
|
||||
LR = 0.D0
|
||||
10 SI = 0.D0
|
||||
LI = 0.D0
|
||||
RETURN
|
||||
20 IF (C.NE.0.D0) GO TO 30
|
||||
SR = 0.D0
|
||||
LR = -B1/A
|
||||
GO TO 10
|
||||
C COMPUTE DISCRIMINANT AVOIDING OVERFLOW
|
||||
30 B = B1/2.D0
|
||||
IF (DABS(B).LT.DABS(C)) GO TO 40
|
||||
E = 1.D0 - (A/B)*(C/B)
|
||||
D = DSQRT(DABS(E))*DABS(B)
|
||||
GO TO 50
|
||||
40 E = A
|
||||
IF (C.LT.0.D0) E = -A
|
||||
E = B*(B/DABS(C)) - E
|
||||
D = DSQRT(DABS(E))*DSQRT(DABS(C))
|
||||
50 IF (E.LT.0.D0) GO TO 60
|
||||
C REAL ZEROS
|
||||
IF (B.GE.0.D0) D = -D
|
||||
LR = (-B+D)/A
|
||||
SR = 0.D0
|
||||
IF (LR.NE.0.D0) SR = (C/LR)/A
|
||||
GO TO 10
|
||||
C COMPLEX CONJUGATE ZEROS
|
||||
60 SR = -B/A
|
||||
LR = SR
|
||||
SI = DABS(D/A)
|
||||
LI = -SI
|
||||
RETURN
|
||||
END
|
||||
@@ -0,0 +1,158 @@
|
||||
double precision function sigmoidfunc(y0,a,b,c,x0,x)
|
||||
implicit none
|
||||
double precision y0,a,b,c,x0,x,term,crit
|
||||
parameter(crit=300.0d0)
|
||||
if((-(x-x0)/b).lt.crit)then
|
||||
term=dexp(-(x-x0)/b)
|
||||
sigmoidfunc=y0+a*(1.0d0/(1.0d0+term))**c
|
||||
else
|
||||
term=dexp((x-x0)/b)
|
||||
sigmoidfunc=y0+a*(term/(1.0d0+term))**c
|
||||
endif
|
||||
return
|
||||
end
|
||||
!-------------------------------------------------------------------
|
||||
subroutine gradsigmoidfunc(y0,a,b,c,x0,x,grad)
|
||||
implicit none
|
||||
double precision y0,a,b,c,x0,x,grad(6),term,crit
|
||||
parameter(crit=300.0d0)
|
||||
! a<->grad(1)
|
||||
! b<->grad(2)
|
||||
! c<->grad(3)
|
||||
! x0<->grad(4)
|
||||
! y0<->grad(5)
|
||||
! x<->grad(6)
|
||||
grad(5)=1.0d0
|
||||
if((-(x-x0)/b).lt.crit)then
|
||||
term=dexp(-(x-x0)/b)
|
||||
grad(1)=(1.0d0/(1.0d0+term))**c
|
||||
grad(6)=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
||||
grad(4)=-(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c)
|
||||
grad(2)=-(a*c*term*(x-x0)/(b*b))*
|
||||
& (1.0d0/(1.0d0+term))**(1.0d0+c)
|
||||
grad(3)=-(a*dlog(1.0d0+term))*(1.0d0/(1.0d0+term))**c
|
||||
else
|
||||
term=(x-x0)/b
|
||||
grad(1)=(dexp(term)/(1.0d0+dexp(term)))**c
|
||||
grad(6)=(a*c/b)*(dexp(term*c/(c+1.0d0))/
|
||||
& (1.0d0+dexp(term)))**(c+1.0d0)
|
||||
grad(4)=-(a*c/b)*(dexp(term*c/(c+1))/
|
||||
& (1.0d0+dexp(term)))**(c+1.0d0)
|
||||
grad(2)=-(a*c*(x-x0)/(b*b))*
|
||||
& (dexp(term*c/(c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c)
|
||||
grad(3)=-a*(dlog(1.0d0+dexp(term))-term)*
|
||||
& (dexp(term)/(1.0d0+dexp(term)))**c
|
||||
endif
|
||||
return
|
||||
end
|
||||
!--------------------------------------------------------------------
|
||||
double precision function twoexpfunc(y0,a1,b1,c1,x01,
|
||||
&a2,b2,c2,x02,x)
|
||||
implicit none
|
||||
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,sigmoidfunc
|
||||
twoexpfunc=y0+sigmoidfunc(0.0d0,a1,b1,c1,x01,x)-
|
||||
&sigmoidfunc(0.0d0,a2,b2,c2,x02,x)
|
||||
return
|
||||
end
|
||||
!---------------------------------------------------------------------
|
||||
subroutine gradtwoexp(y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad)
|
||||
implicit none
|
||||
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad(10),grad6(6)
|
||||
integer i
|
||||
! a1<->grad(1)
|
||||
! b1<->grad(2)
|
||||
! c1<->grad(3)
|
||||
! x01<->grad(4)
|
||||
! y0<->grad(5)
|
||||
! x<->grad(6)
|
||||
! a2<->grad(7)
|
||||
! b2<->grad(8)
|
||||
! c2<->grad(9)
|
||||
! x02<->grad(10)
|
||||
call gradsigmoidfunc(y0,a1,b1,c1,x01,x,grad6)
|
||||
do i=1,6
|
||||
grad(i)=grad6(i)
|
||||
enddo
|
||||
call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6)
|
||||
grad(6)=grad(6)-grad6(6)
|
||||
do i=1,4
|
||||
grad(6+i)=-grad6(i)
|
||||
enddo
|
||||
return
|
||||
end
|
||||
!------------------------------------------------------------------------------
|
||||
subroutine proxyinflpoints(b1,c1,x01,b2,c2,x02,xinfl1,xinfl2)
|
||||
! the approximate inflection points. The exact analytical solution
|
||||
! is difficult to find
|
||||
implicit none
|
||||
double precision b1,c1,x01,b2,c2,x02,xinfl1,xinfl2
|
||||
xinfl1=x01+b1*dlog(c1)
|
||||
xinfl2=x02+b2*dlog(c2)
|
||||
end
|
||||
!------------------------------------------------------------------------------
|
||||
double precision function sigmoidcurvat(y0,a,b,c,x0,x)
|
||||
implicit none
|
||||
double precision y0,a,b,c,x0,x,term,yp,ypp,crit
|
||||
parameter(crit=300.0d0)
|
||||
if((-(x-x0)/b).lt.crit)then
|
||||
term=dexp(-(x-x0)/b)
|
||||
yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
||||
ypp=(a*c/(b*b))*term*(c*term-1.0d0)*
|
||||
& (1.0d0/(1.0d0+term))**(c+2)
|
||||
else
|
||||
term=(x-x0)/b
|
||||
yp=(a*c/b)*(dexp(term*c/(c+1))/
|
||||
& (1.0d0+dexp(term)))**(c+1.0d0)
|
||||
ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
||||
& (1.0d0+dexp(term)))**(c+2)
|
||||
endif
|
||||
sigmoidcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0))
|
||||
return
|
||||
end
|
||||
!------------------------------------------------------------------------------
|
||||
double precision function twoexpcurvat(y0,a1,b1,c1,x01,
|
||||
&a2,b2,c2,x02,x)
|
||||
implicit none
|
||||
double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,a,b,c,x0,
|
||||
&term,yp,ypp,crit
|
||||
parameter(crit=300.0d0)
|
||||
|
||||
! first part
|
||||
a=a1
|
||||
b=b1
|
||||
c=c1
|
||||
x0=x01
|
||||
if((-(x-x0)/b).lt.crit)then
|
||||
term=dexp(-(x-x0)/b)
|
||||
yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
||||
ypp=(a*c/(b*b))*term*(c*term-1.0d0)*
|
||||
& (1.0d0/(1.0d0+term))**(c+2)
|
||||
else
|
||||
term=(x-x0)/b
|
||||
yp=(a*c/b)*(dexp(term*c/(c+1))/
|
||||
& (1.0d0+dexp(term)))**(c+1.0d0)
|
||||
ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
||||
& (1.0d0+dexp(term)))**(c+2)
|
||||
endif
|
||||
|
||||
! second part
|
||||
a=a2
|
||||
b=b2
|
||||
c=c2
|
||||
x0=x02
|
||||
if((-(x-x0)/b).lt.crit)then
|
||||
term=dexp(-(x-x0)/b)
|
||||
yp=yp-(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0)
|
||||
ypp=ypp-(a*c/(b*b))*term*(c*term-1.0d0)*
|
||||
& (1.0d0/(1.0d0+term))**(c+2)
|
||||
else
|
||||
term=(x-x0)/b
|
||||
yp=yp-(a*c/b)*(dexp(term*c/(c+1))/
|
||||
& (1.0d0+dexp(term)))**(c+1.0d0)
|
||||
ypp=ypp-(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/
|
||||
& (1.0d0+dexp(term)))**(c+2)
|
||||
endif
|
||||
twoexpcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0))
|
||||
return
|
||||
end
|
||||
!-----------------------------------------------------------------------
|
||||
@@ -0,0 +1,41 @@
|
||||
!####################################################################
|
||||
subroutine stdmaxmeanmin(nsamp0,xvar0,std,fmean,xmin,xmax)
|
||||
implicit none
|
||||
integer nsamp,j,nsamp0
|
||||
double precision xvar(nsamp0),std,fmean,xmin,xmax,
|
||||
& xvar0(nsamp0),gap
|
||||
parameter(gap=-9999.0d0)
|
||||
|
||||
nsamp=0
|
||||
do j=1,nsamp0
|
||||
if(dabs(xvar0(j)-gap).gt.1.0d-5)then
|
||||
nsamp=nsamp+1
|
||||
xvar(nsamp)=xvar0(j)
|
||||
endif
|
||||
enddo
|
||||
if(nsamp.lt.1)then
|
||||
std=gap
|
||||
fmean=gap
|
||||
xmin=gap
|
||||
xmax=gap
|
||||
return
|
||||
endif
|
||||
fmean=0.0d0
|
||||
xmin=xvar(1)
|
||||
xmax=xvar(1)
|
||||
do j=1,nsamp
|
||||
fmean=fmean+xvar(j)
|
||||
if(xvar(j).gt.xmax)then
|
||||
xmax=xvar(j)
|
||||
endif
|
||||
if(xvar(j).lt.xmin)then
|
||||
xmin=xvar(j)
|
||||
endif
|
||||
enddo
|
||||
fmean=fmean/dble(nsamp)
|
||||
std=0.0d0
|
||||
do j=1,nsamp
|
||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
if(nsamp.gt.1)std=dsqrt(std/dble(nsamp-1))
|
||||
end
|
||||
@@ -0,0 +1,42 @@
|
||||
!####################################################################
|
||||
|
||||
subroutine stemaxmeanmin(nsamp0,xvar0,ste,fmean,xmin,xmax)
|
||||
implicit none
|
||||
integer nsamp,j,nsamp0
|
||||
double precision xvar(nsamp0),ste,fmean,xmin,xmax,
|
||||
& xvar0(nsamp0),gap
|
||||
parameter(gap=-9999.0d0)
|
||||
|
||||
nsamp=0
|
||||
do j=1,nsamp0
|
||||
if(dabs(xvar0(j)-gap).gt.1.0d-5)then
|
||||
nsamp=nsamp+1
|
||||
xvar(nsamp)=xvar0(j)
|
||||
endif
|
||||
enddo
|
||||
if(nsamp.lt.1)then
|
||||
ste=gap
|
||||
fmean=gap
|
||||
xmin=gap
|
||||
xmax=gap
|
||||
return
|
||||
endif
|
||||
fmean=0.0d0
|
||||
xmin=xvar(1)
|
||||
xmax=xvar(1)
|
||||
do j=1,nsamp
|
||||
fmean=fmean+xvar(j)
|
||||
if(xvar(j).gt.xmax)then
|
||||
xmax=xvar(j)
|
||||
endif
|
||||
if(xvar(j).lt.xmin)then
|
||||
xmin=xvar(j)
|
||||
endif
|
||||
enddo
|
||||
fmean=fmean/dble(nsamp)
|
||||
ste=0.0d0
|
||||
do j=1,nsamp
|
||||
ste=ste+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
if(nsamp.gt.1)ste=dsqrt(ste/dble((nsamp-1)*nsamp))
|
||||
end
|
||||
@@ -0,0 +1,212 @@
|
||||
double precision function student_t(ndegfree,Sign_Level)
|
||||
!
|
||||
! the integration from -student_t to student_t =Sign_Level
|
||||
!
|
||||
! The student-t is calculated for a given degree of freedom
|
||||
! and at a certain significance level.
|
||||
! The following relation holds:
|
||||
! Sign_Level = 1 - IncompleteBetaFunction( x, a, b )
|
||||
! x = Df / ( Df + student_t^2 )
|
||||
! a = Df / 2
|
||||
! b = 0.50
|
||||
! We need to solve the above equation for x (or student_t).
|
||||
! Routines from Numerical Recipes are used for that.
|
||||
|
||||
implicit none
|
||||
! Input variables.
|
||||
integer ndegfree
|
||||
! Degree of freedom
|
||||
double precision Sign_Level
|
||||
! Significance level
|
||||
|
||||
! Functions and parameters.
|
||||
double precision zbrent,tobesolved
|
||||
double precision x1,x2,b,eps
|
||||
parameter(x1=0.0d0,x2=1.0d0,b=0.50d0,eps=1.0d-7)
|
||||
|
||||
! Various parameters: x1, x2 bracket the root, given with
|
||||
! accuracy eps.
|
||||
|
||||
! Local
|
||||
double precision Df,a
|
||||
! Degrees of freedom␍
|
||||
! a = 0.50 * Df
|
||||
|
||||
external zbrent,tobesolved
|
||||
|
||||
Df = dble(ndegfree)
|
||||
a = 0.50d0 * Df
|
||||
student_t=zbrent(tobesolved,a,b,Sign_Level,x1,x2,eps)
|
||||
student_t = dsqrt( Df/student_t - Df)
|
||||
end function student_t
|
||||
|
||||
␍ double precision function tobesolved( a, b, c, x )
|
||||
␍ implicit none
|
||||
double precision a, b, c, x
|
||||
! a, b, c: parameters to the function
|
||||
! x: variable
|
||||
double precision betai
|
||||
external betai
|
||||
! Incomplete beta function.
|
||||
tobesolved = betai(a,b,x) - 1.0d0 + c
|
||||
end function tobesolved
|
||||
|
||||
! The rest of this file comes from Numerical Recipes.
|
||||
! Function zbrent has been modified slightly
|
||||
! (variables aaa, bbb, ccc have been intoduced).
|
||||
|
||||
! Brent's method for solving the equation
|
||||
! func(a,b,c,x)=0 for x, where a,b,c parameters.
|
||||
! Root is bracketed by x1 and x2.
|
||||
! Root is returned to varable zbrent with
|
||||
! accuracy tol.
|
||||
|
||||
double precision function zbrent(func,aaa,bbb,ccc,x1,x2,tol)
|
||||
implicit none
|
||||
integer ITMAX,iter
|
||||
double precision tol,x1,x2,func,EPS,
|
||||
& a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm,
|
||||
& aaa,bbb,ccc
|
||||
parameter(ITMAX=5000)
|
||||
parameter(EPS=3.0d-8)
|
||||
external func
|
||||
|
||||
a=x1
|
||||
b=x2
|
||||
|
||||
fa=func(aaa,bbb,ccc,a)
|
||||
fb=func(aaa,bbb,ccc,b)
|
||||
if((fa.gt.0.0d0.and.fb.gt.0.0d0).or.
|
||||
& (fa.lt.0.0d0.and.fb.lt.0.0d0))then
|
||||
write(*,*) 'root must be bracketed for zbrent'
|
||||
endif
|
||||
c=b
|
||||
fc=fb
|
||||
do 11 iter=1,ITMAX
|
||||
if((fb.gt.0.0d0.and.fc.gt.0.0d0).or.
|
||||
& (fb.lt.0.0d0.and.fc.lt.0.0d0))then
|
||||
c=a
|
||||
fc=fa
|
||||
d=b-a
|
||||
e=d
|
||||
endif
|
||||
if(dabs(fc).lt.dabs(fb)) then
|
||||
a=b
|
||||
b=c
|
||||
c=a
|
||||
fa=fb
|
||||
fb=fc
|
||||
fc=fa
|
||||
endif
|
||||
tol1=2.0d0*EPS*dabs(b)+0.5d0*tol
|
||||
xm=0.5d0*(c-b)
|
||||
if(dabs(xm).le.tol1.or.fb.eq.0.0d0)then
|
||||
zbrent=b
|
||||
return
|
||||
endif
|
||||
if(dabs(e).ge.tol1.and.dabs(fa).gt.dabs(fb))then
|
||||
s=fb/fa
|
||||
if(a.eq.c) then
|
||||
p=2.0d0*xm*s
|
||||
q=1.0d0-s
|
||||
else
|
||||
q=fa/fc
|
||||
r=fb/fc
|
||||
p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0))
|
||||
q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0)
|
||||
endif
|
||||
if(p.gt.0.0d0)q=-q
|
||||
p=dabs(p)
|
||||
if(2.0d0*p.lt.dmin1(3.0d0*xm*q-dabs(tol1*q),dabs(e*q)))then
|
||||
e=d
|
||||
d=p/q
|
||||
else
|
||||
d=xm
|
||||
e=d
|
||||
endif
|
||||
else
|
||||
d=xm
|
||||
e=d
|
||||
endif
|
||||
a=b
|
||||
fa=fb
|
||||
if(dabs(d).gt.tol1)then
|
||||
b=b+d
|
||||
else
|
||||
b=b+dsign(tol1,xm)
|
||||
endif
|
||||
fb=func(aaa,bbb,ccc,b)
|
||||
11 continue
|
||||
write(*,*) 'zbrent exceeding maximum iterations'
|
||||
zbrent=b
|
||||
return
|
||||
end function zbrent
|
||||
|
||||
! Incomplete beta function.
|
||||
double precision function betai(a,b,x)
|
||||
double precision a,b,x
|
||||
!U USES betacf,gammln
|
||||
double precision bt
|
||||
double precision betacf,gammln
|
||||
external betacf,gammln
|
||||
|
||||
if(x.lt.0.0d0.or.x.gt.1.0d0)then
|
||||
write(*,*) 'bad argument x in betai'
|
||||
endif
|
||||
if(x.eq.0.0d0.or.x.eq.1.0d0)then
|
||||
bt=0.0d0
|
||||
else
|
||||
bt=dexp(gammln(a+b)-gammln(a)-gammln(b)+
|
||||
& a*dlog(x)+b*dlog(1.0d0-x))
|
||||
endif
|
||||
if(x.lt.(a+1.0d0)/(a+b+2.0d0))then
|
||||
betai=bt*betacf(a,b,x)/a
|
||||
return
|
||||
else
|
||||
betai=1.0d0-bt*betacf(b,a,1.0d0-x)/b
|
||||
return
|
||||
endif
|
||||
end function betai
|
||||
|
||||
␍! Continued fraction evaluation.
|
||||
! Used by routine betai.
|
||||
! Numerical Recipes, chapter 6.4.
|
||||
double precision function betacf(a,b,x)
|
||||
implicit none
|
||||
integer MAXIT,m,m2
|
||||
double precision a,b,x,EPS,FPMIN
|
||||
double precision aa,c,d,del,h,qab,qam,qap
|
||||
parameter(MAXIT = 100)
|
||||
parameter(EPS=3.0d-7,FPMIN=1.0d-30)
|
||||
|
||||
qab=a+b
|
||||
qap=a+1.0d0
|
||||
qam=a-1.0d0
|
||||
c=1.0d0
|
||||
d=1.0d0-qab*x/qap
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
d=1.0d0/d
|
||||
h=d
|
||||
do 11 m=1,MAXIT
|
||||
m2=2*m
|
||||
aa=dble(m)*(b-dble(m))*x/((qam+dble(m2))*(a+dble(m2)))
|
||||
d=1.0d0+aa*d
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
c=1.0d0+aa/c
|
||||
if(dabs(c).lt.FPMIN)c=FPMIN
|
||||
d=1.0d0/d
|
||||
h=h*d*c
|
||||
aa=-(a+dble(m))*(qab+dble(m))*x/((a+dble(m2))*(qap+dble(m2)))
|
||||
d=1.0d0+aa*d
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
c=1.0d0+aa/c
|
||||
if(dabs(c).lt.FPMIN)c=FPMIN
|
||||
d=1.0d0/d
|
||||
del=d*c
|
||||
h=h*del
|
||||
if(dabs(del-1.0d0).lt.EPS)goto 1
|
||||
11 continue
|
||||
write(*,*) 'a or b too big, or MAXIT too small in betacf'
|
||||
1 betacf=h
|
||||
return␍
|
||||
end function betacf
|
||||
@@ -0,0 +1,61 @@
|
||||
!####################################################################
|
||||
|
||||
subroutine sumstatsoutliers(nsamp0,xvar0,std,fmean,xmin,xmax)
|
||||
implicit none
|
||||
integer nsamp,i,j,nsamp0,isoutlier_2sides
|
||||
double precision xvar(nsamp0),std,fmean,xmin,xmax,
|
||||
& xvar0(nsamp0),gap
|
||||
parameter(gap=-9999.0d0)
|
||||
|
||||
nsamp=0
|
||||
do j=1,nsamp0
|
||||
if(dabs(xvar0(j)-gap).gt.1.0d-5)then
|
||||
nsamp=nsamp+1
|
||||
xvar(nsamp)=xvar0(j)
|
||||
endif
|
||||
enddo
|
||||
std=gap
|
||||
fmean=gap
|
||||
xmin=gap
|
||||
xmax=gap
|
||||
if(nsamp.eq.0)return
|
||||
if(nsamp.eq.1)then
|
||||
fmean=xvar(1)
|
||||
return
|
||||
endif
|
||||
|
||||
10 i=isoutlier_2sides(nsamp,xvar)
|
||||
if(i.lt.0)goto 100
|
||||
do j=i,nsamp-1
|
||||
xvar(j)=xvar(j+1)
|
||||
enddo
|
||||
nsamp=nsamp-1
|
||||
goto 10
|
||||
|
||||
100 if(nsamp.lt.1)then
|
||||
std=gap
|
||||
fmean=gap
|
||||
xmin=gap
|
||||
xmax=gap
|
||||
return
|
||||
endif
|
||||
|
||||
fmean=0.0d0
|
||||
xmin=xvar(1)
|
||||
xmax=xvar(1)
|
||||
do j=1,nsamp
|
||||
fmean=fmean+xvar(j)
|
||||
if(xvar(j).gt.xmax)then
|
||||
xmax=xvar(j)
|
||||
endif
|
||||
if(xvar(j).lt.xmin)then
|
||||
xmin=xvar(j)
|
||||
endif
|
||||
enddo
|
||||
fmean=fmean/dble(nsamp)
|
||||
std=0.0d0
|
||||
do j=1,nsamp
|
||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
std=dsqrt(std/dble(nsamp-1))
|
||||
end
|
||||
@@ -0,0 +1,33 @@
|
||||
double precision function
|
||||
&sumthemup(n,time,starttime,endtime,xtosum)
|
||||
implicit none
|
||||
integer n,i,j
|
||||
double precision time(n),starttime,endtime,xtosum(n),agap,
|
||||
&fmean
|
||||
agap=-9999.0d0
|
||||
sumthemup=agap
|
||||
fmean=0.0d0
|
||||
j=0
|
||||
do i=1,n
|
||||
if(time(i).ge.starttime.and.time(i).lt.endtime)then
|
||||
if(dabs(xtosum(i)-agap).gt.1.0d-5)then
|
||||
j=j+1
|
||||
fmean=fmean+xtosum(i)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
if(j.eq.0)return
|
||||
fmean=fmean/dble(j)
|
||||
sumthemup=0.0d0
|
||||
do i=1,n
|
||||
if(time(i).ge.starttime.and.time(i).lt.endtime)then
|
||||
if(dabs(xtosum(i)-agap).gt.1.0d-5)then
|
||||
sumthemup=sumthemup+xtosum(i)
|
||||
else
|
||||
sumthemup=sumthemup+fmean
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
@@ -0,0 +1,798 @@
|
||||
subroutine sort_shell(n,a,iorder)
|
||||
!sort array a with the Shell method (from smallest to largest).
|
||||
!iorder records the original position of each member.
|
||||
implicit none
|
||||
integer n,iorder(n)
|
||||
double precision a(n)
|
||||
integer i,j,inc,k
|
||||
double precision v
|
||||
|
||||
do i=1,n
|
||||
iorder(i)=i
|
||||
enddo
|
||||
inc=1
|
||||
1 inc=3*inc+1
|
||||
if(inc.le.n)goto 1
|
||||
2 continue
|
||||
inc=inc/3
|
||||
do i=inc+1,n
|
||||
v=a(i)
|
||||
k=iorder(i)
|
||||
j=i
|
||||
3 if(a(j-inc).gt.v)then
|
||||
a(j)=a(j-inc)
|
||||
iorder(j)=iorder(j-inc)
|
||||
j=j-inc
|
||||
if(j.le.inc)goto 4
|
||||
goto 3
|
||||
endif
|
||||
4 a(j)=v
|
||||
iorder(j)=k
|
||||
enddo
|
||||
if(inc.gt.1)goto 2
|
||||
return
|
||||
end
|
||||
c
|
||||
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
c This subroutine solves the real root of a cubic equation. Solutions
|
||||
c are found from p184-185 W. Press et al 1992 Numerical Recipes in C
|
||||
c
|
||||
double precision function cubicroot(p,q,r)
|
||||
c
|
||||
implicit double precision(a-h,l,o-z)
|
||||
|
||||
c: x^3+p*x^2+q*x+r=0
|
||||
|
||||
capq=(p*p-3.0d0*q)/9.0d0
|
||||
capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
|
||||
if (capr*capr .lt. capq*capq*capq) then
|
||||
rtta=dacos(capr/(dsqrt(capq*capq*capq)))
|
||||
root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
|
||||
|
||||
root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
|
||||
& dsqrt(3.0d0))-p/3.0d0
|
||||
root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
|
||||
& dsqrt(3.0d0))-p/3.0d0
|
||||
else
|
||||
capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
|
||||
& capq*capq*capq))**(1.0d0/3.0d0)
|
||||
if (dabs(capa) .lt. 1.0d-6) then
|
||||
capb=0.0
|
||||
else
|
||||
capb=capq/capa
|
||||
end if
|
||||
root2 =(capa+capb)-p/3.0d0
|
||||
end if
|
||||
cubicroot=root2
|
||||
return
|
||||
end
|
||||
c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
subroutine quadraticroots(a,b,c,root1,root2)
|
||||
implicit none
|
||||
double precision a,b,c,root1,root2,b24ac,q
|
||||
|
||||
if(dabs(a).lt.1.0d-8)then
|
||||
if(dabs(b).lt.1.0d-8)then
|
||||
root1=-9999.0d0
|
||||
root2=-9999.0d0
|
||||
return
|
||||
endif
|
||||
root1=-c/b
|
||||
root2=-9999.0d0
|
||||
return
|
||||
endif
|
||||
b24ac=b*b-4.0d0*a*c
|
||||
if(b24ac.lt.0.0d0)then
|
||||
root1=-9999.0d0
|
||||
root2=-9999.0d0
|
||||
return
|
||||
endif
|
||||
! q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac))
|
||||
! root1=q/a
|
||||
! root2=c/q
|
||||
root1=(-b-dsqrt(b24ac))/(2.0d0*a)
|
||||
root2=(-b+dsqrt(b24ac))/(2.0d0*a)
|
||||
return
|
||||
end
|
||||
|
||||
subroutine quadraticrootsbound(a,b,c,
|
||||
& lower,upper,root,otherroot,iwrong)
|
||||
implicit none
|
||||
double precision a,b,c,lower,upper,root,
|
||||
& otherroot
|
||||
|
||||
integer iwrong
|
||||
!iwrong=0, root is within (lower,upper) and otherroot is not
|
||||
!iwrong=1, both root and otherroot are within (lower,upper)
|
||||
!iwrong=2, both root and otherroot are real but outside of (lower, upper)
|
||||
!iwrong=3, the equation bx+c=0 type, one root only
|
||||
!iwrong=4, no real roots
|
||||
!iwrong=5, invalid equation
|
||||
|
||||
double precision b24ac,q
|
||||
|
||||
if(a.eq.0.0d0)then
|
||||
if(b.eq.0.0d0)then
|
||||
root=-9999.0d0
|
||||
otherroot=-9999.0d0
|
||||
iwrong=5
|
||||
return
|
||||
endif
|
||||
root=-c/b
|
||||
otherroot=-9999.0d0
|
||||
iwrong=3
|
||||
return
|
||||
endif
|
||||
|
||||
b24ac=b*b-4.0d0*a*c
|
||||
if(b24ac.lt.0.0d0)then
|
||||
root=-9999.0d0
|
||||
otherroot=-9999.0d0
|
||||
iwrong=4
|
||||
return
|
||||
endif
|
||||
q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac))
|
||||
root=c/q
|
||||
otherroot=q/a
|
||||
|
||||
if(root.ge.lower.and.root.le.upper)then
|
||||
if(otherroot.ge.lower.and.otherroot.le.upper)then
|
||||
iwrong=1
|
||||
else
|
||||
iwrong=0
|
||||
endif
|
||||
else
|
||||
if(otherroot.ge.lower.and.otherroot.le.upper)then
|
||||
b24ac=root
|
||||
root=otherroot
|
||||
otherroot=b24ac
|
||||
iwrong=0
|
||||
else
|
||||
iwrong=2
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
c
|
||||
c####################################################################
|
||||
c random number generator
|
||||
c
|
||||
double precision function ran2()
|
||||
implicit none
|
||||
integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
|
||||
double precision am,eps,rnmx
|
||||
! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
|
||||
! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
|
||||
! &rnmx=1.0d0-eps)
|
||||
|
||||
parameter(im1=2147483563,im2=2147483399,
|
||||
&imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
&12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)
|
||||
parameter(am=1.0d0/dble(im1),eps=1.2d-7,
|
||||
&rnmx=1.0d0-eps)
|
||||
|
||||
integer idum2,j,k,iv(ntab),iy,idum
|
||||
save iv,iy,idum2,idum
|
||||
data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
|
||||
|
||||
if(idum.le.0) then
|
||||
idum=max0(-idum,1)
|
||||
idum2=idum
|
||||
do 11 j=ntab+8,1,-1
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0)idum=idum+im1
|
||||
if(j.le.ntab)iv(j)=idum
|
||||
11 continue
|
||||
iy=iv(1)
|
||||
end if
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0)idum=idum+im1
|
||||
k=idum2/iq2
|
||||
idum2=ia2*(idum2-k*iq2)-k*ir2
|
||||
if(idum2.lt.0) idum2=idum2+im2
|
||||
j=1+iy/ndiv
|
||||
iy=iv(j)-idum2
|
||||
iv(j)=idum
|
||||
if(iy.lt.1)iy=iy+imm1
|
||||
ran2=dmin1(am*dble(iy),rnmx)
|
||||
return
|
||||
end
|
||||
c
|
||||
c####################################################################
|
||||
double precision function beta(beta1,beta2)
|
||||
c Returns the value of the Beta function B(u,v)
|
||||
c
|
||||
implicit double precision(a-h,l,o-z)
|
||||
beta=dexp(gammln(beta1)+gammln(beta2)-gammln(beta1+beta2))
|
||||
return
|
||||
end
|
||||
c
|
||||
! Logarithm of gamma function.
|
||||
! Used by routine betai.
|
||||
! Numerical Recipes, chapter 6.1.
|
||||
double precision function gammln(xx)
|
||||
implicit none
|
||||
double precision xx
|
||||
integer j
|
||||
double precision cof(6)
|
||||
double precision ser,stp,tmp,x,y␍
|
||||
save cof,stp
|
||||
data cof,stp/76.18009172947146d0,-86.50532032941677d0,
|
||||
&24.01409824083091d0,-1.231739572450155d0,0.1208650973866179d-2,
|
||||
&-0.5395239384953d-5,2.5066282746310005d0/
|
||||
|
||||
x=xx
|
||||
y=x
|
||||
tmp=x+5.5d0
|
||||
tmp=(x+0.5d0)*dlog(tmp)-tmp
|
||||
ser=1.000000000190015d0
|
||||
do 11 j=1,6
|
||||
y=y+1.0d0
|
||||
ser=ser+cof(j)/y
|
||||
11 continue
|
||||
gammln=tmp+dlog(stp*ser/x)
|
||||
return
|
||||
end
|
||||
c##################################################################
|
||||
c
|
||||
c This subroutine quadrat performs the transformation of 8 point
|
||||
c Gaussian Quadrature in the interval (-1, 1) to any interval (x0,
|
||||
c x1).
|
||||
c
|
||||
subroutine quadrat(x0, x1, abscis, weight, timeby)
|
||||
implicit double precision(a-h,l,o-z)
|
||||
dimension abscis(8), root(8), weight(8), weit(8)
|
||||
|
||||
c
|
||||
save root,weit
|
||||
data(root(i),i=1,4)/0.18343464d0,0.52553241d0,0.79666648d0,
|
||||
& 0.96028986d0/
|
||||
data(root(i),i=5,8)/-0.18343464d0,-0.52553241d0,-0.79666648d0,
|
||||
& -0.96028986d0/
|
||||
data(weit(i),i=1,4)/0.36268378d0,0.31370665d0,0.22238103d0,
|
||||
& 0.10122854d0/
|
||||
data(weit(i),i=5,8)/0.36268378d0,0.31370665d0,0.22238103d0,
|
||||
& 0.10122854d0/
|
||||
|
||||
do 10 i = 1, 8
|
||||
abscis(i) = ((x1-x0)*root(i)+x1+x0)/2.0d0
|
||||
weight(i) = weit(i)
|
||||
10 continue
|
||||
timeby = (x1-x0)/2.0d0
|
||||
return
|
||||
end
|
||||
c####################################################################
|
||||
c random number generator
|
||||
c
|
||||
double precision function ran2_reset()
|
||||
implicit none
|
||||
integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
|
||||
double precision am,eps,rnmx
|
||||
! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
|
||||
! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
|
||||
! &rnmx=1.0d0-eps)
|
||||
|
||||
parameter(im1=2147483563,im2=2147483399,
|
||||
&imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
&12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)
|
||||
|
||||
parameter(am=1.0d0/dble(im1),eps=1.2d-7,
|
||||
&rnmx=1.0d0-eps)
|
||||
|
||||
|
||||
logical resetran2
|
||||
common /ran2reset/resetran2
|
||||
save /ran2reset/
|
||||
|
||||
integer idum2,j,k,iv(ntab),iy,idum
|
||||
save iv,iy,idum2,idum
|
||||
data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
|
||||
|
||||
if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then
|
||||
idum2=123456789
|
||||
do j=1,ntab
|
||||
iv(j)=0
|
||||
enddo
|
||||
iy=0
|
||||
idum=-1
|
||||
endif
|
||||
resetran2=.false.
|
||||
|
||||
if(idum.le.0) then
|
||||
idum=max0(-idum,1)
|
||||
idum2=idum
|
||||
do 11 j=ntab+8,1,-1
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0) idum=idum+im1
|
||||
if(j.le.ntab) iv(j)=idum
|
||||
11 continue
|
||||
iy=iv(1)
|
||||
end if
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0)idum=idum+im1
|
||||
k=idum2/iq2
|
||||
idum2=ia2*(idum2-k*iq2)-k*ir2
|
||||
if(idum2.lt.0) idum2=idum2+im2
|
||||
j=1+iy/ndiv
|
||||
iy=iv(j)-idum2
|
||||
iv(j)=idum
|
||||
if(iy.lt.1)iy=iy+imm1
|
||||
ran2_reset=dmin1(am*dble(iy),rnmx)
|
||||
return
|
||||
end
|
||||
c
|
||||
c####################################################################
|
||||
c random number generator
|
||||
c
|
||||
double precision function cpran2_reset()
|
||||
implicit none
|
||||
integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv
|
||||
double precision am,eps,rnmx
|
||||
! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1),
|
||||
! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7,
|
||||
! &rnmx=1.0d0-eps)
|
||||
|
||||
parameter(im1=2147483563,im2=2147483399,
|
||||
&imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1=
|
||||
&12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab)
|
||||
|
||||
parameter(am=1.0d0/dble(im1),eps=1.2d-7,
|
||||
&rnmx=1.0d0-eps)
|
||||
|
||||
logical resetran2
|
||||
common /cpran2reset/resetran2
|
||||
save /cpran2reset/
|
||||
|
||||
integer idum2,j,k,iv(ntab),iy,idum
|
||||
save iv,iy,idum2,idum
|
||||
data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/
|
||||
|
||||
if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then
|
||||
idum2=123456789
|
||||
do j=1,ntab
|
||||
iv(j)=0
|
||||
enddo
|
||||
iy=0
|
||||
idum=-1
|
||||
endif
|
||||
resetran2=.false.
|
||||
|
||||
if(idum.le.0) then
|
||||
idum=max0(-idum,1)
|
||||
idum2=idum
|
||||
do 11 j=ntab+8,1,-1
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0) idum=idum+im1
|
||||
if(j.le.ntab) iv(j)=idum
|
||||
11 continue
|
||||
iy=iv(1)
|
||||
end if
|
||||
k=idum/iq1
|
||||
idum=ia1*(idum-k*iq1)-k*ir1
|
||||
if(idum.lt.0)idum=idum+im1
|
||||
k=idum2/iq2
|
||||
idum2=ia2*(idum2-k*iq2)-k*ir2
|
||||
if(idum2.lt.0) idum2=idum2+im2
|
||||
j=1+iy/ndiv
|
||||
iy=iv(j)-idum2
|
||||
iv(j)=idum
|
||||
if(iy.lt.1)iy=iy+imm1
|
||||
cpran2_reset=dmin1(am*dble(iy),rnmx)
|
||||
return
|
||||
end
|
||||
c####################################################################
|
||||
c This subroutine calculates R2 and root mean square error and index of
|
||||
cagreement
|
||||
subroutine rsq_rms(y10,y20,n0,rsq,rms,agrind)
|
||||
implicit double precision (a-h,l,o-z)
|
||||
dimension y10(n0),y20(n0),y1(n0),y2(n0)
|
||||
fn9999=-9999.0d0
|
||||
tiny=1.0d-7
|
||||
n=0
|
||||
do i=1,n0
|
||||
if(dabs(y10(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y20(i)-fn9999).gt.tiny)then
|
||||
n=n+1
|
||||
y1(n)=y10(i)
|
||||
y2(n)=y20(i)
|
||||
endif
|
||||
enddo
|
||||
sum=0.0d0
|
||||
do 10 i=1,n
|
||||
sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i))
|
||||
10 continue
|
||||
rms=dsqrt(sum/dble(n))
|
||||
ymean1=0.0d0
|
||||
ymean2=0.0d0
|
||||
do 20 i=1,n
|
||||
ymean1=ymean1+y1(i)
|
||||
ymean2=ymean2+y2(i)
|
||||
20 continue
|
||||
ymean1=ymean1/dble(n)
|
||||
ymean2=ymean2/dble(n)
|
||||
sum1=0.0d0
|
||||
sum2=0.0d0
|
||||
sum3=0.0d0
|
||||
sum4=0.0d0
|
||||
sum5=0.0d0
|
||||
do 30 i=1,n
|
||||
sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1
|
||||
sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2
|
||||
sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3
|
||||
sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4
|
||||
sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))*
|
||||
&(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5
|
||||
30 continue
|
||||
if((sum2*sum3).eq.0.0d0)then
|
||||
rsq=-9999.0d0
|
||||
else
|
||||
rsq=sum1/dsqrt(sum2*sum3)
|
||||
rsq=rsq*rsq
|
||||
endif
|
||||
if(sum5.eq.0.0d0)then
|
||||
agrind=-9999.0d0
|
||||
else
|
||||
agrind=1.0d0-sum4/sum5
|
||||
endif
|
||||
return
|
||||
end
|
||||
c####################################################################
|
||||
subroutine extrsq_rms(y10,y20,n0,nparams,rsq,rms,agrind,
|
||||
&rmse_norm,rmse_perc,aic,aicc)
|
||||
implicit double precision (a-h,l,o-z)
|
||||
dimension y10(n0),y20(n0),y1(n0),y2(n0)
|
||||
fn9999=-9999.0d0
|
||||
tiny=1.0d-7
|
||||
n=0
|
||||
do i=1,n0
|
||||
if(dabs(y10(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y20(i)-fn9999).gt.tiny)then
|
||||
n=n+1
|
||||
y1(n)=y10(i)
|
||||
y2(n)=y20(i)
|
||||
endif
|
||||
enddo
|
||||
ymin=y1(1)
|
||||
ymax=y1(1)
|
||||
do i=2,n
|
||||
if(y1(i).lt.ymin)ymin=y1(i)
|
||||
if(y1(i).gt.ymax)ymax=y1(i)
|
||||
enddo
|
||||
sum=0.0d0
|
||||
rmse_perc=0.0d0
|
||||
do 10 i=1,n
|
||||
sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i))
|
||||
rmse_perc=rmse_perc+(y1(i)-y2(i))*(y1(i)-y2(i))/(y2(i)*y2(i))
|
||||
10 continue
|
||||
rms=dsqrt(sum/dble(n))
|
||||
if(nparams.gt.0)then
|
||||
aic=dble(n)*dlog(rms*rms)+2.0d0*dble(nparams)
|
||||
aicc=aic+2.0d0*dble(nparams*(nparams+1))/dble(n-nparams-1)
|
||||
else
|
||||
aic=-9999.0d0
|
||||
aicc=-9999.0d0
|
||||
endif
|
||||
rmse_norm=rms/(ymax-ymin)
|
||||
rmse_perc=100.0d0*dsqrt(rmse_perc/dble(n))
|
||||
ymean1=0.0d0
|
||||
ymean2=0.0d0
|
||||
do 20 i=1,n
|
||||
ymean1=ymean1+y1(i)
|
||||
ymean2=ymean2+y2(i)
|
||||
20 continue
|
||||
ymean1=ymean1/dble(n)
|
||||
ymean2=ymean2/dble(n)
|
||||
sum1=0.0d0
|
||||
sum2=0.0d0
|
||||
sum3=0.0d0
|
||||
sum4=0.0d0
|
||||
sum5=0.0d0
|
||||
do 30 i=1,n
|
||||
sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1
|
||||
sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2
|
||||
sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3
|
||||
sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4
|
||||
sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))*
|
||||
&(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5
|
||||
30 continue
|
||||
if((sum2*sum3).eq.0.0d0)then
|
||||
rsq=-9999.0d0
|
||||
else
|
||||
rsq=sum1/dsqrt(sum2*sum3)
|
||||
rsq=rsq*rsq
|
||||
endif
|
||||
if(sum5.eq.0.0d0)then
|
||||
agrind=-9999.0d0
|
||||
else
|
||||
agrind=1.0d0-sum4/sum5
|
||||
endif
|
||||
return
|
||||
end
|
||||
!####################################################################
|
||||
subroutine stdmean(nsamp,xvar,std,fmean)
|
||||
implicit none
|
||||
integer nsamp,j
|
||||
double precision xvar(nsamp),std,fmean
|
||||
fmean=0.0d0
|
||||
do j=1,nsamp
|
||||
fmean=fmean+xvar(j)
|
||||
enddo
|
||||
fmean=fmean/dble(nsamp)
|
||||
std=0.0d0
|
||||
do j=1,nsamp
|
||||
std=std+(xvar(j)-fmean)*(xvar(j)-fmean)
|
||||
enddo
|
||||
std=dsqrt(std/dble(nsamp-1))
|
||||
end
|
||||
c#######################################################################
|
||||
subroutine reinitialization(x0min,x0likely,
|
||||
& x0max,x0new,minterval)
|
||||
implicit none
|
||||
double precision x0min,x0likely,x0max,x0new,zrand,
|
||||
& delta1,delta2,ran2_reset
|
||||
integer minterval,iwhichone
|
||||
save
|
||||
intrinsic dble,dabs
|
||||
if(x0likely.le.x0min.or.x0likely.ge.x0max)then
|
||||
x0new=(x0min+x0max)/2.0d0+
|
||||
& (x0max-x0min)*(ran2_reset()-0.5d0)
|
||||
else
|
||||
delta1=(x0likely-x0min)/dble(minterval)
|
||||
delta2=(x0max-x0likely)/dble(minterval)
|
||||
zrand=ran2_reset()
|
||||
iwhichone=idint(dble(2*minterval)*zrand)+1
|
||||
if(iwhichone.gt.(2*minterval))iwhichone=minterval+1
|
||||
zrand=ran2_reset()
|
||||
if(iwhichone.le.minterval)then
|
||||
x0new=x0likely-(x0likely-x0min
|
||||
& -delta1*dble(iwhichone-1))*zrand
|
||||
else
|
||||
x0new=x0likely+
|
||||
& zrand*delta2*dble(iwhichone-minterval)
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
c#######################################################################
|
||||
|
||||
double precision function whatismedian(n,x)
|
||||
implicit none
|
||||
integer n,i,j
|
||||
double precision x(n),copyx(n),term
|
||||
|
||||
do i=1,n
|
||||
copyx(i)=x(i)
|
||||
enddo
|
||||
do i=1,n
|
||||
do j=i+1,n
|
||||
if(copyx(j).lt.copyx(i))then
|
||||
term=copyx(i)
|
||||
copyx(i)=copyx(j)
|
||||
copyx(j)=term
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
if(mod(n,2).eq.0)then
|
||||
whatismedian=(copyx(n/2)+copyx(n/2+1))/2.0d0
|
||||
else
|
||||
whatismedian=copyx((n-1)/2+1)
|
||||
endif
|
||||
return
|
||||
end
|
||||
!------------------------------------------------
|
||||
subroutine y_aPLUSbxrsq(npoints,x,y,a,b,rsq)
|
||||
implicit none
|
||||
!fit for y=a+bx
|
||||
integer npoints
|
||||
double precision x(npoints),y(npoints),a,b,rsq,rms,agrind
|
||||
integer i
|
||||
double precision fn9999,tiny,ycal(npoints)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
|
||||
call y_aPLUSbx(npoints,x,y,a,b)
|
||||
do i=1,npoints
|
||||
ycal(i)=fn9999
|
||||
if(dabs(x(i)-fn9999).gt.tiny)ycal(i)=a+b*x(i)
|
||||
enddo
|
||||
call rsq_rms(y,ycal,npoints,rsq,rms,agrind)
|
||||
return
|
||||
end
|
||||
!------------------------------------------------
|
||||
subroutine y_aPLUSbx(npoints0,x0,y0,a,b)
|
||||
implicit none
|
||||
!fit for y=a+bx
|
||||
integer npoints0
|
||||
double precision x0(npoints0),y0(npoints0),a,b
|
||||
integer i,npoints
|
||||
double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny,
|
||||
&x(npoints0),y(npoints0)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
|
||||
npoints=0
|
||||
do i=1,npoints0
|
||||
if(dabs(x0(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y0(i)-fn9999).gt.tiny)then
|
||||
npoints=npoints+1
|
||||
x(npoints)=x0(i)
|
||||
y(npoints)=y0(i)
|
||||
endif
|
||||
enddo
|
||||
xmean=0.0d0
|
||||
ymean=0.0d0
|
||||
do i=1,npoints
|
||||
xmean=xmean+x(i)
|
||||
ymean=ymean+y(i)
|
||||
enddo
|
||||
xmean=xmean/dble(npoints)
|
||||
ymean=ymean/dble(npoints)
|
||||
lxx=0.0d0
|
||||
lyy=0.0d0
|
||||
lxy=0.0d0
|
||||
do i=1,npoints
|
||||
lxx=lxx+(x(i)-xmean)**2
|
||||
lyy=lyy+(y(i)-ymean)**2
|
||||
lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
|
||||
enddo
|
||||
if(lxx.ne.0.0d0)then
|
||||
b=lxy/lxx
|
||||
a=ymean-b*xmean
|
||||
else
|
||||
b=-9999.0d0
|
||||
a=-9999.0d0
|
||||
endif
|
||||
return
|
||||
end
|
||||
!----------------------------------------------
|
||||
subroutine y_bx(npoints0,x0,y0,b)
|
||||
implicit none
|
||||
!fit for y=bx
|
||||
integer npoints0
|
||||
double precision x0(npoints0),y0(npoints0),b
|
||||
integer i,npoints
|
||||
double precision lxx,lxy,fn9999,tiny,
|
||||
&x(npoints0),y(npoints0)
|
||||
parameter(fn9999=-9999.0d0,tiny=1.0d-7)
|
||||
|
||||
npoints=0
|
||||
do i=1,npoints0
|
||||
if(dabs(x0(i)-fn9999).gt.tiny.and.
|
||||
&dabs(y0(i)-fn9999).gt.tiny)then
|
||||
npoints=npoints+1
|
||||
x(npoints)=x0(i)
|
||||
y(npoints)=y0(i)
|
||||
endif
|
||||
enddo
|
||||
lxx=0.0d0
|
||||
lxy=0.0d0
|
||||
do i=1,npoints
|
||||
lxx=lxx+x(i)*x(i)
|
||||
lxy=lxy+x(i)*y(i)
|
||||
enddo
|
||||
b=lxy/lxx
|
||||
return
|
||||
end
|
||||
!======================================================
|
||||
subroutine linearsys_dim2(a,b,c,d,e,f,x,y)
|
||||
implicit none
|
||||
!solve for x and y in
|
||||
! ax+by=c
|
||||
! dx+ey=f
|
||||
!avoiding overflow
|
||||
double precision a,b,c,d,e,f,x,y
|
||||
if(dabs(a).gt.dabs(b).and.dabs(a).gt.dabs(d)
|
||||
& .and.dabs(a).gt.dabs(e))then
|
||||
y=(f-c*d/a)/(e-b*d/a)
|
||||
x=c/a-b*y/a
|
||||
else
|
||||
if(dabs(b).gt.dabs(a).and.dabs(b).gt.dabs(d)
|
||||
& .and.dabs(b).gt.dabs(e))then
|
||||
x=(f-c*e/b)/(d-a*e/b)
|
||||
y=c/b-a*x/b
|
||||
else
|
||||
if(dabs(d).gt.dabs(a).and.dabs(d).gt.dabs(b)
|
||||
& .and.dabs(d).gt.dabs(e))then
|
||||
y=(c-a*f/d)/(b-a*e/d)
|
||||
x=f/d-e*y/d
|
||||
else
|
||||
x=(c-b*f/e)/(a-b*d/e)
|
||||
y=f/e-d*x/e
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
return
|
||||
end
|
||||
!===========================================================
|
||||
double precision function crosscorrel(nsamp,var1,var2,
|
||||
& istart,iend,ndelay)
|
||||
implicit none
|
||||
integer nsamp,istart,iend,ndelay,i,j
|
||||
double precision var1(1:nsamp),var2(istart:iend),var1mean,
|
||||
& var2mean,sxy,sxx,syy
|
||||
var1mean=0.0d0
|
||||
var2mean=0.0d0
|
||||
j=0
|
||||
do i=1,nsamp
|
||||
if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then
|
||||
j=j+1
|
||||
var1mean=var1mean+var1(i)
|
||||
var2mean=var2mean+var2(i-ndelay)
|
||||
endif
|
||||
enddo
|
||||
var1mean=var1mean/dble(j)
|
||||
var2mean=var2mean/dble(j)
|
||||
sxy=0.0d0
|
||||
sxx=0.0d0
|
||||
syy=0.0d0
|
||||
do i=1,nsamp
|
||||
if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then
|
||||
sxy=sxy+(var1(i)-var1mean)*(var2(i-ndelay)-var2mean)
|
||||
sxx=sxx+(var1(i)-var1mean)*(var1(i)-var1mean)
|
||||
syy=syy+(var2(i-ndelay)-var2mean)*(var2(i-ndelay)-var2mean)
|
||||
endif
|
||||
enddo
|
||||
crosscorrel=sxy/dsqrt(sxx*syy)
|
||||
return
|
||||
end
|
||||
!===========================================================
|
||||
double precision function cumutailsum(n,time,starttime,endtime,
|
||||
&xtosum,threshold,iaboveorbelow)
|
||||
implicit none
|
||||
integer n,i,j,iaboveorbelow,iabove,ibelow
|
||||
double precision time(n),starttime,endtime,xtosum(n),agap,
|
||||
&threshold(n)
|
||||
parameter(iabove=1,ibelow=-1)
|
||||
agap=-9999.0d0
|
||||
cumutailsum=0.0d0
|
||||
do i=1,n
|
||||
if(time(i).ge.starttime.and.time(i).lt.endtime)then
|
||||
if(dabs(xtosum(i)-agap).gt.1.0d-5)then
|
||||
if(iaboveorbelow.eq.iabove)then
|
||||
if(xtosum(i).ge.threshold(i))
|
||||
&cumutailsum=cumutailsum+xtosum(i)
|
||||
endif
|
||||
if(iaboveorbelow.eq.ibelow)then
|
||||
if(xtosum(i).le.threshold(i))
|
||||
&cumutailsum=cumutailsum+xtosum(i)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
!----------------------------------------------------------------
|
||||
double precision function ran1(idum)
|
||||
INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
|
||||
double precision AM,EPS,RNMX
|
||||
PARAMETER (IA=16807,IM=2147483647,AM=1.d0/dble(IM),
|
||||
&IQ=127773,IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-7,
|
||||
&RNMX=1.0d0-EPS)
|
||||
INTEGER j,k,iv(NTAB),iy
|
||||
SAVE iv,iy
|
||||
DATA iv /NTAB*0/, iy /0/
|
||||
if (idum.le.0.or.iy.eq.0) then
|
||||
idum=max(-idum,1)
|
||||
do 11 j=NTAB+8,1,-1
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if (idum.lt.0) idum=idum+IM
|
||||
if (j.le.NTAB) iv(j)=idum
|
||||
11 continue
|
||||
iy=iv(1)
|
||||
endif
|
||||
k=idum/IQ
|
||||
idum=IA*(idum-k*IQ)-IR*k
|
||||
if (idum.lt.0) idum=idum+IM
|
||||
j=1+iy/NDIV
|
||||
iy=iv(j)
|
||||
iv(j)=idum
|
||||
ran1=dmin1(AM*dble(iy),RNMX)
|
||||
return
|
||||
END
|
||||
@@ -0,0 +1,71 @@
|
||||
subroutine targetgridsampling(sampfunc,nparams0,
|
||||
& msect0,bestguess,yatguess,bmax0,bmin0,iflag)
|
||||
implicit none
|
||||
!
|
||||
!iflag(i)=0, fix bestguess(i) at the input value
|
||||
!iflag(i)=1, bestguess(i) is not provided an input value. use grid search
|
||||
integer nparams0,msect0,iflag(nparams0)
|
||||
double precision bestguess(nparams0),
|
||||
& bmax0(nparams0),bmin0(nparams0),
|
||||
& params(nparams0,msect0+1),yatguess,
|
||||
& beta(nparams0),fatbeta,bmax(nparams0),bmin(nparams0)
|
||||
integer i,j,k,n,msect,m,nparams,itag(nparams0)
|
||||
double precision tiny,x1,delta,eps
|
||||
parameter(eps=1.0d-8)
|
||||
external sampfunc
|
||||
!
|
||||
nparams=0
|
||||
do i=1,nparams0
|
||||
if(iflag(i).eq.1)then
|
||||
nparams=nparams+1
|
||||
bmax(nparams)=bmax0(i)
|
||||
bmin(nparams)=bmin0(i)
|
||||
itag(nparams)=i
|
||||
endif
|
||||
enddo
|
||||
msect=msect0
|
||||
do i=1,nparams
|
||||
tiny=(bmax(i)-bmin(i))*eps
|
||||
x1=(bmax(i)-bmin(i)-2.0d0*tiny)/dble(msect)
|
||||
params(i,1)=bmin(i)+tiny
|
||||
do j=2,msect+1
|
||||
params(i,j)=params(i,j-1)+x1
|
||||
params(i,j)=dmax1(params(i,j),bmin(i))
|
||||
params(i,j)=dmin1(params(i,j),bmax(i))
|
||||
enddo
|
||||
enddo
|
||||
msect=msect+1
|
||||
yatguess=1.0d+100
|
||||
do i=1,msect**nparams
|
||||
do j=1,nparams
|
||||
!the size of the larger repeated unit is msect**(nparams-j+1)
|
||||
k=i/(msect**(nparams-j+1))
|
||||
n=mod(i,(msect**(nparams-j+1)))
|
||||
if(n.eq.0)k=k-1
|
||||
!k is the number of repeated units before i (not include the unit i is in)
|
||||
k=i-k*(msect**(nparams-j+1))
|
||||
!now k is the position in the larger repeated unit
|
||||
!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect
|
||||
m=(msect**(nparams-j+1))/msect
|
||||
n=k/m
|
||||
if(mod(k,m).ne.0)n=n+1
|
||||
beta(j)=params(j,n)
|
||||
enddo
|
||||
do j=nparams,1,-1
|
||||
beta(itag(j))=beta(j)
|
||||
enddo
|
||||
do j=1,nparams0
|
||||
if(iflag(j).eq.0)then
|
||||
beta(j)=bestguess(j)
|
||||
endif
|
||||
enddo
|
||||
call sampfunc(nparams0,beta,fatbeta)
|
||||
if(fatbeta.lt.yatguess)then
|
||||
yatguess=fatbeta
|
||||
do j=1,nparams0
|
||||
bestguess(j)=beta(j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,248 @@
|
||||
subroutine test_t(nsamp1,samp1,nsamp2,samp2,alpha,
|
||||
&ntail,fmean1,std1,fmean2,std2,isitdifferent)
|
||||
implicit none
|
||||
!----------------Inputs--------------------------
|
||||
!nsamp: the number of samples
|
||||
!samp: the sample values
|
||||
!alpha: the significance level to consider (e.g. 0.05. 0.01)
|
||||
!ntail: ntail = 1, one tail (one mean is significantly larger (smaller) than the other mean
|
||||
! ntail = 2, two tails (the two means are significantly different from each other)
|
||||
!----------------Outputs---------------------------
|
||||
!fmean and std: sample means and standard deviations
|
||||
!isitdifferent=0, not different
|
||||
! =1, different
|
||||
integer nsamp1,nsamp2,ntail,isitdifferent,ndegfree
|
||||
double precision samp1(nsamp1),samp2(nsamp2),alpha,
|
||||
&fmean1,std1,fmean2,std2,Sign_Level,student_t,t,t0,s0
|
||||
|
||||
call stdmean(nsamp1,samp1,std1,fmean1)
|
||||
call stdmean(nsamp2,samp2,std2,fmean2)
|
||||
ndegfree=nsamp1+nsamp2-2
|
||||
s0=dble((nsamp1-1))*std1*std1+
|
||||
&dble((nsamp2-1))*std2*std2
|
||||
s0=dsqrt(s0/dble(ndegfree))
|
||||
t=(fmean1-fmean2)/
|
||||
&(s0*dsqrt(1.0d0/dble(nsamp1)+1.0d0/dble(nsamp2)))
|
||||
if(ntail.eq.1)then
|
||||
Sign_Level=1.0d0-alpha*2.0d0
|
||||
else
|
||||
Sign_Level=1.0d0-alpha/2.0d0
|
||||
endif
|
||||
t0=student_t(ndegfree,Sign_Level)
|
||||
isitdifferent=0
|
||||
if(dabs(t).gt.t0)isitdifferent=1
|
||||
return
|
||||
end
|
||||
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|
||||
double precision function student_t(ndegfree,Sign_Level)
|
||||
!
|
||||
! the integration from -student_t to student_t =Sign_Level
|
||||
!
|
||||
! The student-t is calculated for a given degree of freedom
|
||||
! and at a certain significance level.
|
||||
! The following relation holds:
|
||||
! Sign_Level = 1 - IncompleteBetaFunction( x, a, b )
|
||||
! x = Df / ( Df + student_t^2 )
|
||||
! a = Df / 2
|
||||
! b = 0.50
|
||||
! We need to solve the above equation for x (or student_t).
|
||||
! Routines from Numerical Recipes are used for that.
|
||||
|
||||
implicit none
|
||||
! Input variables.
|
||||
integer ndegfree
|
||||
! Degree of freedom
|
||||
double precision Sign_Level
|
||||
! Significance level
|
||||
|
||||
! Functions and parameters.
|
||||
double precision zbrent,tobesolved
|
||||
double precision x1,x2,b,eps
|
||||
parameter(x1=0.0d0,x2=1.0d0,b=0.50d0,eps=1.0d-7)
|
||||
|
||||
! Various parameters: x1, x2 bracket the root, given with
|
||||
! accuracy eps.
|
||||
|
||||
! Local
|
||||
double precision Df,a
|
||||
! Degrees of freedom␍
|
||||
! a = 0.50 * Df
|
||||
|
||||
external zbrent,tobesolved
|
||||
|
||||
Df = dble(ndegfree)
|
||||
a = 0.50d0 * Df
|
||||
student_t=zbrent(tobesolved,a,b,Sign_Level,x1,x2,eps)
|
||||
student_t = dsqrt( Df/student_t - Df)
|
||||
end function student_t
|
||||
|
||||
␍ double precision function tobesolved( a, b, c, x )
|
||||
␍ implicit none
|
||||
double precision a, b, c, x
|
||||
! a, b, c: parameters to the function
|
||||
! x: variable
|
||||
double precision betai
|
||||
external betai
|
||||
! Incomplete beta function.
|
||||
tobesolved = betai(a,b,x) - 1.0d0 + c
|
||||
end function tobesolved
|
||||
|
||||
! The rest of this file comes from Numerical Recipes.
|
||||
! Function zbrent has been modified slightly
|
||||
! (variables aaa, bbb, ccc have been intoduced).
|
||||
|
||||
! Brent's method for solving the equation
|
||||
! func(a,b,c,x)=0 for x, where a,b,c parameters.
|
||||
! Root is bracketed by x1 and x2.
|
||||
! Root is returned to varable zbrent with
|
||||
! accuracy tol.
|
||||
|
||||
double precision function zbrent(func,aaa,bbb,ccc,x1,x2,tol)
|
||||
implicit none
|
||||
integer ITMAX,iter
|
||||
double precision tol,x1,x2,func,EPS,
|
||||
& a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm,
|
||||
& aaa,bbb,ccc
|
||||
parameter(ITMAX=5000)
|
||||
parameter(EPS=3.0d-8)
|
||||
external func
|
||||
|
||||
a=x1
|
||||
b=x2
|
||||
|
||||
fa=func(aaa,bbb,ccc,a)
|
||||
fb=func(aaa,bbb,ccc,b)
|
||||
if((fa.gt.0.0d0.and.fb.gt.0.0d0).or.
|
||||
& (fa.lt.0.0d0.and.fb.lt.0.0d0))then
|
||||
write(*,*) 'root must be bracketed for zbrent'
|
||||
endif
|
||||
c=b
|
||||
fc=fb
|
||||
do 11 iter=1,ITMAX
|
||||
if((fb.gt.0.0d0.and.fc.gt.0.0d0).or.
|
||||
& (fb.lt.0.0d0.and.fc.lt.0.0d0))then
|
||||
c=a
|
||||
fc=fa
|
||||
d=b-a
|
||||
e=d
|
||||
endif
|
||||
if(dabs(fc).lt.dabs(fb)) then
|
||||
a=b
|
||||
b=c
|
||||
c=a
|
||||
fa=fb
|
||||
fb=fc
|
||||
fc=fa
|
||||
endif
|
||||
tol1=2.0d0*EPS*dabs(b)+0.5d0*tol
|
||||
xm=0.5d0*(c-b)
|
||||
if(dabs(xm).le.tol1.or.fb.eq.0.0d0)then
|
||||
zbrent=b
|
||||
return
|
||||
endif
|
||||
if(dabs(e).ge.tol1.and.dabs(fa).gt.dabs(fb))then
|
||||
s=fb/fa
|
||||
if(a.eq.c) then
|
||||
p=2.0d0*xm*s
|
||||
q=1.0d0-s
|
||||
else
|
||||
q=fa/fc
|
||||
r=fb/fc
|
||||
p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0))
|
||||
q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0)
|
||||
endif
|
||||
if(p.gt.0.0d0)q=-q
|
||||
p=dabs(p)
|
||||
if(2.0d0*p.lt.dmin1(3.0d0*xm*q-dabs(tol1*q),dabs(e*q)))then
|
||||
e=d
|
||||
d=p/q
|
||||
else
|
||||
d=xm
|
||||
e=d
|
||||
endif
|
||||
else
|
||||
d=xm
|
||||
e=d
|
||||
endif
|
||||
a=b
|
||||
fa=fb
|
||||
if(dabs(d).gt.tol1)then
|
||||
b=b+d
|
||||
else
|
||||
b=b+dsign(tol1,xm)
|
||||
endif
|
||||
fb=func(aaa,bbb,ccc,b)
|
||||
11 continue
|
||||
write(*,*) 'zbrent exceeding maximum iterations'
|
||||
zbrent=b
|
||||
return
|
||||
end function zbrent
|
||||
|
||||
! Incomplete beta function.
|
||||
double precision function betai(a,b,x)
|
||||
double precision a,b,x
|
||||
!U USES betacf,gammln
|
||||
double precision bt
|
||||
double precision betacf,gammln
|
||||
external betacf,gammln
|
||||
|
||||
if(x.lt.0.0d0.or.x.gt.1.0d0)then
|
||||
write(*,*) 'bad argument x in betai'
|
||||
endif
|
||||
if(x.eq.0.0d0.or.x.eq.1.0d0)then
|
||||
bt=0.0d0
|
||||
else
|
||||
bt=dexp(gammln(a+b)-gammln(a)-gammln(b)+
|
||||
& a*dlog(x)+b*dlog(1.0d0-x))
|
||||
endif
|
||||
if(x.lt.(a+1.0d0)/(a+b+2.0d0))then
|
||||
betai=bt*betacf(a,b,x)/a
|
||||
return
|
||||
else
|
||||
betai=1.0d0-bt*betacf(b,a,1.0d0-x)/b
|
||||
return
|
||||
endif
|
||||
end function betai
|
||||
|
||||
␍! Continued fraction evaluation.
|
||||
! Used by routine betai.
|
||||
! Numerical Recipes, chapter 6.4.
|
||||
double precision function betacf(a,b,x)
|
||||
implicit none
|
||||
integer MAXIT,m,m2
|
||||
double precision a,b,x,EPS,FPMIN
|
||||
double precision aa,c,d,del,h,qab,qam,qap
|
||||
parameter(MAXIT = 100)
|
||||
parameter(EPS=3.0d-7,FPMIN=1.0d-30)
|
||||
|
||||
qab=a+b
|
||||
qap=a+1.0d0
|
||||
qam=a-1.0d0
|
||||
c=1.0d0
|
||||
d=1.0d0-qab*x/qap
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
d=1.0d0/d
|
||||
h=d
|
||||
do 11 m=1,MAXIT
|
||||
m2=2*m
|
||||
aa=dble(m)*(b-dble(m))*x/((qam+dble(m2))*(a+dble(m2)))
|
||||
d=1.0d0+aa*d
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
c=1.0d0+aa/c
|
||||
if(dabs(c).lt.FPMIN)c=FPMIN
|
||||
d=1.0d0/d
|
||||
h=h*d*c
|
||||
aa=-(a+dble(m))*(qab+dble(m))*x/((a+dble(m2))*(qap+dble(m2)))
|
||||
d=1.0d0+aa*d
|
||||
if(dabs(d).lt.FPMIN)d=FPMIN
|
||||
c=1.0d0+aa/c
|
||||
if(dabs(c).lt.FPMIN)c=FPMIN
|
||||
d=1.0d0/d
|
||||
del=d*c
|
||||
h=h*del
|
||||
if(dabs(del-1.0d0).lt.EPS)goto 1
|
||||
11 continue
|
||||
write(*,*) 'a or b too big, or MAXIT too small in betacf'
|
||||
1 betacf=h
|
||||
return
|
||||
end function betacf
|
||||
@@ -0,0 +1,52 @@
|
||||
subroutine uniformgridsampling(sampfunc,nparams,
|
||||
& msect0,bestguess,yatguess,bmax,bmin)
|
||||
implicit none
|
||||
!
|
||||
integer nparams,msect0,ihowsamp
|
||||
double precision bestguess(nparams),guessconfid0,
|
||||
& bmax(nparams),bmin(nparams),params(nparams,msect0+1),
|
||||
& guessconfid,yatguess,beta(nparams),fatbeta
|
||||
integer i,nright,nleft,j,k,n,msect,m
|
||||
double precision tiny,x1,delta,eps
|
||||
parameter(eps=1.0d-9)
|
||||
external sampfunc
|
||||
!
|
||||
msect=msect0
|
||||
do i=1,nparams
|
||||
tiny=(bmax(i)-bmin(i))*eps
|
||||
x1=(bmax(i)-bmin(i)-2.0d0*tiny)/dble(msect)
|
||||
params(i,1)=bmin(i)+tiny
|
||||
do j=2,msect+1
|
||||
params(i,j)=params(i,j-1)+x1
|
||||
params(i,j)=dmax1(params(i,j),bmin(i))
|
||||
params(i,j)=dmin1(params(i,j),bmax(i))
|
||||
enddo
|
||||
enddo
|
||||
msect=msect+1
|
||||
yatguess=1.0d+100
|
||||
do i=1,msect**nparams
|
||||
do j=1,nparams
|
||||
!the size of the larger repeated unit is msect**(nparams-j+1)
|
||||
k=i/(msect**(nparams-j+1))
|
||||
n=mod(i,(msect**(nparams-j+1)))
|
||||
if(n.eq.0)k=k-1
|
||||
!k is the number of repeated units before i (not include the unit i is in)
|
||||
k=i-k*(msect**(nparams-j+1))
|
||||
!now k is the position in the larger repeated unit
|
||||
!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect
|
||||
m=(msect**(nparams-j+1))/msect
|
||||
n=k/m
|
||||
if(mod(k,m).ne.0)n=n+1
|
||||
beta(j)=params(j,n)
|
||||
enddo
|
||||
call sampfunc(nparams,beta,fatbeta)
|
||||
if(fatbeta.lt.yatguess)then
|
||||
yatguess=fatbeta
|
||||
do j=1,nparams
|
||||
bestguess(j)=beta(j)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
1 format(1x,i5,4f15.8)
|
||||
return
|
||||
end
|
||||
@@ -0,0 +1,34 @@
|
||||
subroutine univparser(longchar,nmax,vars,n)
|
||||
!convert a line of characters that consists of an array of real numbers into a
|
||||
!vector of real numbers
|
||||
implicit none
|
||||
integer nmax,n
|
||||
double precision vars(nmax+100)
|
||||
character longchar*(*),astring*50,c*1
|
||||
integer i,pos1,pos2,ispartnum,leng,numchar,ierr
|
||||
!
|
||||
n=0
|
||||
leng=len(longchar)
|
||||
i=0
|
||||
10 i=i+1
|
||||
if(i.gt.leng)return
|
||||
c=longchar(i:i)
|
||||
if(ispartnum(c).eq.0)goto 10
|
||||
pos1=i-1
|
||||
20 i=i+1
|
||||
c=longchar(i:i)
|
||||
if(ispartnum(c).eq.1)then
|
||||
if(i.lt.leng)goto 20
|
||||
i=i+1
|
||||
endif
|
||||
numchar=i-1-(pos1+1)+1
|
||||
if(numchar.gt.0)then
|
||||
n=n+1
|
||||
astring=longchar((pos1+1):(i-1))
|
||||
call extCharToFloatNum(numchar,astring,vars(n),ierr)
|
||||
endif
|
||||
if(i.ge.leng)return
|
||||
pos1=i
|
||||
goto 20
|
||||
return
|
||||
end subroutine univparser
|
||||
@@ -0,0 +1,15 @@
|
||||
subroutine vectorrotation(vectold,tranmatrix,vectnew)
|
||||
implicit none
|
||||
!transform the three components of a vector from an old coordinate
|
||||
!system to an new coordinate system defined by the rotation matrix tranmatrix
|
||||
!tranmatrix(i,j): ith row, jth column
|
||||
double precision vectold(3),tranmatrix(3,3),vectnew(3)
|
||||
integer i,j
|
||||
do i=1,3
|
||||
vectnew(i)=0.0d0
|
||||
do j=1,3
|
||||
vectnew(i)=vectnew(i)+
|
||||
& tranmatrix(i,j)*vectold(j)
|
||||
enddo
|
||||
enddo
|
||||
end subroutine vectorrotation
|
||||
Reference in New Issue
Block a user