160 lines
4.1 KiB
FortranFixed
160 lines
4.1 KiB
FortranFixed
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
|