Télécharger fuse.eso

Retour à la liste

Numérotation des lignes :

fuse
  1. C FUSE SOURCE CB215821 19/07/30 21:16:40 10273
  2. SUBROUTINE FUSE(IPT1,IPT2,IPT3,LTELQ)
  3. C=============================================================
  4. C
  5. C Ce sous-programme réalise l'operation "ET" sur les deux objets
  6. C maillages IPT1 et IPT2.
  7. C Le resultat est rangé dans IPT3
  8. C
  9. C=============================================================
  10. C
  11. C Modifications :
  12. C
  13. C PM 09/10/2007 : respecte l'ordre y compris avec éléments
  14. C dégénérés (points doubles)
  15. C CB215821 21/04/2015 : retrait des MAILLAGES vides éventuels durant
  16. C la fusion
  17. C
  18. C=============================================================
  19. C
  20. C Remarques :
  21. C
  22. C=============================================================
  23.  
  24. IMPLICIT INTEGER(I-N)
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC CCGEOME
  29. -INC SMELEME
  30. LOGICAL LTELQ
  31. SEGMENT ISO1(NBSOU1)
  32. SEGMENT ISO2(NBSOU2)
  33.  
  34. ITEMP=0
  35.  
  36. C Aiguillage
  37. C ----------
  38. C Cas de deux maillages identiques
  39. ** Rien de special, on fait la fusion. Si on souhaite autre chose, on utilise UNIQ.
  40. ** IF (IPT1.GT.0.AND.IPT2.EQ.IPT1) THEN
  41. ** IPT3 = IPT1
  42. ** RETURN
  43. ** ENDIF
  44.  
  45. C Deux maillages différents
  46. SEGACT IPT1,IPT2
  47. ISAUV1=IPT1
  48. ISAUV2=IPT2
  49.  
  50. C Premier maillage complexe
  51. IF (IPT1.LISOUS(/1).NE.0) GOTO 100
  52. C Seul le 2e maillage est complexe
  53. IF (IPT2.LISOUS(/1).NE.0) GOTO 101
  54. C Deux maillages simples
  55. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 50
  56.  
  57. C 1) Deux maillages simples de même type
  58. C --------------------------------------
  59. C CAS DES MULTIPLICATEURS: le nb de points par élément est différent
  60. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 50
  61.  
  62. C 1) Deux maillages simples de même type de même nb de points par élément
  63. IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 70
  64. C a) Deux objets de type ligne ou point
  65. CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
  66. GOTO 200
  67.  
  68. 70 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 71
  69. C b) Deux objets surfaciques
  70. CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
  71. GOTO 200
  72.  
  73. C c) Deux objets volumiques
  74. 71 CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
  75.  
  76. 200 RETURN
  77.  
  78. C 2) Deux maillages simples de type ou de nb d'éléments différents
  79. C ----------------------------------------------------------------
  80. 50 CONTINUE
  81. C Exclusion des MAILLAGES VIDES
  82. IF (IPT1.NUM(/2) .EQ. 0) THEN
  83. C Premier MAILLAGE VIDE
  84. C WRITE(IOIMP,*)'Premier MAILLAGE VIDE'
  85. SEGINI,IPT3=IPT2
  86. ELSEIF (IPT2.NUM(/2) .EQ. 0) THEN
  87. C Deuxieme MAILLAGE VIDE
  88. C WRITE(IOIMP,*)'Deuxieme MAILLAGE VIDE'
  89. SEGINI,IPT3=IPT1
  90. ELSE
  91. NBSOUS= 2
  92. NBREF = 0
  93. NBNN = 0
  94. NBELEM= 0
  95. SEGINI IPT3
  96. IPT3.LISOUS(1)=IPT1
  97. IPT3.LISOUS(2)=IPT2
  98. ENDIF
  99. RETURN
  100.  
  101. C 3) Un seul maillage complexe
  102. C ----------------------------
  103. C qu'on s'arrange pour être le deuxième,
  104. C mais ITEMP<>0 permet de savoir qu'on les a intervertis
  105. 100 CONTINUE
  106. IF (IPT2.LISOUS(/1).NE.0) GOTO 110
  107. ITEMP=IPT1
  108. IPT1=IPT2
  109. IPT2=ITEMP
  110. 101 CONTINUE
  111.  
  112. C Cas du 1er MAILLAGE VIDE, on renvoie IPT3 comme une copie de IPT2
  113. IF (IPT1.NUM(/2) .EQ. 0) THEN
  114. SEGINI,IPT3=IPT2
  115. RETURN
  116. ENDIF
  117.  
  118. NBSOU2=IPT2.LISOUS(/1)
  119. DO I=1,NBSOU2
  120. IPT3=IPT2.LISOUS(I)
  121. SEGACT IPT3
  122. IF (IPT3.NUM(/1).EQ.IPT1.NUM(/1)) THEN
  123. C une partition du bon type existe déjà
  124. IF (IPT3.ITYPEL.EQ.IPT1.ITYPEL) THEN
  125. IPT5=IPT1
  126. IPT6=IPT3
  127. if(ltelq)then
  128. IF (ITEMP.ne.0) THEN
  129. IPT5=IPT3
  130. IPT6=IPT1
  131. ENDIF
  132. endif
  133. GOTO 301
  134. ENDIF
  135. ENDIF
  136. ENDDO
  137. C on ajoute au 2e une partition avec ce nouveau type d'élément
  138. NBSOUS = NBSOU2+1
  139. NBREF = 0
  140. NBNN = 0
  141. NBELEM = 0
  142. SEGINI IPT3
  143. DO I=1,NBSOU2
  144. IPT3.LISOUS(I)=IPT2.LISOUS(I)
  145. ENDDO
  146. IPT3.LISOUS(NBSOUS)=IPT1
  147. RETURN
  148.  
  149. C On fusionne le 1er avec la partition existante du 2e
  150. 301 CONTINUE
  151. IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
  152. CALL FUSELI(IPT5,IPT6,IPT4,LTELQ)
  153. ELSEIF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
  154. CALL FUSESU(IPT5,IPT6,IPT4,LTELQ)
  155. ELSE
  156. CALL FUSEVO(IPT5,IPT6,IPT4,LTELQ)
  157. ENDIF
  158. NBSOUS = NBSOU2
  159. NBREF = 0
  160. NBNN = 0
  161. NBELEM = 0
  162. SEGINI IPT3
  163. DO II=1,NBSOU2
  164. IPT3.LISOUS(II)=IPT2.LISOUS(II)
  165. ENDDO
  166. IPT3.LISOUS(I)=IPT4
  167. RETURN
  168.  
  169. C 4) Deux maillages complexes
  170. C ---------------------------
  171. 110 CONTINUE
  172. NBSOU1=IPT1.LISOUS(/1)
  173. NBSOU2=IPT2.LISOUS(/1)
  174. NBSOUS=NBSOU1+NBSOU2
  175. SEGINI ISO1,ISO2
  176. DO I=1,NBSOU1
  177. ISO1(I)=IPT1.LISOUS(I)
  178. ENDDO
  179. DO I=1,NBSOU2
  180. ISO2(I)=IPT2.LISOUS(I)
  181. ENDDO
  182.  
  183. C-- Fusion des partitions de mêmes caractéristiques
  184. DO I1=1,NBSOU1
  185. IPT1=ISO1(I1)
  186. SEGACT IPT1
  187. DO 311 I2=1,NBSOU2
  188. SEGACT IPT1
  189. IPT2=ISO2(I2)
  190. IF (IPT2.EQ.0) GOTO 311
  191. SEGACT IPT2
  192. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 312
  193. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 312
  194. C On peut fusionner
  195. IF (KSURF(IPT1.ITYPEL).EQ.0)
  196. # CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
  197. IF (KSURF(IPT1.ITYPEL).NE.0.AND.
  198. # KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL)
  199. # CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
  200. IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL)
  201. $ CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
  202. ISO1(I1)=IPT3
  203. ISO2(I2)=0
  204. NBSOUS=NBSOUS-1
  205. 312 CONTINUE
  206. 311 CONTINUE
  207. ENDDO
  208.  
  209. C-- Gestion des sous-références (en évitant les redondances)
  210. NBREF = 0
  211. IPT1 = ISAUV1
  212. IPT2 = ISAUV2
  213. SEGACT IPT1,IPT2
  214. C POUR LE CAS DES VOLUMES ET DES SURFACES SI UN DES DEUX UNE SEULE
  215. C REFERENCE ON FAIT LA DIFFERENCE SYMETRIQUE
  216. C SI LES DEUX 2 OU 3 REFERENCE 1<-1.1 2<-2.2 3<-DIFF DES AUTRES
  217. C SI 1.2=2.1
  218. IF (IPT1.LISREF(/1).EQ.0.OR.IPT2.LISREF(/1).EQ.0) GOTO 1000
  219. IF (IPT1.LISREF(/1).EQ.1.OR.IPT2.LISREF(/1).EQ.1) THEN
  220. NBREF=1
  221. GOTO 1001
  222. ENDIF
  223. C Chaque maillage a au moins deux sous-références
  224. IPT3=IPT1.LISREF(2)
  225. IPT4=IPT2.LISREF(1)
  226. IF (IPT3.EQ.IPT4) GOTO 1002
  227. SEGACT IPT3,IPT4
  228. IF (IPT3.LISOUS(/1).EQ.0 .OR.
  229. # IPT3.LISOUS(/1).NE.IPT4.LISOUS(/1)) GOTO 1001
  230. DO I=1,IPT3.LISOUS(/1)
  231. IF (IPT3.LISOUS(I).NE.IPT4.LISOUS(I)) GOTO 1001
  232. ENDDO
  233.  
  234. 1002 CONTINUE
  235. C Deux sous-réf. chaque dont au moins 1 commune
  236. NBREF=3
  237. IF (IPT1.LISREF(/1).EQ.2 .OR. IPT2.LISREF(/1).EQ.2) THEN
  238. NBREF=2
  239. GOTO 1011
  240. ENDIF
  241. C A REVOIR NE MARCHE QUE SI LE POURTOUR EST FORME D'UN TYPE D'ELEMENT
  242. IPT3=IPT1.LISREF(3)
  243. SEGACT IPT3
  244. IF (IPT1.LISREF(/1).EQ.3) GOTO 1004
  245. DO 1005 I=4,IPT1.LISREF(/1)
  246. IPT4=IPT1.LISREF(I)
  247. SEGACT IPT4
  248. IF (IPT4.NUM(/2).NE.0) GOTO 1006
  249. NBREF=2
  250. GOTO 1011
  251. 1006 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT3,IPT4,IPT5,LTELQ)
  252. IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT3,IPT4,IPT5,LTELQ)
  253. IPT3=IPT5
  254. 1005 CONTINUE
  255. 1004 CONTINUE
  256. IPT6=IPT2.LISREF(3)
  257. SEGACT IPT6
  258. IF (IPT2.LISREF(/1).EQ.3) GOTO 1010
  259. DO 1009 I=4,IPT2.LISREF(/1)
  260. IPT4=IPT2.LISREF(I)
  261. SEGACT IPT4
  262. IF (IPT4.NUM(/2).NE.0) GOTO 1008
  263. NBREF=2
  264. GOTO 1011
  265. 1008 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT6,IPT4,IPT5,LTELQ)
  266. IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT6,IPT4,IPT5,LTELQ)
  267. IPT6=IPT5
  268. 1009 CONTINUE
  269. 1010 CONTINUE
  270. CALL OUEXCL(IPT3,IPT6,IPT7)
  271. GOTO 1011
  272.  
  273. 1001 CONTINUE
  274. C ON EST SENSE TOUT FUSIONNER A VOIR PLUS TARD
  275. NBREF=0
  276.  
  277. 1011 CONTINUE
  278.  
  279. C-- Construction du maillage final et de ses sous-références
  280. 1000 CONTINUE
  281. NBNN = 0
  282. NBELEM = 0
  283. SEGINI IPT3
  284. DO I=1,NBSOU1
  285. IPT3.LISOUS(I)=ISO1(I)
  286. ENDDO
  287. II=NBSOU1+1
  288. DO 112 I=1,NBSOU2
  289. C on n'ajoute que les partitions n'existant pas encore
  290. IF (ISO2(I).EQ.0) GOTO 112
  291. IPT3.LISOUS(II)=ISO2(I)
  292. II=II+1
  293. 112 CONTINUE
  294. SEGSUP ISO1,ISO2
  295.  
  296. IF (NBREF.EQ.0) GOTO 1020
  297. IPT3.LISREF(1)=IPT1.LISREF(1)
  298. IPT3.LISREF(2)=IPT2.LISREF(2)
  299. IF (NBREF.EQ.2) GOTO 1020
  300. IPT3.LISREF(3)=IPT7
  301.  
  302. 1020 RETURN
  303.  
  304. END
  305.  
  306.  
  307.  

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