129 lines
3.8 KiB
FortranFixed
129 lines
3.8 KiB
FortranFixed
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
|