Télécharger fuse.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSE SOURCE CB215821 18/09/27 21:15:24 9936
  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. C SEGDES,IPT1,IPT2
  99. SEGACT,IPT3*NOMOD
  100. RETURN
  101.  
  102. C 3) Un seul maillage complexe
  103. C ----------------------------
  104. C qu'on s'arrange pour être le deuxième,
  105. C mais ITEMP<>0 permet de savoir qu'on les a intervertis
  106. 100 CONTINUE
  107. IF (IPT2.LISOUS(/1).NE.0) GOTO 110
  108. ITEMP=IPT1
  109. IPT1=IPT2
  110. IPT2=ITEMP
  111. 101 CONTINUE
  112.  
  113. C Cas du 1er MAILLAGE VIDE, on renvoie IPT3 comme une copie de IPT2
  114. IF (IPT1.NUM(/2) .EQ. 0) THEN
  115. SEGINI,IPT3=IPT2
  116. C SEGDES IPT1,IPT2
  117. SEGACT,IPT3*NOMOD
  118. RETURN
  119. ENDIF
  120.  
  121. NBSOU2=IPT2.LISOUS(/1)
  122. DO I=1,NBSOU2
  123. IPT3=IPT2.LISOUS(I)
  124. SEGACT IPT3
  125. IF (IPT3.NUM(/1).EQ.IPT1.NUM(/1)) THEN
  126. C une partition du bon type existe déjà
  127. IF (IPT3.ITYPEL.EQ.IPT1.ITYPEL) THEN
  128. IPT5=IPT1
  129. IPT6=IPT3
  130. if(ltelq)then
  131. IF (ITEMP.ne.0) THEN
  132. IPT5=IPT3
  133. IPT6=IPT1
  134. ENDIF
  135. endif
  136. GOTO 301
  137. ENDIF
  138. ENDIF
  139. C SEGDES IPT3
  140. ENDDO
  141. C on ajoute au 2e une partition avec ce nouveau type d'élément
  142. NBSOUS = NBSOU2+1
  143. NBREF = 0
  144. NBNN = 0
  145. NBELEM = 0
  146. SEGINI IPT3
  147. DO I=1,NBSOU2
  148. IPT3.LISOUS(I)=IPT2.LISOUS(I)
  149. ENDDO
  150. IPT3.LISOUS(NBSOUS)=IPT1
  151. C SEGDES IPT1,IPT2
  152. SEGACT,IPT3*NOMOD
  153. RETURN
  154.  
  155. C On fusionne le 1er avec la partition existante du 2e
  156. 301 CONTINUE
  157. IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
  158. CALL FUSELI(IPT5,IPT6,IPT4,LTELQ)
  159. ELSEIF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
  160. CALL FUSESU(IPT5,IPT6,IPT4,LTELQ)
  161. ELSE
  162. CALL FUSEVO(IPT5,IPT6,IPT4,LTELQ)
  163. ENDIF
  164. C SEGDES IPT1,IPT3
  165. SEGACT IPT4*NOMOD
  166. NBSOUS = NBSOU2
  167. NBREF = 0
  168. NBNN = 0
  169. NBELEM = 0
  170. SEGINI IPT3
  171. DO II=1,NBSOU2
  172. IPT3.LISOUS(II)=IPT2.LISOUS(II)
  173. ENDDO
  174. IPT3.LISOUS(I)=IPT4
  175. C SEGDES IPT2
  176. SEGACT,IPT3*NOMOD
  177. RETURN
  178.  
  179. C 4) Deux maillages complexes
  180. C ---------------------------
  181. 110 CONTINUE
  182. NBSOU1=IPT1.LISOUS(/1)
  183. NBSOU2=IPT2.LISOUS(/1)
  184. NBSOUS=NBSOU1+NBSOU2
  185. SEGINI ISO1,ISO2
  186. DO I=1,NBSOU1
  187. ISO1(I)=IPT1.LISOUS(I)
  188. ENDDO
  189. DO I=1,NBSOU2
  190. ISO2(I)=IPT2.LISOUS(I)
  191. ENDDO
  192. C SEGDES IPT1,IPT2
  193.  
  194. C-- Fusion des partitions de mêmes caractéristiques
  195. DO I1=1,NBSOU1
  196. IPT1=ISO1(I1)
  197. SEGACT IPT1
  198. DO 311 I2=1,NBSOU2
  199. SEGACT IPT1
  200. IPT2=ISO2(I2)
  201. IF (IPT2.EQ.0) GOTO 311
  202. SEGACT IPT2
  203. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 312
  204. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 312
  205. C On peut fusionner
  206. IF (KSURF(IPT1.ITYPEL).EQ.0)
  207. # CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
  208. IF (KSURF(IPT1.ITYPEL).NE.0.AND.
  209. # KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL)
  210. # CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
  211. IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL)
  212. $ CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
  213. ISO1(I1)=IPT3
  214. ISO2(I2)=0
  215. SEGACT,IPT3*NOMOD
  216. NBSOUS=NBSOUS-1
  217. 312 CONTINUE
  218. C SEGDES IPT2
  219. 311 CONTINUE
  220. C SEGDES IPT1
  221. ENDDO
  222.  
  223. C-- Gestion des sous-références (en évitant les redondances)
  224. NBREF = 0
  225. IPT1 = ISAUV1
  226. IPT2 = ISAUV2
  227. SEGACT IPT1,IPT2
  228. C POUR LE CAS DES VOLUMES ET DES SURFACES SI UN DES DEUX UNE SEULE
  229. C REFERENCE ON FAIT LA DIFFERENCE SYMETRIQUE
  230. C SI LES DEUX 2 OU 3 REFERENCE 1<-1.1 2<-2.2 3<-DIFF DES AUTRES
  231. C SI 1.2=2.1
  232. IF (IPT1.LISREF(/1).EQ.0.OR.IPT2.LISREF(/1).EQ.0) GOTO 1000
  233. IF (IPT1.LISREF(/1).EQ.1.OR.IPT2.LISREF(/1).EQ.1) THEN
  234. NBREF=1
  235. GOTO 1001
  236. ENDIF
  237. C Chaque maillage a au moins deux sous-références
  238. IPT3=IPT1.LISREF(2)
  239. IPT4=IPT2.LISREF(1)
  240. IF (IPT3.EQ.IPT4) GOTO 1002
  241. SEGACT IPT3,IPT4
  242. IF (IPT3.LISOUS(/1).EQ.0 .OR.
  243. # IPT3.LISOUS(/1).NE.IPT4.LISOUS(/1)) GOTO 1001
  244. DO I=1,IPT3.LISOUS(/1)
  245. IF (IPT3.LISOUS(I).NE.IPT4.LISOUS(I)) GOTO 1001
  246. ENDDO
  247. C SEGDES IPT3,IPT4
  248.  
  249. 1002 CONTINUE
  250. C Deux sous-réf. chaque dont au moins 1 commune
  251. NBREF=3
  252. IF (IPT1.LISREF(/1).EQ.2 .OR. IPT2.LISREF(/1).EQ.2) THEN
  253. NBREF=2
  254. GOTO 1011
  255. ENDIF
  256. C A REVOIR NE MARCHE QUE SI LE POURTOUR EST FORME D'UN TYPE D'ELEMENT
  257. IPT3=IPT1.LISREF(3)
  258. SEGACT IPT3
  259. IF (IPT1.LISREF(/1).EQ.3) GOTO 1004
  260. DO 1005 I=4,IPT1.LISREF(/1)
  261. IPT4=IPT1.LISREF(I)
  262. SEGACT IPT4
  263. IF (IPT4.NUM(/2).NE.0) GOTO 1006
  264. NBREF=2
  265. C SEGDES IPT4
  266. GOTO 1011
  267. 1006 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT3,IPT4,IPT5,LTELQ)
  268. IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT3,IPT4,IPT5,LTELQ)
  269. C SEGDES IPT3,IPT4
  270. IPT3=IPT5
  271. 1005 CONTINUE
  272. 1004 CONTINUE
  273. IPT6=IPT2.LISREF(3)
  274. SEGACT IPT6
  275. IF (IPT2.LISREF(/1).EQ.3) GOTO 1010
  276. DO 1009 I=4,IPT2.LISREF(/1)
  277. IPT4=IPT2.LISREF(I)
  278. SEGACT IPT4
  279. IF (IPT4.NUM(/2).NE.0) GOTO 1008
  280. NBREF=2
  281. C SEGDES IPT4
  282. GOTO 1011
  283. 1008 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT6,IPT4,IPT5,LTELQ)
  284. IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT6,IPT4,IPT5,LTELQ)
  285. C SEGDES IPT6,IPT4
  286. IPT6=IPT5
  287. 1009 CONTINUE
  288. 1010 CONTINUE
  289. CALL OUEXCL(IPT3,IPT6,IPT7)
  290. C SEGDES IPT3,IPT6
  291. SEGACT,IPT7*NOMOD
  292. GOTO 1011
  293.  
  294. 1001 CONTINUE
  295. C ON EST SENSE TOUT FUSIONNER A VOIR PLUS TARD
  296. NBREF=0
  297.  
  298. 1011 CONTINUE
  299.  
  300. C-- Construction du maillage final et de ses sous-références
  301. 1000 CONTINUE
  302. NBNN = 0
  303. NBELEM = 0
  304. SEGINI IPT3
  305. DO I=1,NBSOU1
  306. IPT3.LISOUS(I)=ISO1(I)
  307. ENDDO
  308. II=NBSOU1+1
  309. DO 112 I=1,NBSOU2
  310. C on n'ajoute que les partitions n'existant pas encore
  311. IF (ISO2(I).EQ.0) GOTO 112
  312. IPT3.LISOUS(II)=ISO2(I)
  313. II=II+1
  314. 112 CONTINUE
  315. SEGSUP ISO1,ISO2
  316.  
  317. IF (NBREF.EQ.0) GOTO 1020
  318. IPT3.LISREF(1)=IPT1.LISREF(1)
  319. IPT3.LISREF(2)=IPT2.LISREF(2)
  320. IF (NBREF.EQ.2) GOTO 1020
  321. IPT3.LISREF(3)=IPT7
  322.  
  323. 1020 SEGACT,IPT3*NOMOD
  324. C SEGDES IPT1,IPT2
  325. RETURN
  326.  
  327. END
  328.  
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.  

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