1 : C SEGLIN SOURCE CHAT 05/01/13 03:13:13 5004 2 : subroutine seglin(p1,p2,x1,x2,dx,ide) 3 : C============================================================= 4 : C 5 : C INTERSECTION D UN SEGMENT S1 S2 AVEC UN segment P1 P2 6 : C = 7 : C P1,P2 2 points POINTS DANS UN PLAN 8 : C X1,X2 2 points DANS LE MEME PLAN 9 : C 10 : C OUTPUT: 11 : C dx: POINT D'INTERSECTION 12 : C ide =-2 pas de solution (supports // ) 13 : C IDE =-1 intersection support x1x2 en dehors du segment P1 P2 14 : C ide = 0 intersection support x1x2 dans le segment p1 p2 15 : C IDE = 1 les segments se coupent 16 : C 17 : C G. L. JIANG / MODIFIE BAZE 18 : C 19 : C============================================================= 20 : 21 : IMPLICIT INTEGER(I-N) 22 : IMPLICIT REAL*8(A-H,O-Z) 23 : dimension xtrav(2) 24 : dimension p1(*),p2(*),x1(*),x2(*),dx(*) 25 : C segment itrav 26 : C REAL*8 xtrav(2),xpen(2) 27 : C endsegment 28 : DATA EPSI/0.0001/ 29 : C 30 : C segini itrav 31 : ide= 10 32 : a11 = x2(2)-x1(2) 33 : a12 = x1(1)-x2(1) 34 : a21 = p2(2)-p1(2) 35 : a22 = p1(1)-p2(1) 36 : b1 = x1(1)*a11+x1(2)*a12 37 : b2 = p1(1)*a21+p1(2)*a22 38 : det = a11*a22-a21*a12 39 : C================ 40 : IF(ABS(DET).LT.EPSI) THEN 41 : C les segments ont ils le meme support 42 : ps1=0.D0 43 : do i=1,2 44 : xtrav(i) = (x1(i)+x2(i))/2.D0 45 : ps1 = ps1 + (x2(i)-x1(i))*(p2(i)-p1(i)) 46 : enddo 47 : xpen= (x1(2)-x2(2))*(p2(1)-p1(1)) + 48 : & (x2(1)-x1(1))*(p2(2)-p1(2)) 49 : 50 : C------------ 51 : if ( xpen.lt.epsi) then 52 : C il sont sur le meme support 53 : C on met p1p2 dans le sens x1x2 si besoin 54 : if(ps1.lt.0.D0) then 55 : do i=1,2 56 : xtrav(i) = p2(i) 57 : p2(i) = p1(i) 58 : p1(i) = xtrav(i) 59 : enddo 60 : endif 61 : C 62 : ps1= 0.D0 63 : ps2= 0.D0 64 : ps3= 0.D0 65 : do i=1,2 66 : ps1 = ps1 + (x1(i)-p1(i))*(x1(i)-p2(i)) 67 : ps2 = ps2 + (x2(i)-p1(i))*(x2(i)-p2(i)) 68 : ps3 = ps3 + (p1(i)-x1(i))*(p1(i)-x2(i)) 69 : enddo 70 : C 71 : if(ps1.lt.0.D0.and.ps2.lt.0.D0) then 72 : C x1 et x2 entre p1 et p2 73 : ide= 1 74 : do i=1,2 75 : dx(i)=x2(i) 76 : enddo 77 : goto 200 78 : endif 79 : C 80 : if(ps1.gt.0.D0.and.ps2.gt.0.D0) then 81 : C p1 et p2 entre x1 et x2 82 : ide=0 83 : if(ps3.gt.0.D0) goto 200 84 : ide=1 85 : do i=1,2 86 : dx(i)=p1(i) 87 : enddo 88 : goto 200 89 : endif 90 : C 91 : if(ps1.gt.0.D0.and.ps2.lt.0.D0) then 92 : C x2 entre p1 et p2 93 : do i=1,2 94 : dx(i)=p1(i) 95 : enddo 96 : ide=1 97 : goto 200 98 : endif 99 : C 100 : if(ps1.lt.0.D0.and.ps2.gt.0.D0) then 101 : C x1 entre p1 et p2 102 : do i=1,2 103 : dx(i)=p2(i) 104 : enddo 105 : ide=1 106 : goto 200 107 : endif 108 : C 109 : if(ps2.gt.0.D0) then 110 : C x2 entre p1 et p2 111 : do i=1,2 112 : dx(i)=p1(i) 113 : ide=1 114 : enddo 115 : goto 200 116 : endif 117 : C 118 : 119 : C 120 : else 121 : C-------- 122 : ide=-2 123 : endif 124 : C--------- 125 : ELSE 126 : C================ les supports se croisent 127 : dx(1)=(b1*a22-b2*a12)/det 128 : dx(2)=-(b1*a21-b2*a11)/det 129 : ps=0.D0 130 : ps2=0.D0 131 : do 168 i=1,2 132 : ps = ps + (x1(i)-dx(i))*(x2(i)-dx(i)) 133 : ps2=ps2 + (p1(i)-dx(i))*(p2(i)-dx(i)) 134 : 168 continue 135 : 136 : 137 : if (ps2.le.epsi) then 138 : C intersection du support x1x2 entre p1 et p2 139 : if (ps.lt.0.D0.or.abs(ps).lt.0.1D-3) then 140 : ide = 1 141 : else 142 : ide = 0 143 : endif 144 : else 145 : C intersection des supports en dehors de p1p2 146 : ide=-1 147 : endif 148 : ENDIF 149 : 200 CONTINUE 150 : C================ 151 : C write(6,1000) ide, (dx(il),il=1,2) 152 : 1000 format (I4,2E12.5) 153 : return 154 : end 155 : 156 : 157 :
© Cast3M 2003 - All rights reserved.
Disclaimer