Télécharger diago.eso

Retour à la liste

Numérotation des lignes :

  1. C DIAGO SOURCE JC220346 16/11/29 21:15:12 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. LOGICAL FUNCTION DIAGO(IP,JP,XCRIT)
  5. C |
  6. C CETTE FONCTION LOGIQUE VERIFIE QUE LE SEGMENT >IP,JP! |
  7. C CREE EST VALIDE. |
  8. C -1- CE SEGMENT NE DOIT PAS ETRE LA DIAGONALE D'UNE |
  9. C FACETTE CARREE DEJA EXISTANTE. |
  10. C -2- CE SEGMENT NE DOIT PAS ETRE TROP LONG |
  11. C |
  12. C---------------------------------------------------------------------|
  13. C
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8(A-H,O-Z)
  16. -INC CCOPTIO
  17. -INC TDEMAIT
  18. LOGICAL REPONS,IN,in2,vervol
  19. C
  20. C WRITE(6,1000)
  21. C1000 FORMAT(' *** DIAGO ***')
  22. C
  23. REPONS=.FALSE.
  24. DIAGO=.FALSE.
  25. IFDIAG=0
  26. C
  27. C LE SEGMENT APPARTIENT-IL A UNE FACETTE CARREE ?
  28. C QUESTION SUBSIDIAIRE EXISTE-T-IL DEJA ??? |
  29. C -----------------------------------------------
  30. DO 100 I=1,40
  31. JF=NPF(I,IP)
  32. IF (JF.EQ.0) GOTO 200
  33. DO 110 J=1,40
  34. IF (NPF(J,JP).EQ.0) GOTO 100
  35. IF (JF.NE.NPF(J,JP)) GOTO 110
  36. * LE SEGMENT EST UNE ARETE D'UNE FACETTE TRIANGULAIRE ==> OK
  37. IF (NFC(4,JF).EQ.0) RETURN
  38. IF (IP.EQ.NFC(1,JF).AND.JP.EQ.NFC(3,JF)) REPONS=.TRUE.
  39. IF (IP.EQ.NFC(3,JF).AND.JP.EQ.NFC(1,JF)) REPONS=.TRUE.
  40. IF (IP.EQ.NFC(2,JF).AND.JP.EQ.NFC(4,JF)) REPONS=.TRUE.
  41. IF (IP.EQ.NFC(4,JF).AND.JP.EQ.NFC(2,JF)) REPONS=.TRUE.
  42. IF (REPONS) GOTO 200
  43. * LE SEGMENT EST UNE ARETE D'UNE FACETTE QUADRANGULAIRE ==> OK
  44. RETURN
  45. 110 CONTINUE
  46. 100 CONTINUE
  47. 200 CONTINUE
  48. C
  49. DIAGO=REPONS
  50. C
  51. IF (.NOT.REPONS) GOTO 300
  52. C
  53. IF (IVERB.EQ.1) WRITE(6,1010)IP,JP,JF,nfc(1,jf),nfc(2,jf),
  54. # nfc(3,jf)
  55. 1010 FORMAT(' LE SEGMENT >',I3,',',I3,'! APPARTIENT A LA FACETTE ',
  56. # I3,3i5)
  57. C
  58. RETURN
  59. *
  60. * TEST QUE L'ARETE N'EST PAS INSCRITE DANS UNE FACETTE
  61. *
  62. 300 CONTINUE
  63. * test pour voir si l'arete est dans le volume a mailler
  64. * premier test rapide par les volumes aux facettes issues du sommet
  65. * en cas d'echec test supplementaire
  66. DO 900 I=1,40
  67. JF=NPF(I,IP)
  68. IF (JF.EQ.0) GOTO 901
  69. if (vol(jp,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950
  70. if (nfc(4,jf).eq.0) goto 900
  71. if (vol(jp,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950
  72. 900 continue
  73. 901 continue
  74. DO 910 I=1,40
  75. JF=NPF(I,JP)
  76. IF (JF.EQ.0) GOTO 911
  77. if (vol(ip,nfc(1,jf),nfc(2,jf),nfc(3,jf)).gt.0.d0) goto 950
  78. if (nfc(4,jf).eq.0) goto 910
  79. if (vol(ip,nfc(1,jf),nfc(3,jf),nfc(4,jf)).gt.0.d0) goto 950
  80. 910 continue
  81. 911 continue
  82. goto 960
  83. 950 continue
  84. * write (6,*) ' tests complementaires '
  85. do 3 i=1,4
  86. xyz(i,nptmax+1)=0.99d0*xyz(i,ip)+0.01d0*xyz(i,jp)
  87. xyz(i,nptmax+2)=0.01d0*xyz(i,ip)+0.99d0*xyz(i,jp)
  88. 3 continue
  89. diago=.not.vervol(nptmax+1,ip,ip,-1,-1,-1,-1,-1,-1)
  90. if (diago) return
  91. diago=.not.vervol(nptmax+1,jp,jp,-1,-1,-1,-1,-1,-1)
  92. if (diago) return
  93. 960 continue
  94. XIP=XYZ(1,IP)
  95. YIP=XYZ(2,IP)
  96. ZIP=XYZ(3,IP)
  97. XJP=XYZ(1,JP)
  98. YJP=XYZ(2,JP)
  99. ZJP=XYZ(3,JP)
  100. DO 310 I=1,40
  101. IF=NPF(I,IP)
  102. IF (IF.EQ.0) GOTO 315
  103. II=ISUCC(IF,IP)
  104. IF (II.EQ.JP) GOTO 310
  105. JJ=IPRED(IF,IP)
  106. IF (JJ.EQ.JP) GOTO 310
  107. XII=XYZ(1,II)-XIP
  108. YII=XYZ(2,II)-YIP
  109. ZII=XYZ(3,II)-ZIP
  110. VII=SQRT(XII**2+YII**2+ZII**2)
  111. XII=XII/VII
  112. YII=YII/VII
  113. ZII=ZII/VII
  114. XJJ=XYZ(1,JJ)-XIP
  115. YJJ=XYZ(2,JJ)-YIP
  116. ZJJ=XYZ(3,JJ)-ZIP
  117. VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2)
  118. XJJ=XJJ/VJJ
  119. YJJ=YJJ/VJJ
  120. ZJJ=ZJJ/VJJ
  121. * (IP,JP)^(IP,II)
  122. XN1=(YJP-YIP)* ZII -(ZJP-ZIP)* YII
  123. YN1=(ZJP-ZIP)* XII -(XJP-XIP)* ZII
  124. ZN1=(XJP-XIP)* YII -(YJP-YIP)* XII
  125. VN1=SQRT(XN1**2+YN1**2+ZN1**2)
  126. * (IP,JP)^(IP,JJ)
  127. XN2=(YJP-YIP)* ZJJ -(ZJP-ZIP)* YJJ
  128. YN2=(ZJP-ZIP)* XJJ -(XJP-XIP)* ZJJ
  129. ZN2=(XJP-XIP)* YJJ -(YJP-YIP)* XJJ
  130. VN2=SQRT(XN2**2+YN2**2+ZN2**2)
  131. IF((XJP-XIP)*(XII+XJJ)+(YJP-YIP)*(YII+YJJ)+
  132. # (ZJP-ZIP)*(ZII+ZJJ).LT.0.d0) GOTO 310
  133. SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2
  134. IF (SCAL.LT.-xcrit*VN1*VN2) THEN
  135. if (iimpi.ne.0)
  136. > WRITE (6,*) ' DIAGO-1 ',IP,JP,' EST DANS ',IF,
  137. > nfc(1,if),nfc(2,if),nfc(3,if)
  138. DIAGO=.TRUE.
  139. ifdiag=if
  140. RETURN
  141. ENDIF
  142. 310 CONTINUE
  143. 315 CONTINUE
  144. DO 320 I=1,40
  145. IF=NPF(I,JP)
  146. IF (IF.EQ.0) GOTO 325
  147. II=ISUCC(IF,JP)
  148. IF (II.EQ.IP) GOTO 320
  149. JJ=IPRED(IF,JP)
  150. IF (JJ.EQ.IP) GOTO 320
  151. XII=XYZ(1,II)-XJP
  152. YII=XYZ(2,II)-YJP
  153. ZII=XYZ(3,II)-ZJP
  154. VII=SQRT(XII**2+YII**2+ZII**2)
  155. XII=XII/VII
  156. YII=YII/VII
  157. ZII=ZII/VII
  158. XJJ=XYZ(1,JJ)-XJP
  159. YJJ=XYZ(2,JJ)-YJP
  160. ZJJ=XYZ(3,JJ)-ZJP
  161. VJJ=SQRT(XJJ**2+YJJ**2+ZJJ**2)
  162. XJJ=XJJ/VJJ
  163. YJJ=YJJ/VJJ
  164. ZJJ=ZJJ/VJJ
  165. * (JP,IP)^(JP,II)
  166. XN1=(YIP-YJP)* ZII -(ZIP-ZJP)* YII
  167. YN1=(ZIP-ZJP)* XII -(XIP-XJP)* ZII
  168. ZN1=(XIP-XJP)* YII -(YIP-YJP)* XII
  169. VN1=SQRT(XN1**2+YN1**2+ZN1**2)
  170. * (JP,IP)^(JP,JJ)
  171. XN2=(YIP-YJP)* ZJJ -(ZIP-ZJP)* YJJ
  172. YN2=(ZIP-ZJP)* XJJ -(XIP-XJP)* ZJJ
  173. ZN2=(XIP-XJP)* YJJ -(YIP-YJP)* XJJ
  174. VN2=SQRT(XN2**2+YN2**2+ZN2**2)
  175. IF((XIP-XJP)*(XII+XJJ)+(YIP-YJP)*(YII+YJJ)+
  176. # (ZIP-ZJP)*(ZII+ZJJ).LT.0d0) GOTO 320
  177. SCAL=XN1*XN2+YN1*YN2+ZN1*ZN2
  178. IF (SCAL.LT.-xcrit*VN1*VN2) THEN
  179. if (iimpi.ne.0)
  180. > WRITE (6,*) ' DIAGO-2 ',JP,IP,' EST DANS ',IF,
  181. > nfc(1,if),nfc(2,if),nfc(3,if)
  182. ifdiag=if
  183. DIAGO=.TRUE.
  184. RETURN
  185. ENDIF
  186. 320 CONTINUE
  187. 325 CONTINUE
  188. * VERIFICATION DES DISTANCES AVEC LES AUTRES ARETES RENTRANTES
  189. * RECHERCHE SI ARETE EXISTE DEJA
  190. DO 500 I=1,40
  191. IF=NPF(I,IP)
  192. IF (IF.EQ.0) GOTO 501
  193. DO 502 J=1,40
  194. JF=NPF(J,JP)
  195. IF (JF.EQ.0) GOTO 500
  196. IF (IF.EQ.JF) GOTO 800
  197. 502 CONTINUE
  198. 500 CONTINUE
  199. 501 CONTINUE
  200. XP1=XYZ(1,IP)
  201. YP1=XYZ(2,IP)
  202. ZP1=XYZ(3,IP)
  203. XP2=XYZ(1,JP)
  204. YP2=XYZ(2,JP)
  205. ZP2=XYZ(3,JP)
  206. DP=(XP1-XP2)**2+(YP1-YP2)**2+(ZP1-ZP2)**2
  207. XP3=(XP1+XP2)/2.d0
  208. YP3=(YP1+YP2)/2.d0
  209. ZP3=(ZP1+ZP2)/2.d0
  210. * TEST AVEC LES AUTRES ARETES POSSIBLES
  211. goto 800
  212. do 520 ipt=ip,jp,jp-ip
  213. DO 510 I=1,40
  214. IF=NPF(I,IPT)
  215. if (IF.EQ.0) goto 520
  216. kp=isucc(if,ipt)
  217. IF (IP.EQ.KP) GOTO 510
  218. IF (JP.EQ.KP) GOTO 510
  219. do 511 J=1,40
  220. jf=npf(j,kp)
  221. if (jF.EQ.0) goto 510
  222. lp=isucc(jf,kp)
  223. IF (IP.EQ.LP) GOTO 511
  224. IF (JP.EQ.LP) GOTO 511
  225. XQ1=XYZ(1,KP)
  226. YQ1=XYZ(2,KP)
  227. ZQ1=XYZ(3,KP)
  228. XQ2=XYZ(1,LP)
  229. YQ2=XYZ(2,LP)
  230. ZQ2=XYZ(3,LP)
  231. DQ=(XQ1-XQ2)**2+(YQ1-YQ2)**2+(ZQ1-ZQ2)**2
  232. XQ3=(XQ1+XQ2)/2.d0
  233. YQ3=(YQ1+YQ2)/2.d0
  234. ZQ3=(ZQ1+ZQ2)/2.d0
  235. dmin=min(dp,dq)/64d0
  236. * DT=(XP1-XQ1)**2+(YP1-YQ1)**2+(ZP1-ZQ1)**2
  237. * IF (DT.LE.dmin) GOTO 810
  238. * DT=(XP1-XQ2)**2+(YP1-YQ2)**2+(ZP1-ZQ2)**2
  239. * IF (DT.LE.dmin) GOTO 810
  240. * DT=(XP1-XQ3)**2+(YP1-YQ3)**2+(ZP1-ZQ3)**2
  241. * IF (DT.LE.dmin) GOTO 810
  242. * DT=(XP2-XQ1)**2+(YP2-YQ1)**2+(ZP2-ZQ1)**2
  243. * IF (DT.LE.dmin) GOTO 810
  244. * DT=(XP2-XQ2)**2+(YP2-YQ2)**2+(ZP2-ZQ2)**2
  245. * IF (DT.LE.dmin) GOTO 810
  246. * DT=(XP2-XQ3)**2+(YP2-YQ3)**2+(ZP2-ZQ3)**2
  247. * IF (DT.LE.dmin) GOTO 810
  248. DT=(XP3-XQ1)**2+(YP3-YQ1)**2+(ZP3-ZQ1)**2
  249. IF (DT.LE.dmin) GOTO 810
  250. DT=(XP3-XQ2)**2+(YP3-YQ2)**2+(ZP3-ZQ2)**2
  251. IF (DT.LE.dmin) GOTO 810
  252. DT=(XP3-XQ3)**2+(YP3-YQ3)**2+(ZP3-ZQ3)**2
  253. IF (DT.LE.dmin) GOTO 810
  254. 511 continue
  255. 510 CONTINUE
  256. 520 CONTINUE
  257. 800 CONTINUE
  258. DIAGO=.FALSE.
  259. RETURN
  260. 810 CONTINUE
  261. DIAGO=.TRUE.
  262. IFDIAG=JF
  263. if (iimpi.ne.0)
  264. >WRITE (6,*) ' ARETE TROP PROCHES ',IP,JP,KP,LP,dt,dmin
  265. * WRITE (6,*) 'xp1,yp1,zp1 ',xp1,yp1,zp1
  266. * WRITE (6,*) 'xp2,yp2,zp2 ',xp2,yp2,zp2
  267. * WRITE (6,*) 'xp3,yp3,zp3 ',xp3,yp3,zp3
  268. * WRITE (6,*) 'xq1,yq1,zq1 ',xq1,yq1,zq1
  269. * WRITE (6,*) 'xq2,yq2,zq2 ',xq2,yq2,zq2
  270. * WRITE (6,*) 'xq3,yq3,zq3 ',xq3,yq3,zq3
  271. RETURN
  272. END
  273.  
  274.  
  275.  
  276.  

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