Télécharger solpyr.eso

Retour à la liste

Numérotation des lignes :

  1. C SOLPYR SOURCE PV 17/09/12 21:15:03 9542
  2. C---------------------------------------------------------------------|
  3. C |
  4. LOGICAL FUNCTION SOLPYR(IF1,IF2,IF3,IF4,IF5)
  5. C |
  6. C CETTE FONCTION LOGIQUE TESTE SI LA PYRAMIDE DECRIT PAR LES |
  7. C FACETTES IF1..IF5 EST VIDE DE POINT. |
  8. C LES ENTIERS N1..N5 INDIQUENT L'ORIENTATION DES FACETTES |
  9. C SOLPYR EST VRAI SI LA PYRAMIDE EST VIDE (DONC VALIDE) |
  10. C SOLPYR EST FAUX SI LA PYRAMIDE 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. -INC CCOPTIO
  18. -INC TDEMAIT
  19. LOGICAL FACET3,FACET2,vervol
  20. dimension ift(5)
  21. ift(1)=if1
  22. ift(2)=if2
  23. ift(3)=if3
  24. ift(4)=if4
  25. ift(5)=if5
  26. C
  27. C CHERCHER SI LES FACETTES SONT NOUVELLES OU ANCIENNES
  28. N1=-1
  29. N2=-1
  30. N3=-1
  31. N4=-1
  32. N5=-1
  33. IF (IFAT(IF1).NE.0) N1=1
  34. IF (IFAT(IF2).NE.0) N2=1
  35. IF (IFAT(IF3).NE.0) N3=1
  36. IF (IFAT(IF4).NE.0) N4=1
  37. IF (IFAT(IF5).NE.0) N5=1
  38. 10 CONTINUE
  39. * encadrer l'hexaedre
  40. xmin=1e30
  41. xmax=-1e30
  42. ymin=1e30
  43. ymax=-1e30
  44. zmin=1e30
  45. zmax=-1e30
  46. do 92 j=1,5
  47. do 90 i=1,3
  48. xmin=min(xmin,xyz(1,nfc(i,ift(j))))
  49. xmax=max(xmax,xyz(1,nfc(i,ift(j))))
  50. ymin=min(ymin,xyz(2,nfc(i,ift(j))))
  51. ymax=max(ymax,xyz(2,nfc(i,ift(j))))
  52. zmin=min(zmin,xyz(3,nfc(i,ift(j))))
  53. zmax=max(zmax,xyz(3,nfc(i,ift(j))))
  54. 90 continue
  55. 92 continue
  56. iteste=0
  57. * DO 100 I=1,NPTMAX
  58. DO 100 I=1,0
  59. IF (NPF(1,I).EQ.0) GOTO 100
  60. DO 110 J=1,4
  61. IF (I.EQ.NFC(J,IF1)) GOTO 100
  62. IF (I.EQ.NFC(J,IF2)) GOTO 100
  63. IF (I.EQ.NFC(J,IF3)) GOTO 100
  64. IF (I.EQ.NFC(J,IF4)) GOTO 100
  65. IF (I.EQ.NFC(J,IF5)) GOTO 100
  66. 110 CONTINUE
  67. if (iteste.ne.0) then
  68. if (xyz(1,i).lt.xmin.or.xyz(1,i).gt.xmax) goto 100
  69. if (xyz(2,i).lt.ymin.or.xyz(2,i).gt.ymax) goto 100
  70. if (xyz(3,i).lt.zmin.or.xyz(3,i).gt.zmax) goto 100
  71. endif
  72. iteste=1
  73. C
  74. V1=N1*VOL(I,NFC(1,IF1),NFC(2,IF1),NFC(3,IF1))
  75. V2=N1*VOL(I,NFC(1,IF1),NFC(3,IF1),NFC(4,IF1))
  76. V3=N2*VOL(I,NFC(1,IF2),NFC(2,IF2),NFC(3,IF2))
  77. V4=N3*VOL(I,NFC(1,IF3),NFC(2,IF3),NFC(3,IF3))
  78. V5=N4*VOL(I,NFC(1,IF4),NFC(2,IF4),NFC(3,IF4))
  79. V6=N5*VOL(I,NFC(1,IF5),NFC(2,IF5),NFC(3,IF5))
  80. VV=V1+V2+V3+V4+V5+V6
  81. IF (VV.LE.0.) then
  82. if(IVERB.EQ.1) write (6,*) ' pyramide volume negatif '
  83. solpyr=.false.
  84. return
  85. GOTO 120
  86. endif
  87. IF (V1.LE.-0.01*VV) GOTO 100
  88. IF (V2.LE.-0.01*VV) GOTO 100
  89. IF (V3.LE.-0.01*VV) GOTO 100
  90. IF (V4.LE.-0.01*VV) GOTO 100
  91. IF (V5.LE.-0.01*VV) GOTO 100
  92. IF (V6.LE.-0.01*VV) GOTO 100
  93. GOTO 120
  94. C
  95. C
  96. 100 CONTINUE
  97. C
  98. C IL N'EXISTE PAS DE POINTS INTERNES AU VOLUME
  99. SOLPYR=.TRUE.
  100. C RAJOUT PV TEST INTERSECTION DES FACETTES
  101. IF (N1.EQ.1) SOLPYR=SOLPYR.AND.FACET2(IF1)
  102. IF (.NOT.SOLPYR) RETURN
  103. IF (N2.EQ.1) SOLPYR=SOLPYR.AND.FACET2(IF2)
  104. IF (.NOT.SOLPYR) RETURN
  105. IF (N3.EQ.1) SOLPYR=SOLPYR.AND.FACET2(IF3)
  106. IF (.NOT.SOLPYR) RETURN
  107. IF (N4.EQ.1) SOLPYR=SOLPYR.AND.FACET2(IF4)
  108. IF (.NOT.SOLPYR) RETURN
  109. IF (N5.EQ.1) SOLPYR=SOLPYR.AND.FACET2(IF5)
  110. IF (.NOT.SOLPYR) RETURN
  111. C
  112. C on teste maintenant qu'on ne recouvre pas un autre volume
  113. ip1=nfc(1,if1)
  114. ip2=nfc(2,if1)
  115. ip3=nfc(3,if1)
  116. ip4=nfc(4,if1)
  117. ip5=nfc(1,if2)
  118. if (ip5.eq.ip1.or.ip5.eq.ip2.or.ip5.eq.ip3.or.ip5.eq.ip4)
  119. * ip5=nfc(2,if2)
  120. if (ip5.eq.ip1.or.ip5.eq.ip2.or.ip5.eq.ip3.or.ip5.eq.ip4)
  121. * ip5=nfc(3,if2)
  122. * write (6,*) ' solpyr sommets ',ip1,ip2,ip3,ip4,ip5
  123. * write (6,*) ' solpyr coordonnees '
  124. * write (6,*) xyz(1,ip1),xyz(2,ip1),xyz(3,ip1)
  125. * write (6,*) xyz(1,ip2),xyz(2,ip2),xyz(3,ip2)
  126. * write (6,*) xyz(1,ip3),xyz(2,ip3),xyz(3,ip3)
  127. * write (6,*) xyz(1,ip4),xyz(2,ip4),xyz(3,ip4)
  128. * write (6,*) xyz(1,ip5),xyz(2,ip5),xyz(3,ip5)
  129. xbar=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip3)+xyz(1,ip4)+xyz(1,ip5))/5.
  130. ybar=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip3)+xyz(2,ip4)+xyz(2,ip5))/5.
  131. zbar=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip3)+xyz(3,ip4)+xyz(3,ip5))/5.
  132. * write (6,*) ' bary ',xbar,ybar,zbar
  133. xfac=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip3)+xyz(1,ip4))/4.
  134. yfac=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip3)+xyz(2,ip4))/4.
  135. zfac=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip3)+xyz(3,ip4))/4.
  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. solpyr=solpyr.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,ip5,-1,-1,-1)
  140. if (.not.solpyr) return
  141. xfac=(xyz(1,ip1)+xyz(1,ip2)+xyz(1,ip5))/3.
  142. yfac=(xyz(2,ip1)+xyz(2,ip2)+xyz(2,ip5))/3.
  143. zfac=(xyz(3,ip1)+xyz(3,ip2)+xyz(3,ip5))/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. solpyr=solpyr.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,ip5,-1,-1,-1)
  148. if (.not.solpyr) return
  149. xfac=(xyz(1,ip2)+xyz(1,ip3)+xyz(1,ip5))/3.
  150. yfac=(xyz(2,ip2)+xyz(2,ip3)+xyz(2,ip5))/3.
  151. zfac=(xyz(3,ip2)+xyz(3,ip3)+xyz(3,ip5))/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. solpyr=solpyr.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,ip5,-1,-1,-1)
  156. if (.not.solpyr) return
  157. xfac=(xyz(1,ip3)+xyz(1,ip4)+xyz(1,ip5))/3.
  158. yfac=(xyz(2,ip3)+xyz(2,ip4)+xyz(2,ip5))/3.
  159. zfac=(xyz(3,ip3)+xyz(3,ip4)+xyz(3,ip5))/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. solpyr=solpyr.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,ip5,-1,-1,-1)
  164. if (.not.solpyr) return
  165. xfac=(xyz(1,ip4)+xyz(1,ip1)+xyz(1,ip5))/3.
  166. yfac=(xyz(2,ip4)+xyz(2,ip1)+xyz(2,ip5))/3.
  167. zfac=(xyz(3,ip4)+xyz(3,ip1)+xyz(3,ip5))/3.
  168. xyz(1,nptmax+1)=xfac+0.1*(xbar-xfac)
  169. xyz(2,nptmax+1)=yfac+0.1*(ybar-yfac)
  170. xyz(3,nptmax+1)=zfac+0.1*(zbar-zfac)
  171. solpyr=solpyr.and.vervol(nptmax+1,ip1,ip2,ip3,ip4,ip5,-1,-1,-1)
  172. if (.not.solpyr) return
  173. RETURN
  174. C
  175. 120 CONTINUE
  176. C LE POINT I EST INTERNE AU VOLUME
  177. IF (IVERB.EQ.1) WRITE(6,1010)I
  178. 1010 FORMAT(' LE POINT ',I5,' EST INTERNE A la pyramide CREEe')
  179. IF (IVERB.EQ.1) write (6,*) xyz(1,i),xyz(2,i),xyz(3,i)
  180. SOLPYR=.FALSE.
  181. RETURN
  182. END
  183.  
  184.  
  185.  
  186.  
  187.  

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