Télécharger redumo.eso

Retour à la liste

Numérotation des lignes :

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

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