Initial commit
This commit is contained in:
@@ -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
|
||||
Reference in New Issue
Block a user