Télécharger fusmod.eso

Retour à la liste

Numérotation des lignes :

fusmod
  1. C FUSMOD SOURCE PASCAL 20/04/01 21:15:32 10568
  2.  
  3. SUBROUTINE FUSMOD(MODL1,MODL2,MODL)
  4.  
  5. *--------------------------------------------------------------------*
  6. * *
  7. * REUNION DE DEUX OBJETS MODELE *
  8. * *
  9. * ENTREES/SORTIE: *
  10. * *
  11. * MODL1 POINTEUR SUR LE PREMIER OBJET MODELE *
  12. * MODL2 POINTEUR SUR LE SECOND OBJET MODELE *
  13. * MODL POINTEUR SUR L'OBJET MODELE RESULTAT *
  14. * = 0 SINON *
  15. * *
  16. * AM 22/6/93 ON EXCLUT LA POSSIBILITE DE ZONE COMMUNE *
  17. * *
  18. *--------------------------------------------------------------------*
  19. *
  20. * - UNE ZONE ELEMENTAIRE EST DITE COMMUNE AUX DEUX "MODELE" SI:
  21. * LES GEOMETRIES ELEMENTAIRES
  22. * LES NOMS DE CONSTITUANTS
  23. * LES NUMEROS DES TYPES D'ELEMENTS-FINIS
  24. * LES INFMOD
  25. * LES FORMULATIONS
  26. * LES TYPES DE MATERIAUX
  27. * SONT LES MEMES.
  28. *
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31.  
  32. C Segment ICOPIE : indique les sous-zones (IMODEL) dupliquees
  33. SEGMENT ICOPIE(NCP1)
  34.  
  35.  
  36. -INC PPARAM
  37. -INC CCOPTIO
  38. -INC SMMODEL
  39. -INC SMELEME
  40. *
  41. CHARACTER*(LCONMO) CONM1,CONM2
  42. LOGICAL bXFEM
  43. *
  44. * INITIALISATION
  45. *
  46. MODL=0
  47. MMODE1=MODL1
  48. MMODE2=MODL2
  49. SEGACT,MMODE1,MMODE2
  50. NMOD1=MMODE1.KMODEL(/1)
  51. NMOD2=MMODE2.KMODEL(/1)
  52. *
  53. IF (IIMPI.EQ.666) THEN
  54. WRITE(IOIMP,*)'*** SOUS-PROGRAMME FUSMOD ***'
  55. WRITE(IOIMP,*)'NOMBRE DE ZONES ELEMENTAIRES : ',NMOD1
  56. WRITE(IOIMP,*)'NOMBRE DE ZONES ELEMENTAIRES : ',NMOD2
  57. ENDIF
  58. *
  59. DO 10 I10=1,NMOD1
  60. *
  61. * BOUCLE SUR LES ZONES ELEMENTAIRES DU 1ER "MODELE"
  62. *
  63. IMODE1=MMODE1.KMODEL(I10)
  64. SEGACT,IMODE1
  65. nefm1=IMODE1.NEFMOD
  66. ipma1=IMODE1.IMAMOD
  67. conm1=IMODE1.CONMOD
  68. *
  69. DO 20 I20=1,NMOD2
  70. *
  71. * BOUCLE SUR LES ZONES ELEMENTAIRES DU 2ND "MODELE"
  72. *
  73. IMODE2=MMODE2.KMODEL(I20)
  74. SEGACT,IMODE2
  75. nefm2=IMODE2.NEFMOD
  76. ipma2=IMODE2.IMAMOD
  77. conm2=IMODE2.CONMOD
  78. ckich quand la phase est identique et le type d element identique
  79. c c est tout ou rien
  80. IF (nefm1.EQ.nefm2 .AND. conm1.EQ.conm2 .AND.
  81. & imode1.formod(1).EQ.imode2.formod(1)) THEN
  82. iret = 0
  83. call interb(ipma1,ipma2,iret,iob1)
  84. if (iret.GT.0) goto 16
  85. ipt2 = ipma1
  86. ipt3 = ipma2
  87. ipt4 = iob1
  88. segact ipt2,ipt3,ipt4
  89. if (ipt2.num(/2).ne.ipt3.num(/2).or.
  90. & ipt2.num(/2).ne.ipt4.num(/2)) then
  91. call erreur(618)
  92. write(6,*) ' maillages non disjoints mais phase commune '
  93. goto 999
  94. endif
  95. ENDIF
  96. 16 IF (ipma1.NE.ipma2) GOTO 20
  97. *
  98. * ---- AM 22/6/93
  99. * ON VERIFIE QU'IL N'Y A PAS DE ZONE COMMUNE, C'EST A DIRE
  100. * QUE SI LES MAILLAGES SONT IDENTIQUES, LES CONSTITUANTS EUX
  101. * SONT DIFFERENTS
  102. *
  103. IF (conm1.EQ.conm2) THEN
  104. IF (nefm1.NE.nefm2) THEN
  105. CALL ERREUR(618)
  106. ELSE
  107. CALL ERREUR(617)
  108. ENDIF
  109. GO TO 999
  110. ENDIF
  111. * ----
  112. 20 CONTINUE
  113. * END DO
  114. 10 CONTINUE
  115. * END DO
  116. *
  117. N1=NMOD1+NMOD2
  118. SEGINI,MMODEL
  119. MODL=MMODEL
  120.  
  121. c write(6,*) ' ***** Dans FUSMOD !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
  122.  
  123. NCP1 = N1
  124. SEGINI, ICOPIE
  125. *
  126. * BOUCLE SUR LES ZONES GEOMETRIQUES DU 1ER "MODELE"
  127. *
  128. IF (IIMPI.EQ.666) THEN
  129. WRITE(IOIMP,*)'*** SOUS-PROGRAMME FUSMOD ***'
  130. WRITE(IOIMP,*)'BOUCLE SUR LES ZONES DU 1ER MODELE'
  131. ENDIF
  132. DO 50 IA=1,NMOD1
  133. IMODE1=MMODE1.KMODEL(IA)
  134. C SEGINI,IMODEL=imode1
  135. KMODEL(IA)=IMODE1
  136. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  137. nfor = IMODE1.formod(/2)
  138. c write(6,*) ' ***** nfor =',nfor
  139.  
  140. CALL PLACE (imode1.FORMOD,NFOR,IDARC,'DARCY')
  141. CALL PLACE (imode1.FORMOD,NFOR,IEULE,'EULER')
  142. CALL PLACE (imode1.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  143. IF ((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) THEN
  144. c write(6,*) ' ***** FUSMOD : je copie imode1'
  145. SEGINI,IMODEL=imode1
  146. KMODEL(IA)=IMODEL
  147. ICOPIE(IA) = 1
  148. IMODEL.INFMOD(2)=0
  149. ENDIF
  150. 50 CONTINUE
  151. * END DO
  152. *
  153. * BOUCLE SUR LES ZONES GEOMETRIQUES DU 2ND "MODELE"
  154. *
  155. IF (IIMPI.EQ.666) THEN
  156. WRITE(IOIMP,*)'*** SOUS-PROGRAMME FUSMOD ***'
  157. WRITE(IOIMP,*)'BOUCLE SUR LES ZONES DU 2ND MODELE'
  158. ENDIF
  159. DO 80 IB=1,NMOD2
  160. IMODE2=MMODE2.KMODEL(IB)
  161. C SEGINI,IMODEL=imode2
  162. KMODEL(IB+NMOD1)=IMODE2
  163.  
  164. C CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
  165. C et on duplique le segment IMODE1
  166. nfor = IMODE2.formod(/2)
  167. CALL PLACE (imode2.FORMOD,NFOR,IDARC,'DARCY')
  168. CALL PLACE (imode2.FORMOD,NFOR,IEULE,'EULER')
  169. CALL PLACE (imode2.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  170. IF ((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) THEN
  171. c write(6,*) ' ***** FUSMOD : je copie imode2'
  172. SEGINI,IMODEL=imode2
  173. KMODEL(IB+NMOD1)=IMODEL
  174. ICOPIE(IB+NMOD1) = 1
  175. IMODEL.INFMOD(2)=0
  176. ENDIF
  177. 80 CONTINUE
  178. * END DO
  179. *
  180. 999 CONTINUE
  181. IF (MODL.EQ.0) RETURN
  182. *
  183. * on va maintenant fusionner les zones geometriques de memes caracteristiques
  184. *
  185. do 100 i=1,kmodel(/1)
  186. imode1=kmodel(i)
  187. c* segact imode1
  188. if (imode1.eq.0) goto 100
  189. ipt1=imode1.imamod
  190. if (ipt1.eq.0) goto 100
  191. nefm1=imode1.nefmod
  192. conm1=imode1.conmod
  193. segact ipt1
  194. ityp1=ipt1.itypel
  195. bXFEM = NUMMFR(nefm1).EQ.63
  196. c* bXFEM = imode1.infele(13).EQ.63
  197. do 110 j=i+1,kmodel(/1)
  198. imode2=kmodel(j)
  199. if (imode2.eq.0) goto 110
  200. c* segact imode2
  201. if (imode2.nefmod.ne.nefm1) goto 110
  202. if (imode2.conmod.ne.conm1) goto 110
  203. ipt2=imode2.imamod
  204. segact ipt2
  205. if (ipt2.itypel.ne.ityp1) goto 110
  206. if (imode2.cmatee.ne.imode1.cmatee) goto 110
  207. ** if (imode2.infmod(/1).ne.imode1.infmod(/1)) goto 110
  208. ** do k=1,imode1.infmod(/1)
  209. ** if (imode2.infmod(k).ne.imode1.infmod(k)) goto 110
  210. ** enddo
  211. if (imode2.formod(/2).ne.imode1.formod(/2)) goto 110
  212. do k=1,imode1.formod(/2)
  213. if (imode2.formod(k).ne.imode1.formod(k)) goto 110
  214. enddo
  215. if (imode2.matmod(/2).ne.imode1.matmod(/2)) goto 110
  216. do k=1,imode1.matmod(/2)
  217. if (imode2.matmod(k).ne.imode1.matmod(k)) goto 110
  218. enddo
  219. ipdpg1 = imode1.ipdpge
  220. ipdpg2 = imode2.ipdpge
  221. if (ipdpg2.ne.ipdpg1) then
  222. if (iptpoi(ipdpg2).ne.iptpoi(ipdpg1)) goto 110
  223. endif
  224. if (imode2.inatuu.ne.imode1.inatuu) goto 110
  225. if (imode2.lnomid(/1).ne.imode1.lnomid(/1)) goto 110
  226. * BP, 2016-03-25 : ajout test car en sortie de RAFF
  227. * on a 2 ou 3 sous modeles identiques aux noms de composantes pres
  228.  
  229. IF (nefm1.eq.22) THEN
  230. do k=1,imode1.lnomid(/1)
  231. if (imode2.lnomid(k).ne.imode1.lnomid(k)) goto 110
  232. enddo
  233. ENDIF
  234. * GG : si deux sure de couleurs differentes pas de fusion
  235. IF (nefm1.eq.259) THEN
  236. if (ipt1.ICOLOR(1).ne.ipt2.ICOLOR(1)) goto 110
  237. ENDIF
  238. if (imode2.infele(/1).ne.imode1.infele(/1)) goto 110
  239. do k=1,imode1.infele(/1)
  240. if (imode2.infele(k).ne.imode1.infele(k)) goto 110
  241. enddo
  242. if (.NOT. bXFEM) then
  243. if (imode2.tymode(/2).ne.imode1.tymode(/2)) goto 110
  244. do k=1,imode1.tymode(/2)
  245. if (imode2.tymode(k).ne.imode1.tymode(k)) goto 110
  246. enddo
  247. if (imode2.ivamod(/1).ne.imode1.ivamod(/1)) goto 110
  248. do k=1,imode1.ivamod(/1)
  249. if (imode2.ivamod(k).ne.imode1.ivamod(k)) goto 110
  250. enddo
  251. endif
  252.  
  253. * fusion des meleme : on duplique le segment IMODE1
  254. IF (ICOPIE(i).EQ.0) THEN
  255. c write(6,*) ' ***** FUSMOD : je copie car fusion meleme '
  256. SEGINI, IMODEL = IMODE1
  257. KMODEL(i) = IMODEL
  258. IMODE1 = IMODEL
  259. ENDIF
  260. nbnn =ipt1.num(/1)
  261. nbel1=ipt1.num(/2)
  262. nbel2=ipt2.num(/2)
  263. nbelem=nbel1+nbel2
  264. nbref=0
  265. nbsous=0
  266. segini meleme
  267. itypel=ityp1
  268. do iel= 1,nbel1
  269. do ino=1,nbnn
  270. num(ino,iel)=ipt1.num(ino,iel)
  271. enddo
  272. icolor(iel)=ipt1.icolor(iel)
  273. enddo
  274. do iel =1,nbel2
  275. jel = iel+nbel1
  276. do ino =1,nbnn
  277. num(ino,jel)=ipt2.num(ino,iel)
  278. enddo
  279. icolor(jel)=ipt2.icolor(iel)
  280. enddo
  281. ipt1=meleme
  282. c* segact imode1*mod,imode2*mod
  283. imode1.imamod=ipt1
  284. IF (bXFEM) CALL FUCHXR(imode1,imode2,0)
  285. c* imode2.imamod=0
  286. c* segsup,imode2
  287. kmodel(j)=0
  288. 110 continue
  289. IF (bXFEM) CALL PARTXR(0,ipt1,imode1)
  290. 100 continue
  291. * desactivation & compactage du modele
  292. idec=0
  293. do 130 i=1,kmodel(/1)
  294. imode1=kmodel(i)
  295. if (imode1.eq.0) then
  296. idec=idec+1
  297. else
  298. kmodel(i-idec)=imode1
  299. endif
  300. 130 continue
  301. if (idec.gt.0) then
  302. n1=kmodel(/1)-idec
  303. segadj mmodel
  304. endif
  305.  
  306. SEGSUP,ICOPIE
  307.  
  308. END
  309.  
  310.  
  311.  
  312.  

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