85 lines
2.0 KiB
Fortran
85 lines
2.0 KiB
Fortran
|
|
SUBROUTINE weightfromdata(m,x,maxiter,weight)
|
|
implicit none
|
|
|
|
integer :: m,maxiter
|
|
real*8 :: x(m),weight
|
|
real*8 :: thr,mu,sigma,Xvec,normconstants,fx,z,bfx,wlo
|
|
real*8 :: pi,phix(m),dnorm0,shi,slo,temp(m),beta(m),initialwlo,tmpweight,temp_deltaweight(100),wmid,smid,whi,conTol,wtol,stol
|
|
integer :: ii,tnum,i
|
|
|
|
pi = 3.1415926
|
|
thr = sqrt(2.0*log(real(m)))
|
|
mu = 0
|
|
sigma = 1
|
|
Xvec = abs((thr-mu)**2)
|
|
normconstants = 1.0/(sqrt(2.0*pi)*sigma)
|
|
fx = normconstants*exp(-Xvec/(2.0*sigma))
|
|
z = (thr-mu)/sigma
|
|
bfx = 1.0/2.0*erfc(-z/sqrt(2.0))
|
|
|
|
wlo = 1 + (bfx - thr*fx - 1.0/2)/(sqrt(pi/2.0)*fx*thr**2)
|
|
if(isnan(wlo)) wlo = 1
|
|
wlo = 1.0/wlo
|
|
|
|
phix = abs((x-mu)**2)
|
|
phix = normconstants*exp(-phix/(2.0*sigma))
|
|
dnorm0 = 0.398942280401433
|
|
|
|
do i=1,m
|
|
if(abs(phix(i) - dnorm0)>5.55111512312578e-14) then
|
|
beta(i) = (dnorm0/phix(i)-1.0)/x(i)**2-1.0
|
|
else
|
|
beta(i) = -0.5
|
|
end if
|
|
end do
|
|
|
|
shi = sum(beta/(1.0 + beta))
|
|
if(shi>=0) then
|
|
weight = 1
|
|
goto 10
|
|
end if
|
|
|
|
temp = wlo*beta
|
|
slo = sum(beta/(1.0+temp))
|
|
if(slo<=0) then
|
|
tmpweight = wlo
|
|
initialwlo = wlo
|
|
end if
|
|
|
|
conTol = 1.0e30
|
|
wtol = 2.22044604925031e-14
|
|
stol = 1e-7
|
|
ii = 1
|
|
|
|
temp_deltaweight = 0
|
|
temp_deltaweight(1) = 1.0-wlo
|
|
tnum = 1
|
|
|
|
whi = 1
|
|
do while(conTol>wtol)
|
|
wmid = sqrt(whi*wlo)
|
|
smid = sum(beta/(1.0+wmid*beta))
|
|
|
|
if(abs(smid)<stol) then
|
|
tmpweight = wmid
|
|
weight = tmpweight
|
|
goto 10
|
|
end if
|
|
|
|
if(smid>0) wlo = wmid
|
|
if(smid<0) whi = wmid
|
|
|
|
tnum = tnum+1
|
|
temp_deltaweight(tnum) = whi-wlo
|
|
|
|
conTol = abs(temp_deltaweight(ii+1) - temp_deltaweight(ii))
|
|
ii = ii+1
|
|
if(ii>maxiter) exit
|
|
end do
|
|
|
|
tmpweight = sqrt(wlo*whi)
|
|
if(slo <= 0) tmpweight = initialwlo
|
|
weight = tmpweight
|
|
|
|
10 end subroutine |