Télécharger redumo.eso

Retour à la liste

Numérotation des lignes :

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

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