1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
| program test_voisin
implicit none
integer :: dim,i
real*8 :: x
integer, dimension (10) :: points
integer, dimension (:,:), allocatable :: mat
dim=10
allocate (mat(dim,dim))
call random_seed
do i = 1,10
call random_number (x)
x=2*10*x-1
points(i)=x
enddo
print*, points
pause 100
call connexion (points,mat,dim)
end program test_voisin
subroutine connexion (points,mat,dim)
implicit none
integer :: dim
real*8 , dimension (dim) :: points
real*8,dimension (:), allocatable :: t1
integer , dimension (dim,dim) :: mat
integer , dimension (:) , allocatable :: l1,l2,l3
integer , dimension (:) , allocatable :: vois
logical test
integer i,j,k
integer ifus,iv1,iv2,iv3
real*8 x,y,z,t
real*8 eps,larg
dim=10
open(10,file='depart.dat',status='unknown')
allocate(t1(dim))
allocate(vois(dim))
allocate(l1(dim))
allocate(l2(dim))
allocate(l3(dim))
print*, 'deuxieme verification', points
2 write(6,*) 'critere de distance entre points'
read(5,*) eps
mat=0
l1=0
l2=0
l3=0
vois=0
do i=1,dim
k=0
do j=1,dim
if(abs(points(i)-points(j)).le.eps) then
k=k+1
mat(i,k)=j
endif
enddo
vois(i)=k
enddo
do i=1,dim
write(6,*) (mat(i,j),j=1,vois(i))
enddo
do while(.true.)
ifus=0
do i=1,dim
do j=1,dim
if(i.eq.j) cycle
l1=mat(i,:)
l2=mat(j,:)
iv1=vois(i)
iv2=vois(j)
if(iv1*iv2.eq.0) cycle
call intersection(l1,l2,l3,iv1,iv2,iv3,dim,test)
if(test.eq..false.) cycle
mat(i,:)=l3
vois(i)=iv3
mat(j,:)=0
vois(j)=0
ifus=1
enddo
enddo
if(ifus.eq.0) exit
enddo
write(6,*) 'termine'
k=0
do i=1,dim
if(vois(i).eq.0) cycle
k=k+1
write(6,1) k,vois(i)
1 format( 'l''ensemble de points numero ',i4,' contient les ',i4,' points suivants :')
write(6,*) (mat(i,j),j=1,vois(i))
write(6,*)
enddo
rewind(10)
do i=1,dim
x=1.d0
write(10,*) points(i),x
enddo
do i=1,dim
if(vois(i).eq.0) cycle
do j=1,vois(i)
t1(j)=points(mat(i,j))
enddo
y=minval(t1(1:vois(i)))
z=maxval(t1(1:vois(i)))
t=y
x=2.d0
do while(t.le.z)
write(10,*) t,x
t=t+eps/1000.d0
enddo
x=3.d0
write(10,*) (y+z)/2.d0,x
enddo
go to 2
end subroutine connexion
subroutine intersection(l1,l2,l3,iv1,iv2,iv3,dim,test)
integer , intent(in) :: dim
integer iv3,k,i,j
integer l3(dim)
integer , intent(in) :: l1(dim),l2(dim)
integer, intent(in) :: iv1,iv2
logical test
test=.false.
do i=1,iv1
do j=1,iv2
if(l1(i).eq.l2(j)) then
test=.true.
endif
enddo
enddo
if(test.eq..false.) return
l3=l1
k=iv1
do i=1,iv2
do j=1,iv1
if(l3(j).eq.l2(i)) go to 1
enddo
k=k+1
l3(k)=l2(i)
1 continue
enddo
iv3=k
return
end subroutine intersection |
Partager