Télécharger facet.eso

Retour à la liste

Numérotation des lignes :

  1. C FACET SOURCE JC220346 16/11/29 21:15:14 9221
  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.  
  310.  
  311.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales