Télécharger j3surf.eso

Retour à la liste

Numérotation des lignes :

  1. C J3SURF SOURCE CHAT 05/01/13 00:47:33 5004
  2. SUBROUTINE J3SURF(VWORK1,TOL)
  3. C----------------------------------------------------
  4. C ELIMINATION DES CAS TORDUS POUR SURF
  5. C
  6. C PP 9/97
  7. C Pierre Pegon/JRC Ispra
  8. C----------------------------------------------------
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11. DIMENSION XY(2)
  12. C
  13. -INC CCOPTIO
  14. C
  15. SEGMENT VWORK
  16. INTEGER FWWORK(NFACE)
  17. ENDSEGMENT
  18. POINTEUR VWORK1.VWORK
  19. C
  20. SEGMENT WWORK
  21. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  22. INTEGER FWORK
  23. INTEGER TWORK(NTROU)
  24. ENDSEGMENT
  25. C
  26. SEGMENT WORK
  27. REAL*8 XYC(2,NPTO)
  28. INTEGER IST(3,NPTO)
  29. REAL*8 DENS(NPTO)
  30. INTEGER JUN
  31. ENDSEGMENT
  32. POINTEUR WORK1.WORK, WORK2.WORK
  33. C
  34. C ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN
  35. C UN BLOCK COMPOSE DE FACE
  36. C
  37. NBLOCK=VWORK1.FWWORK(/1)
  38. C
  39. C ON BOUCLE SUR CHAQUE BLOCK
  40. C
  41. DO IE1=1,NBLOCK
  42. VWORK=VWORK1.FWWORK(IE1)
  43. NFACE=FWWORK(/1)
  44. C
  45. C ON BOUCLE SUR CHAQUE FACE
  46. C
  47. DO IE2=1,NFACE
  48. WWORK=FWWORK(IE2)
  49. NTROU=TWORK(/1)
  50. C
  51. C S'IL Y A DES TROUS, ON FAIT QUELQUE CHOSE ....
  52. C
  53. IF(NTROU.GT.0)THEN
  54. IF(IIMPI.EQ.1790)THEN
  55. WRITE(IOIMP,*)'J3SURF: FACE A TRAITER'
  56. CALL J3LIWW(WWORK)
  57. ENDIF
  58. C
  59. C S'IL Y A PLUSIEURS TROUS AVEC UN PT COMMUN, ON LES COHALESCE
  60. C
  61. IF(NTROU.GT.1)THEN
  62. C
  63. C A) SIMULATION DE "DO 10 IE3=1,NTROU-1" AVEC NTROU VARIABLE
  64. C
  65. IE3=0
  66. 1 IE3=IE3+1
  67. IF(IE3.GE.NTROU)GOTO 10
  68. WORK1=TWORK(IE3)
  69. NPTO1=WORK1.DENS(/1)
  70. C
  71. C B) BOUCLE SUR LES POINTS DU TROU QUE L'ON CHARGE DANS XY
  72. C
  73. DO IE4=1,NPTO1
  74. IPO1=IE4
  75. XY(1)=WORK1.XYC(1,IE4)
  76. XY(2)=WORK1.XYC(2,IE4)
  77. C
  78. C C) BOUCLE SUR LES TROUS RESTANTS
  79. C
  80. DO IE5=IE3+1,NTROU
  81. IF5=IE5
  82. WORK2=TWORK(IE5)
  83. NPTO2=WORK2.DENS(/1)
  84. CALL J3NOCO(XY,WORK2.XYC,NPTO2,TOL,IPO2)
  85. IF(IPO2.NE.0)GOTO 2
  86. ENDDO
  87. C
  88. ENDDO
  89. C
  90. GOTO 1
  91. C
  92. C D) COHALESCENCE DES TROUS WORK1 ET WORK2
  93. C
  94. 2 NPTO=NPTO1+NPTO2
  95. SEGADJ,WORK1
  96. DO IE4=NPTO,IPO1+NPTO2,-1
  97. WORK1.DENS(IE4)=WORK1.DENS(IE4-NPTO2)
  98. WORK1.XYC(1,IE4)=WORK1.XYC(1,IE4-NPTO2)
  99. WORK1.XYC(2,IE4)=WORK1.XYC(2,IE4-NPTO2)
  100. ENDDO
  101. DO IE4=IPO1,IPO1+NPTO2-1
  102. JE4=IE4-IPO1+IPO2
  103. IF(JE4.GT.NPTO2)JE4=JE4-NPTO2
  104. WORK1.DENS(IE4)=WORK2.DENS(JE4)
  105. WORK1.XYC(1,IE4)=WORK2.XYC(1,JE4)
  106. WORK1.XYC(2,IE4)=WORK2.XYC(2,JE4)
  107. ENDDO
  108. C
  109. C E) SUPPRESSION DE WORK2
  110. C
  111. SEGSUP,WORK2
  112. C
  113. C F) ON REPASSE DANS LA MOULINETTE EN REORGANISANT TWORK
  114. C
  115. IF(IF5.NE.NTROU)THEN
  116. DO IE4=IF5,NTROU-1
  117. TWORK(IE4)=TWORK(IE4+1)
  118. ENDDO
  119. ENDIF
  120. NTROU=NTROU-1
  121. SEGADJ,WWORK
  122. IE3=IE3-1
  123. GOTO 1
  124. C
  125. 10 CONTINUE
  126. C
  127. C FIN DU CAS A PLUSIEURS TROUS
  128. C
  129. ENDIF
  130. C
  131. C ON CONSIDERE MAINTENANT LE CONTOURS PRINCIPAL
  132. C
  133. WORK1=FWORK
  134. NPTO1=WORK1.DENS(/1)
  135. C
  136. C SI L'UN DES TROUS A UN POINT COMMUN, ON COHALESCE
  137. C
  138. C A) SIMULATION DE "DO 20 IE3=1,NTROU" AVEC NTROU VARIABLE
  139. C
  140. IE3=0
  141. 11 IE3=IE3+1
  142. IF(IE3.GT.NTROU)GOTO 20
  143. WORK2=TWORK(IE3)
  144. NPTO2=WORK2.DENS(/1)
  145. C
  146. C B) BOUCLE SUR LES POINTS DE WORK1 QUE L'ON CHARGE DANS XY
  147. C
  148. DO IE4=1,NPTO1
  149. IPO1=IE4
  150. XY(1)=WORK1.XYC(1,IE4)
  151. XY(2)=WORK1.XYC(2,IE4)
  152. CALL J3NOCO(XY,WORK2.XYC,NPTO2,TOL,IPO2)
  153. IF(IPO2.NE.0)GOTO 12
  154. ENDDO
  155. C
  156. GOTO 11
  157. C
  158. C C) COHALESCENCE DU TROU WORK2 AVEC WORK1
  159. C
  160. 12 NPTO=NPTO1+NPTO2
  161. SEGADJ,WORK1
  162. DO IE4=NPTO,IPO1+NPTO2,-1
  163. WORK1.DENS(IE4)=WORK1.DENS(IE4-NPTO2)
  164. WORK1.XYC(1,IE4)=WORK1.XYC(1,IE4-NPTO2)
  165. WORK1.XYC(2,IE4)=WORK1.XYC(2,IE4-NPTO2)
  166. ENDDO
  167. DO IE4=IPO1,IPO1+NPTO2-1
  168. JE4=IE4-IPO1+IPO2
  169. IF(JE4.GT.NPTO2)JE4=JE4-NPTO2
  170. WORK1.DENS(IE4)=WORK2.DENS(JE4)
  171. WORK1.XYC(1,IE4)=WORK2.XYC(1,JE4)
  172. WORK1.XYC(2,IE4)=WORK2.XYC(2,JE4)
  173. ENDDO
  174. C
  175. C D) SUPPRESSION DE WORK2
  176. C
  177. SEGSUP,WORK2
  178. C
  179. C E) ON REPASSE DANS LA MOULINETTE EN REORGANISANT TWORK
  180. C
  181. IF(IE3.NE.NTROU)THEN
  182. DO IE4=IE3,NTROU-1
  183. TWORK(IE4)=TWORK(IE4+1)
  184. ENDDO
  185. ENDIF
  186. NTROU=NTROU-1
  187. SEGADJ,WWORK
  188. IE3=IE3-1
  189. GOTO 11
  190. C
  191. 20 CONTINUE
  192. C
  193. C FIN DU CAS A TROU
  194. C
  195. IF(IIMPI.EQ.1790)THEN
  196. WRITE(IOIMP,*)'J3SURF: FACE APRES TRAITEMENT'
  197. CALL J3LIWW(WWORK)
  198. ENDIF
  199. ENDIF
  200. C
  201. C FIN BOUCLE FACE
  202. C
  203. ENDDO
  204. C
  205. C FIN BOUCLE BLOCK
  206. C
  207. ENDDO
  208. C
  209. RETURN
  210. END
  211.  
  212.  
  213.  

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