Télécharger redumo.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUMO SOURCE CB215821 19/04/18 21:15:09 10200
  2.  
  3. SUBROUTINE REDUMO (IPMODL,IMEL, IRET)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7. *______________________________________________________________________
  8. *
  9. * REDU D'UN MODELE SUR MELEME (APPELE PAR REDU)
  10. *
  11. * ENTREES :
  12. * ---------
  13. * IPMODL MODELE A REDUIRE (TYPE MMODEL)
  14. * IMEL MAILLAGE SUR LEQUEL ON DOIT REDUIRE (TYPE MELEME)
  15. *
  16. * SORTIE :
  17. * --------
  18. * IRET MODELE REDUIT
  19. * = 0 SI PB
  20. *
  21. * REMARQUE : ON SE LIMITE A NE POUVOIR REDUIRE UN MODELE QUE SUR
  22. * ---------- UN MAILLAGE POUR LEQUEL TOUS SES ELEMENTS "ADHERENT"
  23. * AU MODELE ET DE PLUS IL FAUT QU'A CHAQUE SOUS ZONE
  24. * DU MAILLAGE IMEL CORRESPONDE UNE SOUS ZONE DANS LE
  25. * MODELE (IE UNE SOUS ZONE DU MAILLAGE IMEL NE PEUT
  26. * ETRE "A CHEVAL" SUR PLUSIEURS SOUS ZONES DU MODELE)
  27. *
  28. * limitation levee par degay
  29. * si le maillage est a cheval sur plusieurs sous zones
  30. * on le tronconne en autant de morceaux
  31. *
  32. * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 11 90
  33. *
  34. *______________________________________________________________________
  35. *
  36. -INC CCOPTIO
  37. *
  38. -INC SMCOORD
  39. -INC SMELEME
  40. -INC SMMODEL
  41. *
  42. SEGMENT ICPR(NPT)
  43. SEGMENT ICOM(NBEL)
  44. SEGMENT ITRA1
  45. INTEGER ICC (IA+1)
  46. ENDSEGMENT
  47. segment itra2
  48. INTEGER IRE(ima)
  49. ENDSEGMENT
  50. LOGICAL INIT,DEJA
  51. *
  52. IRET=0
  53. *
  54. DEJA = .FALSE.
  55.  
  56.  
  57. * on duplique le maillage pour pouvoir le modifier si besoin est
  58. IPT1 = IMEL
  59. SEGACT,IPT1
  60. NBSOU1 = IPT1.LISOUS(/1)
  61.  
  62. NBELEM = 1
  63. IF (NBSOU1 .EQ. 0) THEN
  64. * Un MAILLAGE VIDE normalement constitue a un NBSOUS = 0
  65. NBELEM=IPT1.NUM(/2)
  66. ENDIF
  67.  
  68. * CB215821 : Reduire un MMODEL sur un MAILLAGE VIDE ==> MMODEL VIDE
  69. IF (NBELEM .EQ. 0) THEN
  70. N1 = 0
  71. SEGINI,MMODE1
  72. SEGACT,MMODE1*NOMOD,IPT1*NOMOD
  73. IRET = MMODE1
  74. RETURN
  75. ENDIF
  76. NBELEM = 0
  77.  
  78. *
  79. MMODEL = IPMODL
  80. SEGACT MMODEL
  81. SEGINI,MMODE1=MMODEL
  82. NSOUS=KMODEL(/1)
  83. * CB215821 : Reduire un MMODEL VIDE sur un MAILLAGE ==> MMODEL VIDE
  84. IF (NSOUS .EQ. 0) THEN
  85. SEGACT,MMODE1*NOMOD,IPT1*NOMOD
  86. IRET = MMODE1
  87. RETURN
  88. ENDIF
  89.  
  90. *
  91. * FABRICATION DE ICPR QUI DIRA SI UN POINT DU MODELE EST TOUCHE PAR
  92. * LE MAILLAGE IMEL ET SUR COMBIEN D'ELEMENTS ON VA TRAVAILLER PAR TYPE
  93. * D'ELEMENTS
  94. *
  95. NPT = XCOOR(/1)/(IDIM+1)
  96. ICPR = 0
  97. *
  98.  
  99.  
  100. MELEME = IPT1
  101. *
  102. * BOUCLE CONDITIONNNELLE SUR LES SOUS ZONES DU MAILLAGE IMEL
  103. *
  104. IBOU1 = 0
  105. NS01 = 0
  106. *
  107. 1 CONTINUE
  108. IBOU1 = IBOU1 + 1
  109. IF (NBSOU1.NE.0) THEN
  110. MELEME = IPT1.LISOUS(IBOU1)
  111. ENDIF
  112. SEGACT MELEME
  113. *
  114. * NNNT :NB D'ELEMENTS DE IMEL POUR LA SOUS ZONE CONSIDEREE
  115. NNNT=NUM(/2)
  116. *
  117. * Creation ou remise a zero du segment ICPR
  118. IF (ICPR.EQ.0) THEN
  119. SEGINI,ICPR
  120. ELSE
  121. DO i = 1, NPT
  122. ICPR(i) = 0
  123. ENDDO
  124. ENDIF
  125. *
  126. * CREATION D'UNE NUMEROTATION LOCALE
  127. *
  128. IA=0
  129. DO 3 J=1,NNNT
  130. DO 3 K=1,NUM(/1)
  131. ID=NUM(K,J)
  132. IF(ICPR(ID).NE.0) GO TO 3
  133. IA=IA+1
  134. ICPR(ID)=IA
  135. 3 CONTINUE
  136. *
  137. * FABRICATION DE ITRA1 puis 2 :
  138. * ICC DONNE LE NOMBRE D'ELEMENTS touchant le i eme noeud local
  139. *
  140. SEGINI ITRA1
  141. DO 8 J=1,NNNT
  142. DO 8 K=1,NUM(/1)
  143. ID=ICPR(NUM(K,J))
  144. ICC(ID)=ICC(ID)+1
  145. 8 CONTINUE
  146. *
  147. * fabrication de ire stocker les elements touchant le noeud i
  148. *
  149. igt=icc(1)
  150. DO 80 j=2,ia
  151. if( igt.lt.icc(j) ) igt = icc(j)
  152. icc(j)=icc(j)+icc(j-1)
  153. 80 CONTINUE
  154. ima = icc(ia)
  155. icc(ia+1) = ima
  156. * write(6,*) 'taille de ire ', ima, ia,igt
  157. segini itra2
  158. do 81 j=1,NNNT
  159. DO 81 k=1,num(/1)
  160. id=icpr(num(k,j))
  161. ie = icc(id)
  162. icc(id)=icc(id)-1
  163. ire(ie)= j
  164. 81 CONTINUE
  165. *
  166. * IL FAUT MAINTENANT REGARDER SI DANS UNE SOUS ZONE IMODEL IL
  167. * EXISTE LES ELEMENTS DE LA SOUS ZONE DU MELEME IMEL
  168. * BOUCLE SUR LES SOUS ZONES DU MODELE
  169. *
  170. IFLAG=0
  171. IMOD1=0
  172. DO 10 I=1,KMODEL(/1)
  173. SEGACT MELEME
  174. * write(6,*) ' boucle 10 ibou1 i', ibou1, i
  175. IMODEL=KMODEL(I)
  176. SEGACT IMODEL
  177. IPT2=IMAMOD
  178. SEGACT IPT2
  179. *
  180. IF(ITYPEL.NE.IPT2.ITYPEL) GO TO 11
  181. *
  182. INIT=.FALSE.
  183.  
  184. NBEL = NUM(/2)
  185. SEGINI ICOM
  186. *
  187. ICO=0
  188. NBEL2=IPT2.NUM(/1)
  189. DO 12 K=1,IPT2.NUM(/2)
  190. DO 13 L=1,NBEL2
  191. ID=IPT2.NUM(L,K)
  192. IDD = ICPR(ID)
  193. IF(IDD.EQ.0) GO TO 12
  194. 13 CONTINUE
  195. *
  196. ID =IPT2.NUM(1,K)
  197. IDD=ICPR(ID)
  198. IDE=ICC(IDD)+1
  199. *
  200. * OK L'ELEMENT K POSSEDE SES NOEUDS DANS IMEL
  201. *
  202. IF(ITYPEL.EQ.1) THEN
  203. IRE1=IRE(ide)
  204. GOTO 20
  205. ENDIF
  206. *
  207. * CES NOEUDS CORRESPONDENT-T-ILS A UN MEME ELEMENT IRE1
  208. *
  209. IDF=ICC(IDD+1)
  210. DO 14 L=IDE,IDF
  211. IRE1=IRE(L)
  212. DO 15 M=2,NBEL2
  213. IDD2=ICPR(IPT2.NUM(M,K))
  214. IF(IDD2.EQ.0) GO TO 12
  215. IDE2=ICC(IDD2)+1
  216. IDF2=ICC(IDD2+1)
  217. DO 16 N=IDE2,IDF2
  218. IF(IRE(N).EQ.IRE1) GO TO 15
  219. 16 CONTINUE
  220. GO TO 14
  221. 15 CONTINUE
  222. *
  223. * ON A TROUVE UN ELEMENT COMMUN AUX 2 MAILLAGES
  224. *
  225. GOTO 20
  226. 14 CONTINUE
  227. *
  228. GOTO 12
  229. *
  230. 20 CONTINUE
  231. IF (.NOT.INIT) INIT=.TRUE.
  232. IFLAG=1
  233. ICOM(IRE1)=1
  234. ICO=ICO+1
  235. 12 CONTINUE
  236. *
  237. IF (INIT) THEN
  238. *
  239. * LE NB D'ELEMENTS EST-IL EGAL POUR LA SOUS ZONE IMEL ET
  240. * LA SOUS ZONE DU MODELE
  241. *
  242. * print *, 'element en commun' ,'ico=',ico,'nnnt=',nnnt
  243. IF (ICO.EQ.NNNT) THEN
  244. NS01=NS01+1
  245. IF (NS01.GT.MMODE1.KMODEL(/1)) THEN
  246. ** CALL ERREUR(845)
  247. write(ioimp,*) 'Elements du maillage en double ?'
  248. MOTERR(1:8)='MAILLAGE'
  249. MOTERR(9:16)='MODELE'
  250. CALL ERREUR(135)
  251. SEGACT,IPT1*NOMOD
  252. SEGSUP MMODE1
  253. GOTO 901
  254. ENDIF
  255. IMOD1=IMOD1+1
  256. SEGINI,IMODE1=IMODEL
  257. C Dans le cas DARCY on ignore la table de préconditionnement afin de
  258. C pouvoir la recalculer correctement par la suite
  259. NFOR=IMODE1.FORMOD(/2)
  260. CALL PLACE (IMODE1.FORMOD,NFOR,IDARC,'DARCY')
  261. CALL PLACE (IMODE1.FORMOD,NFOR,IEULE,'EULER')
  262. CALL PLACE (IMODE1.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  263. IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))
  264. & IMODE1.INFMOD(2)=0
  265. MMODE1.KMODEL(NS01)=IMODE1
  266. IMODE1.IMAMOD=MELEME
  267. C* Cas particulier : Elements type XFEM
  268. IF (NUMMFR(IMODE1.NEFMOD).EQ.63)
  269. & CALL PARTXR(IMODEL,0,IMODE1)
  270. * write(6,*) ' meleme imamod ' , meleme
  271. *
  272. SEGACT,IMODE1*NOMOD
  273. ELSE
  274. *
  275. * IL FAUT SCINDER LE SOUS MAILAGE EN DEUX
  276. *
  277. * creation des deux maillages dont l'union est le maillage meleme
  278. NBNN = NUM(/1)
  279. NBELEM = ICO
  280. NBREF = 0
  281. NBSOUS = 0
  282. SEGINI IPT3
  283. NBELEM = NUM(/2) - ICO
  284. SEGINI IPT4
  285. IPT3.ITYPEL = ITYPEL
  286. IPT4.ITYPEL = ITYPEL
  287. I3 = 0
  288. I4 = 0
  289. DO 25 II=1,NUM(/2)
  290. IF (ICOM(II) .EQ. 1) THEN
  291. * l'element est commun aux deux maillages
  292. I3=I3+1
  293. IPT3.ICOLOR(I3)=ICOLOR(II)
  294. DO 23 JJ=1,NUM(/1)
  295. IPT3.NUM(JJ,I3)=NUM(JJ,II)
  296. 23 CONTINUE
  297. ELSE
  298. * l'element appartient seulement a meleme
  299. I4=I4+1
  300. IPT4.ICOLOR(I4)=ICOLOR(II)
  301. DO 24 JJ=1,NUM(/1)
  302. IPT4.NUM(JJ,I4)=NUM(JJ,II)
  303. 24 CONTINUE
  304. ENDIF
  305. 25 CONTINUE
  306. *
  307. * modification de ipt1
  308. *
  309. NBREF =0
  310. NBELEM=0
  311. NBNN =0
  312. IF (IPT1.LISOUS(/1) .EQ. 0) THEN
  313. NBSOUS=2
  314. SEGINI IPT5
  315. IPT5.LISOUS(1)=IPT3
  316. IPT5.LISOUS(2)=IPT4
  317. SEGACT,IPT1*NOMOD
  318. IPT1=IPT5
  319. ELSE
  320. IF (.NOT. DEJA) THEN
  321. SEGINI,IPT5=IPT1
  322. SEGACT,IPT1*NOMOD
  323. IPT1 = IPT5
  324. ENDIF
  325. NBSOUS=IPT1.LISOUS(/1)+1
  326. SEGADJ IPT1
  327. IPT1.LISOUS(IBOU1)=IPT3
  328. IPT1.LISOUS(NBSOUS)=IPT4
  329. SEGACT,MELEME*NOMOD
  330. ENDIF
  331. IBOU1=IBOU1-1
  332. NBSOU1=NBSOUS
  333. NS01=NS01-IMOD1
  334. SEGACT,IMODEL*NOMOD
  335. SEGSUP ICOM,ITRA1,ITRA2
  336. GOTO 1
  337. *
  338. ENDIF
  339. ENDIF
  340. SEGSUP ICOM
  341. 11 CONTINUE
  342. SEGACT,IMODEL*NOMOD
  343. 10 CONTINUE
  344. *
  345. SEGSUP,ITRA1,ITRA2
  346. C SEGDES,MELEME,IPT2
  347.  
  348. IF (IFLAG.EQ.0) THEN
  349. *
  350. * ON N'A PAS TROUVE DE SOUS ZONE DANS LE MODELE QUI COR-
  351. * RESPONDENT A UNE SOUS ZONE DE IMEL
  352. *
  353. MOTERR(1:8)='MAILLAGE'
  354. MOTERR(9:16)='MODELE'
  355. CALL ERREUR(135)
  356. SEGACT,IPT1*NOMOD
  357. SEGSUP MMODE1
  358. GOTO 901
  359. ENDIF
  360. *
  361. * FIN DE LA BOUCLE SUR LES SOUS ZONES DU MAILLAGE
  362. *
  363. ** print *, 'nbsou1=' , 'ibou1=' ,ibou1
  364. IF (IBOU1 .LT. NBSOU1 ) GOTO 1
  365. *
  366. SEGACT,IPT1*NOMOD
  367. ** print *,NS01,NSOUS
  368. IF(NS01.NE.NSOUS) THEN
  369. N1=NS01
  370. SEGADJ,MMODE1
  371. ENDIF
  372. IRET=MMODE1
  373. SEGACT,MMODE1*NOMOD
  374. 901 CONTINUE
  375. SEGACT,MMODEL*NOMOD
  376. C- Un peu de menage
  377. IF (ICPR.GT.0) SEGSUP,ICPR
  378.  
  379. END
  380.  
  381.  
  382.  

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