Télécharger soltet.eso

Retour à la liste

Numérotation des lignes :

  1. C SOLTET SOURCE PV 17/09/12 21:15:04 9542
  2. C---------------------------------------------------------------------|
  3. C |
  4. LOGICAL FUNCTION SOLTET(IF1,IF2,IF3,IF4,IPIN)
  5. C |
  6. C CETTE FONCTION LOGIQUE TESTE SI LE TETRAEDRE DECRIT PAR LES |
  7. C FACETTES IF1..IF4 EST VIDE DE POINT. |
  8. C LES ENTIERS N1..N4 INDIQUENT L'ORIENTATION DES FACETTES |
  9. C SOLTET EST VRAI SI LE TETRAEDRE EST VIDE (DONC VALIDE) |
  10. C SOLTET EST FAUX SI LE TETRAEDRE CONTIENT UN POINT (ET EST |
  11. C DONC INVALIDE) |
  12. C |
  13. C---------------------------------------------------------------------|
  14. C
  15. IMPLICIT INTEGER(I-N)
  16. IMPLICIT REAL*8(A-H,O-Z)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC TDEMAIT
  21. LOGICAL VAL,FACET2,FACET3,vervol
  22. C
  23. dimension ift(4)
  24. real*8 xo(3),xa(3),xb(3),xc(3),eps
  25. IPIN=0
  26. ift(1)=if1
  27. ift(2)=if2
  28. ift(3)=if3
  29. ift(4)=if4
  30. ip1=nfc(1,if1)
  31. ip2=nfc(2,if1)
  32. ip3=nfc(3,if1)
  33. ip4=nfc(1,if2)
  34. if (ip4.eq.ip1.or.ip4.eq.ip2.or.ip4.eq.ip3) ip4=nfc(2,if2)
  35. if (ip4.eq.ip1.or.ip4.eq.ip2.or.ip4.eq.ip3) ip4=nfc(3,if2)
  36. C
  37. C CHERCHER SI LES FACETTES SONT NOUVELLES OU ANCIENNES
  38. N1=-1
  39. N2=-1
  40. N3=-1
  41. N4=-1
  42. IF (IFAT(IF1).NE.0) N1=1
  43. IF (IFAT(IF2).NE.0) N2=1
  44. IF (IFAT(IF3).NE.0) N3=1
  45. IF (IFAT(IF4).NE.0) N4=1
  46. * encadrer le tetraedre
  47. xmin=1e30
  48. xmax=-1e30
  49. ymin=1e30
  50. ymax=-1e30
  51. zmin=1e30
  52. zmax=-1e30
  53. xmin=min(xyz(1,ip1),xyz(1,ip2),xyz(1,ip3),xyz(1,ip4))
  54. xmax=max(xyz(1,ip1),xyz(1,ip2),xyz(1,ip3),xyz(1,ip4))
  55. xmin=min(xyz(2,ip1),xyz(2,ip2),xyz(2,ip3),xyz(2,ip4))
  56. xmax=max(xyz(2,ip1),xyz(2,ip2),xyz(2,ip3),xyz(2,ip4))
  57. xmin=min(xyz(3,ip1),xyz(3,ip2),xyz(3,ip3),xyz(3,ip4))
  58. xmax=max(xyz(3,ip1),xyz(3,ip2),xyz(3,ip3),xyz(3,ip4))
  59. xd=(xmax-xmax)/2
  60. yd=(ymax-ymax)/2
  61. zd=(zmax-zmax)/2
  62. td=max(xd,yd,zd)
  63. xmin=xmin-td
  64. xmax=xmax+td
  65. ymin=ymin-td
  66. ymax=ymax+td
  67. zmin=zmin-td
  68. zmax=zmax+td
  69. iteste=0
  70. V1=N1*VOL(1,NFC(1,IF1),NFC(2,IF1),NFC(3,IF1))
  71. V2=N2*VOL(1,NFC(1,IF2),NFC(2,IF2),NFC(3,IF2))
  72. V3=N3*VOL(1,NFC(1,IF3),NFC(2,IF3),NFC(3,IF3))
  73. V4=N4*VOL(1,NFC(1,IF4),NFC(2,IF4),NFC(3,IF4))
  74. VV=V1+V2+V3+V4
  75. tm=(xyz(4,ip1)+xyz(4,ip2)+xyz(4,ip3)+xyz(4,ip4))/4
  76. tv=tm**3*1e-6
  77. IF (VV.LE.tv) then
  78. if(IVERB.EQ.1) write (6,*) ' tetraedre volume negatif '
  79. GOTO 120
  80. endif
  81. * DO 100 I=1,NPTMAX
  82. DO 100 I=1,-1
  83. IF (NPF(1,I).EQ.0) GOTO 100
  84. IF (I.EQ.IP1) GOTO 100
  85. IF (I.EQ.IP2) GOTO 100
  86. IF (I.EQ.IP3) GOTO 100
  87. IF (I.EQ.IP4) GOTO 100
  88. if (xyz(1,i).lt.xmin.or.xyz(1,i).gt.xmax) goto 100
  89. if (xyz(2,i).lt.ymin.or.xyz(2,i).gt.ymax) goto 100
  90. if (xyz(3,i).lt.zmin.or.xyz(3,i).gt.zmax) goto 100
  91. C
  92. V1=N1*VOL(I,NFC(1,IF1),NFC(2,IF1),NFC(3,IF1))
  93. V2=N2*VOL(I,NFC(1,IF2),NFC(2,IF2),NFC(3,IF2))
  94. V3=N3*VOL(I,NFC(1,IF3),NFC(2,IF3),NFC(3,IF3))
  95. V4=N4*VOL(I,NFC(1,IF4),NFC(2,IF4),NFC(3,IF4))
  96. IF (V1.LE.-volcri*VV) GOTO 100
  97. IF (V2.LE.-volcri*VV) GOTO 100
  98. IF (V3.LE.-volcri*VV) GOTO 100
  99. IF (V4.LE.-volcri*VV) GOTO 100
  100. IF (IVERB.EQ.1) WRITE(6,1010)I
  101. 1010 FORMAT(' LE POINT ',I5,' EST INTERNE AU tetraedre CREE |')
  102. IF (IVERB.EQ.1) write (6,*) ' vv,v1,v2,v3,v4 ',vv,v1,v2,v3,v4
  103. ipin=i
  104. GOTO 120
  105. C
  106. C
  107. C
  108. 100 CONTINUE
  109. C
  110. C IL N'EXISTE PAS DE POINTS INTERNES AU VOLUME
  111. SOLTET=.TRUE.
  112. C RAJOUT PV TEST ON NE CREE PAS D'ARETE A PLUS DE DEUX FACETTES
  113. * IF (N1.EQ.1) SOLTET=SOLTET.AND.FACET2(IF1)
  114. * IF (.NOT.SOLTET) RETURN
  115. * IF (N2.EQ.1) SOLTET=SOLTET.AND.FACET2(IF2)
  116. * IF (.NOT.SOLTET) RETURN
  117. * IF (N3.EQ.1) SOLTET=SOLTET.AND.FACET2(IF3)
  118. * IF (.NOT.SOLTET) RETURN
  119. * IF (N4.EQ.1) SOLTET=SOLTET.AND.FACET2(IF4)
  120. * IF (.NOT.SOLTET) RETURN
  121. C
  122. C on teste maintenant qu'on ne recouvre pas un autre volume
  123. * write (6,*) ' soltet sommets ',ip1,ip2,ip3,ip4
  124. * write (6,*) ' soltet coordonnees '
  125. * write (6,*) xyz(1,ip1),xyz(2,ip1),xyz(3,ip1)
  126. * write (6,*) xyz(1,ip2),xyz(2,ip2),xyz(3,ip2)
  127. * write (6,*) xyz(1,ip3),xyz(2,ip3),xyz(3,ip3)
  128. * write (6,*) xyz(1,ip4),xyz(2,ip4),xyz(3,ip4)
  129. xbar=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip3)+xyz(1,ip4))/4.
  130. ybar=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip3)+xyz(2,ip4))/4.
  131. zbar=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip3)+xyz(3,ip4))/4.
  132. * write (6,*) ' bary ',xbar,ybar,zbar
  133. xfac=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip3))/3.
  134. yfac=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip3))/3
  135. zfac=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip3))/3.
  136. xyz(1,nptmax+1)=xfac+0.1*(xbar-xfac)
  137. xyz(2,nptmax+1)=yfac+0.1*(ybar-yfac)
  138. xyz(3,nptmax+1)=zfac+0.1*(zbar-zfac)
  139. soltet=soltet.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,-1,-1,-1,-1)
  140. if (.not.soltet) return
  141. xfac=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip4))/3.
  142. yfac=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip4))/3
  143. zfac=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip4))/3.
  144. xyz(1,nptmax+1)=xfac+0.1*(xbar-xfac)
  145. xyz(2,nptmax+1)=yfac+0.1*(ybar-yfac)
  146. xyz(3,nptmax+1)=zfac+0.1*(zbar-zfac)
  147. soltet=soltet.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,-1,-1,-1,-1)
  148. if (.not.soltet) return
  149. xfac=(xyz(1,ip2)+xyz(1,ip3)+xyz(1,ip4))/3.
  150. yfac=(xyz(2,ip2)+xyz(2,ip3)+xyz(2,ip4))/3
  151. zfac=(xyz(3,ip2)+xyz(3,ip3)+xyz(3,ip4))/3.
  152. xyz(1,nptmax+1)=xfac+0.1*(xbar-xfac)
  153. xyz(2,nptmax+1)=yfac+0.1*(ybar-yfac)
  154. xyz(3,nptmax+1)=zfac+0.1*(zbar-zfac)
  155. soltet=soltet.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,-1,-1,-1,-1)
  156. if (.not.soltet) return
  157. xfac=(xyz(1,ip3)+xyz(1,ip1)+xyz(1,ip4))/3.
  158. yfac=(xyz(2,ip3)+xyz(2,ip1)+xyz(2,ip4))/3
  159. zfac=(xyz(3,ip3)+xyz(3,ip1)+xyz(3,ip4))/3.
  160. xyz(1,nptmax+1)=xfac+0.1*(xbar-xfac)
  161. xyz(2,nptmax+1)=yfac+0.1*(ybar-yfac)
  162. xyz(3,nptmax+1)=zfac+0.1*(zbar-zfac)
  163. soltet=soltet.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,-1,-1,-1,-1)
  164. if (.not.soltet) return
  165. * test sur les facettes touchees
  166. * do 200 i=1,4
  167. * if (i.eq.1) ip=ip1
  168. * if (i.eq.2) ip=ip2
  169. * if (i.eq.3) ip=ip3
  170. * if (i.eq.4) ip=ip4
  171. * do 210 j=1,40
  172. * if=npf(j,ip)
  173. * if (if.eq.0) goto 200
  174. * iprob=0
  175. * do 220 k=1,3
  176. * jp=nfc(k,if)
  177. * if (npf(4,jp).ne.0.and.npf(5,jp).eq.0) iprob=iprob+1
  178. *220 continue
  179. * if (iprob.eq.3) soltet=.false.
  180. *210 continue
  181. *200 continue
  182. * if (.not.soltet) write (6,*) ' soltet nouveau test echoue'
  183. * test sur qualite
  184. * if (qualt(ip1,ip2,ip3,ip4).lt.5e-2) then
  185. * write (6,*) ' soltet qualite insuffisante '
  186. * soltet=.false.
  187. * endif
  188. RETURN
  189. C
  190. 120 CONTINUE
  191. C LE POINT I EST INTERNE AU VOLUME
  192. IF (IVERB.EQ.1) write (6,*) ' facettes ',if1,if2,if3,if4
  193. SOLTET=.FALSE.
  194. RETURN
  195. END
  196.  
  197.  
  198.  
  199.  
  200.  

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