1 : C FACET SOURCE PV 07/10/11 21:15:10 5907 2 : C---------------------------------------------------------------------| 3 : C | 4 : LOGICAL FUNCTION FACET(JF) 5 : C | 6 : C CETTE FONCTION LOGIQUE INDIQUE SI LA FACETTE JF EST VALIDE. | 7 : C -0- On verifie que les diag des quadr ne sont pas des aretes ! 8 : C -1- ON TESTE LES ANGLES DES SEGMENTS DE LA FACETTES | 9 : C SI CES ANGLES SONT TROP PETITS, LA FACETTE EST INVALIDE | | 10 : C -2- ON TESTE LES ANGLES DE LA FACETTE JF AVEC LES FACETES | 11 : C ADJACENTES: SI CET ANGLE EST TROP PETIT, LA FACETTE EST | 12 : C INVALIDE | | 13 : C -3- ON TESTE L'INTERSECTION DE LA FACETTE AVEC LES FACETTES | 14 : C ENVIRONNANTES. | 15 : C -4- ON VERIFIE LA POSITION DES ARETES DE LA FACETTE PAR | 16 : C AUX FACETTES AVOISINANTES | 17 : C | 18 : C---------------------------------------------------------------------| 19 : C 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8(A-H,O-Z) 22 : -INC TDEMAIT 23 : -INC CCOPTIO 24 : LOGICAL REPONS,INTER,DROIT,FACET2,ARET,TSDIS,icause 25 : C SI LA FACETTE A ETE SUPPRIME ELLE EST CONSIDEREE COMME BONNE 26 : ifs=jf 27 : icause=.false. 28 : iirfac=0 29 : j1rfac=0 30 : j2rfac=0 31 : ifrfac=0 32 : DO 10 I=1,NFACET 33 : IF (IFUT(I).EQ.JF) GOTO 20 34 : 10 CONTINUE 35 : FACET=.TRUE. 36 : RETURN 37 : 20 CONTINUE 38 : C 39 : FACET=.FALSE. 40 : C 41 : I1=NFC(1,JF) 42 : I2=NFC(2,JF) 43 : I3=NFC(3,JF) 44 : I4=NFC(4,JF) 45 : C 46 : C 0EME CAS 47 : C -------- 48 : if (i4.ne.0) then 49 : DO 100 I=1,40 50 : IF=NPF(I,I1) 51 : if (if.eq.jf) goto 100 52 : IF (IF.EQ.0) GOTO 120 53 : DO 110 J=1,40 54 : IF (NPF(J,i3).EQ.0) GOTO 100 55 : IF (IF.eq.NPF(J,i3)) GOTO 150 56 : 110 continue 57 : 100 continue 58 : 120 continue 59 : DO 130 I=1,40 60 : IF=NPF(I,I2) 61 : if (if.eq.jf) goto 130 62 : IF (IF.EQ.0) GOTO 160 63 : DO 140 J=1,40 64 : IF (NPF(J,i4).EQ.0) GOTO 130 65 : IF (IF.eq.NPF(J,i4)) GOTO 150 66 : 140 continue 67 : 130 continue 68 : goto 160 69 : 150 continue 70 : * write (6,*) ' facet diagonale arete' 71 : return 72 : 160 continue 73 : endif 74 : C 75 : C 1ER CAS 76 : C -------- 77 : IF (.NOT.DROIT(I1,I2,I3)) RETURN 78 : IF (I4.NE.0) THEN 79 : IF (.NOT.DROIT(I2,I3,I4)) RETURN 80 : IF (.NOT.DROIT(I3,I4,I1)) RETURN 81 : IF (.NOT.DROIT(I4,I1,I2)) RETURN 82 : ELSE 83 : IF (.NOT.DROIT(I2,I3,I1)) RETURN 84 : IF (.NOT.DROIT(I3,I1,I2)) RETURN 85 : ENDIF 86 : C 87 : C 2EME CAS: 88 : C -------- 89 : C 90 : ANG=TETA(JF,NOISIN(I1,I2,JF),I1,I2) 91 : IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then 92 : icause=.true. 93 : kf=NOISIN(I1,I2,JF) 94 : ifrfac=ifs 95 : iirfac=nfc(1,kf) 96 : j1rfac=nfc(2,kf) 97 : j2rfac=nfc(3,kf) 98 : * write (6,*) ' facet angle 1 incorrect ',ang 99 : RETURN 100 : ENDIF 101 : C 102 : ANG=TETA(JF,NOISIN(I2,I3,JF),I2,I3) 103 : IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then 104 : icause=.true. 105 : kf=NOISIN(I2,I3,JF) 106 : ifrfac=ifs 107 : iirfac=nfc(1,kf) 108 : j1rfac=nfc(2,kf) 109 : j2rfac=nfc(3,kf) 110 : * write (6,*) ' facet angle 2 incorrect ',ang 111 : RETURN 112 : ENDIF 113 : C 114 : IF (I4.EQ.0) THEN 115 : ANG=TETA(JF,NOISIN(I3,I1,JF),I3,I1) 116 : IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then 117 : icause=.true. 118 : kf=NOISIN(I3,I1,JF) 119 : ifrfac=ifs 120 : iirfac=nfc(1,kf) 121 : j1rfac=nfc(2,kf) 122 : j2rfac=nfc(3,kf) 123 : * write (6,*) ' facet angle 3 incorrect ',ang 124 : RETURN 125 : ENDIF 126 : ELSE 127 : ANG=TETA(JF,NOISIN(I3,I4,JF),I3,I4) 128 : IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then 129 : icause=.true. 130 : kf=NOISIN(I3,I4,JF) 131 : ifrfac=ifs 132 : iirfac=nfc(1,kf) 133 : j1rfac=nfc(2,kf) 134 : j2rfac=nfc(3,kf) 135 : * write (6,*) ' facet angle 4 incorrect ',ang 136 : RETURN 137 : ENDIF 138 : C 139 : ANG=TETA(JF,NOISIN(I4,I1,JF),I4,I1) 140 : IF (ANG.GT.CFACET.or.ang.lt.-2000000-cfacet) then 141 : icause=.true. 142 : kf=NOISIN(I4,I1,JF) 143 : ifrfac=ifs 144 : iirfac=nfc(1,kf) 145 : j1rfac=nfc(2,kf) 146 : j2rfac=nfc(3,kf) 147 : * write (6,*) ' facet angle 5 incorrect ',ang 148 : RETURN 149 : ENDIF 150 : ENDIF 151 : C 152 : C 3EME CAS: 153 : C --------- 154 : FACET=.TRUE. 155 : C 156 : C TEST DE L'INTERSECTION DE LA FACETTE JF AVEC LES FACETTES ENVIRON 157 : C ----------------------------------------------------------------- 158 : C ( AYANT UN POINT COMMUN AVEC LA FACETTE TESTEE ) 159 : C EGALEMENT TEST DES POSITIONS RELATIVES 160 : C -------------------------------------- 161 : C 162 : NBD=4 163 : IF (NFC(4,JF).EQ.0) NBD=3 164 : IPROB=0 165 : DO 200 IP=1,NBD 166 : * POINT DE LA FACE 167 : II=NFC(IP,JF) 168 : I1=IPRED(JF,II) 169 : I2=ISUCC(JF,II) 170 : dref= (xyz(1,i2)-xyz(1,i1))**2 171 : > + (xyz(2,i2)-xyz(2,i1))**2 172 : > + (xyz(3,i2)-xyz(3,i1))**2 173 : * TEST DE SITUATION A EVITER SI 4 FACES AUTOUR DU POINT 174 : DO 210 I=1,40 175 : * FACE CONTENANT LE POINT 176 : KF=NPF(I,II) 177 : IF (KF.EQ.0) GOTO 200 178 : IF (KF.EQ.JF) GOTO 210 179 : J1=IPRED(KF,II) 180 : J2=ISUCC(KF,II) 181 : IF (I1.EQ.J1) GOTO 210 182 : IF (I1.EQ.J2) GOTO 210 183 : IF (I2.EQ.J1) GOTO 210 184 : IF (I2.EQ.J2) GOTO 210 185 : * Y A T IL INTERSECTION ??? LES DEUX POINTS D'UNE FACE SONT DE PART ET 186 : * D'AUTRE DE L'AUTRE 187 : V1=VOL(I1,II,J1,J2) 188 : V2=VOL(I2,II,J1,J2) 189 : av1=abs(v1) 190 : av2=abs(v2) 191 : VV=max(av1,av2)/faccri 192 : *pv IF (V1*V2.GE.0.d0) GOTO 210 193 : IF (av1.gt.vv.and.av2.gt.vv.and.V1*V2.GT.1D-12*dref**3) GOTO 210 194 : W1=VOL(J1,II,I1,I2) 195 : W2=VOL(J2,II,I1,I2) 196 : aw1=abs(w1) 197 : aw2=abs(w2) 198 : ww=max(aw1,aw2)/faccri 199 : *pv IF (W1*W2.GE.0.d0) GOTO 210 200 : IF (aw1.gt.ww.and.aw2.gt.ww.and.W1*W2.GT.1D-12*dref**3) GOTO 210 201 : * si les deux facettes sont à peu pres coplanaires, test spécial 202 : if (max(av1,av2,aw1,aw2).lt.1e-6*dref**(3/2)) then 203 : * write (6,*) ' FACET facettes coplanaires ' 204 : * si il y a intersection i1 ou i2 est entre j1 et j2 ou l'inverse 205 : xi1=xyz(1,i1)-xyz(1,ii) 206 : yi1=xyz(2,i1)-xyz(2,ii) 207 : zi1=xyz(3,i1)-xyz(3,ii) 208 : si1=sqrt(xi1**2+yi1**2+zi1**2) 209 : xi2=xyz(1,i2)-xyz(1,ii) 210 : yi2=xyz(2,i2)-xyz(2,ii) 211 : zi2=xyz(3,i2)-xyz(3,ii) 212 : si2=sqrt(xi2**2+yi2**2+zi2**2) 213 : xj1=xyz(1,j1)-xyz(1,ii) 214 : yj1=xyz(2,j1)-xyz(2,ii) 215 : zj1=xyz(3,j1)-xyz(3,ii) 216 : sj1=sqrt(xj1**2+yj1**2+zj1**2) 217 : xj2=xyz(1,j2)-xyz(1,ii) 218 : yj2=xyz(2,j2)-xyz(2,ii) 219 : zj2=xyz(3,j2)-xyz(3,ii) 220 : sj2=sqrt(xj2**2+yj2**2+zj2**2) 221 : xn1=yi1*zj1-zi1*yj1 222 : yn1=zi1*xj1-xi1*zj1 223 : zn1=xi1*yj1-yi1*xj1 224 : xn2=yi1*zj2-zi1*yj2 225 : yn2=zi1*xj2-xi1*zj2 226 : zn2=xi1*yj2-yi1*xj2 227 : sc1=xn1*xn2+yn1*yn2+zn1*zn2 228 : sd1=xi1*(xj1/sj1+xj2/sj2)+yi1*(yj1/sj1+yj2/sj2) 229 : > +zi1*(zj1/sj1+zj2/sj2) 230 : xn1=yi2*zj1-zi2*yj1 231 : yn1=zi2*xj1-xi2*zj1 232 : zn1=xi2*yj1-yi2*xj1 233 : xn2=yi2*zj2-zi2*yj2 234 : yn2=zi2*xj2-xi2*zj2 235 : zn2=xi2*yj2-yi2*xj2 236 : sc2=xn1*xn2+yn1*yn2+zn1*zn2 237 : sd2=xi2*(xj1/sj1+xj2/sj2)+yi2*(yj1/sj1+yj2/sj2) 238 : > +zi2*(zj1/sj1+zj2/sj2) 239 : if ((sc1.lt.0.D0.and.sd1.gt.0.d0).or. 240 : > (sc2.lt.0.D0.and.sd2.gt.0.d0)) then 241 : * WRITE (6,*) ' FACET TRIANGLES COPLANAIRES INTERSECTANTS ' 242 : * WRITE (6,*) II,I1,I2,II,J1,J2,v1,v2,w1,w2,sc1,sc2 243 : FACET=.FALSE. 244 : icause=.true. 245 : ifrfac=ifs 246 : iirfac=ii 247 : j1rfac=j1 248 : j2rfac=j2 249 : RETURN 250 : endif 251 : goto 210 252 : endif 253 : * VERIFIER QUE II (I1 I2 INTER F2 ) ET II (J1 J2 INTER F1) SONT 254 : * DANS LA MEME DIRECTION 255 : if ((v2-v1).eq.0.d0) goto 210 256 : XN1=(V2*XYZ(1,I1)-V1*XYZ(1,I2))/(V2-V1)-XYZ(1,II) 257 : YN1=(V2*XYZ(2,I1)-V1*XYZ(2,I2))/(V2-V1)-XYZ(2,II) 258 : ZN1=(V2*XYZ(3,I1)-V1*XYZ(3,I2))/(V2-V1)-XYZ(3,II) 259 : if ((w2-w1).eq.0.d0) goto 210 260 : XN2=(W2*XYZ(1,J1)-W1*XYZ(1,J2))/(W2-W1)-XYZ(1,II) 261 : YN2=(W2*XYZ(2,J1)-W1*XYZ(2,J2))/(W2-W1)-XYZ(2,II) 262 : ZN2=(W2*XYZ(3,J1)-W1*XYZ(3,J2))/(W2-W1)-XYZ(3,II) 263 : IF (XN1*XN2+YN1*YN2+ZN1*ZN2.LT.0.D0) GOTO 210 264 : * WRITE (6,*) ' FACET TRIANGLES INTERSECTANTS ' 265 : * WRITE (6,*) II,I1,I2,II,J1,J2,v1,v2,w1,w2 266 : * WRITE (6,*) XN1*XN2+YN1*YN2+ZN1*ZN2 267 : * WRITE (6,*) 'dref ',dref 268 : * write (6,*) 'ii ',xyz(1,ii),xyz(2,ii),xyz(3,ii) 269 : * write (6,*) 'i1 ',xyz(1,i1),xyz(2,i1),xyz(3,i1) 270 : * write (6,*) 'i2 ',xyz(1,i2),xyz(2,i2),xyz(3,i2) 271 : * write (6,*) 'j1 ',xyz(1,j1),xyz(2,j1),xyz(3,j1) 272 : * write (6,*) 'j2 ',xyz(1,j2),xyz(2,j2),xyz(3,j2) 273 : FACET=.FALSE. 274 : icause=.true. 275 : ifrfac=ifs 276 : iirfac=ii 277 : j1rfac=j1 278 : j2rfac=j2 279 : RETURN 280 : 210 CONTINUE 281 : 200 CONTINUE 282 : if (.not.facet) return 283 : C 284 : C TEST DE LA POSITION DES ARETES PAR AUX FACETTES VOISINES 285 : C 286 : * FACET=ARET(I1,I2) 287 : * IF (.NOT.FACET) RETURN 288 : * FACET=ARET(I2,I3) 289 : * IF (.NOT.FACET) RETURN 290 : * IF (I4.EQ.0) THEN 291 : * FACET=ARET(I3,I1) 292 : * IF (.NOT.FACET) RETURN 293 : * ELSE 294 : * FACET=ARET(I3,I4) 295 : * IF (.NOT.FACET) RETURN 296 : * FACET=ARET(I4,I1) 297 : * IF (.NOT.FACET) RETURN 298 : * ENDIF 299 : RETURN 300 : * test de la position des points existants par rapport a la facette 301 : C 302 : C 303 : C FACET=FALSE SI LA NOUVELLE FACETTE EST MAUVAISE 304 : C FACET=TRUE SI LA NOUVELLE FACETTE EST BONNE 305 : C 306 : END 307 : 308 : 309 :
© Cast3M 2003 - All rights reserved.
Disclaimer