Télécharger j3surf.eso

Retour à la liste

Numérotation des lignes :

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

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