909 lines
25 KiB
FortranFixed
909 lines
25 KiB
FortranFixed
subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
|
|
implicit none
|
|
integer n,imin,imax,i
|
|
double precision x(n),xmin,xmax
|
|
imin=1
|
|
xmin=x(1)
|
|
imax=1
|
|
xmax=x(1)
|
|
do i=2,n
|
|
if(x(i).lt.xmin)then
|
|
imin=i
|
|
xmin=x(i)
|
|
endif
|
|
if(x(i).gt.xmax)then
|
|
imax=i
|
|
xmax=x(i)
|
|
endif
|
|
enddo
|
|
return
|
|
end
|
|
|
|
double precision function fdotsec(idotsec)
|
|
implicit none
|
|
integer idotsec,i,k,j(100),n
|
|
k=idotsec
|
|
i=1
|
|
10 j(i)=mod(k,10)
|
|
k=k/10
|
|
if(k.gt.0)then
|
|
i=i+1
|
|
goto 10
|
|
endif
|
|
fdotsec=0.0d0
|
|
do k=1,i
|
|
n=10**(i-k+1)
|
|
fdotsec=fdotsec+dble(j(k))/dble(n)
|
|
enddo
|
|
return
|
|
end
|
|
|
|
integer function isitnaninf(x)
|
|
!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
|
|
implicit none
|
|
double precision x
|
|
isitnaninf=1
|
|
if((x+1.0d0).gt.x)isitnaninf=0
|
|
if((x+1.0d0).lt.x)isitnaninf=1
|
|
if((x+1.0d0).eq.x)isitnaninf=1
|
|
return
|
|
end
|
|
|
|
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
|
|
|
|
subroutine getcubicroot(p,q,r,root1,root2,root3)
|
|
c
|
|
implicit double precision(a-h,l,o-z)
|
|
|
|
c: x^3+p*x^2+q*x+r=0
|
|
root1=-9999.0d0
|
|
root2=-9999.0d0
|
|
root3=-9999.0d0
|
|
|
|
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
|
|
|
|
subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
|
|
implicit none
|
|
integer nsamp0,nsamp,j
|
|
double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
|
|
nsamp=0
|
|
do j=1,nsamp0
|
|
if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
|
|
nsamp=nsamp+1
|
|
xvar(nsamp)=xvar0(j)
|
|
endif
|
|
enddo
|
|
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))
|
|
cv=std/fmean
|
|
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
|