Télécharger fuse.eso

Retour à la liste

Numérotation des lignes :

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

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