Télécharger numopt.eso

Retour à la liste

Numérotation des lignes :

  1. C NUMOPT SOURCE CB215821 16/09/30 21:15:09 9105
  2. C RACINE DE LA NUMEROTATION POUR LA SORTIE SUR FAC
  3. C
  4. SUBROUTINE NUMOPT(MELEME,ICPR,NODES)
  5. IMPLICIT INTEGER(I-N)
  6. -INC SMELEME
  7. -INC SMCOORD
  8. -INC CCOPTIO
  9. -INC CCPRECO
  10. CHARACTER*4 MVAL
  11. DATA MVAL/'NOOP'/
  12. SEGMENT MEMJT1(NKON)
  13. SEGMENT MEMJT2(NKON)
  14. SEGMENT IPOME(NODES+1)
  15. SEGMENT JNT(NODES)
  16. SEGMENT JMEM(NODES)
  17. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  18. SEGMENT ICPREN(XCOOR(/1)/(IDIM+1))
  19. SEGMENT IDCP(XCOOR(/1)/(IDIM+1))
  20. SEGMENT JOINT(NODES)
  21. SEGMENT NEWJT(NODES)
  22. icpren=0
  23. segact mcoord
  24. segact meleme
  25. * cas trivial ou le maillage est fait de points isoles
  26. CALL LIRMOT(MVAL,1,IRET,0)
  27. if (itypel.eq.1.or.iret.eq.1.or.nucrou.eq.-1) then
  28. segact icpr*MOD
  29. ia=0
  30. ipt1=meleme
  31. segact meleme
  32. do k=1,max(1,lisous(/1))
  33. if (lisous(/1).ne.0) ipt1=lisous(k)
  34. segact ipt1
  35. do j= ipt1.num(/2),1,-1
  36. do i=1,ipt1.num(/1)
  37. if (icpr(ipt1.num(i,j)).eq.0) then
  38. ia=ia+1
  39. icpr(ipt1.num(i,j))=ia
  40. endif
  41. enddo
  42. enddo
  43. enddo
  44. nodes=ia
  45. return
  46. endif
  47. nucro=0
  48. * si plus de 2000 noeuds dans le meleme numérotation NS
  49. segact icpr*mod
  50. do i=1,icpr(/1)
  51. icpr(i)=0
  52. enddo
  53. segact meleme
  54. ia=0
  55. ib=0
  56. ipt1=meleme
  57. ifrot=0
  58. do 60 isous=1,max(1,lisous(/1))
  59. if (lisous(/1).ne.0) ipt1=lisous(isous)
  60. segact ipt1
  61. if (ipt1.itypel.eq.-22) then
  62. * write (6,*) ' frottement '
  63. ifrot=1
  64. endif
  65. ib=max(ib,ipt1.num(/1))
  66. do 50 i=1,ipt1.num(/2)
  67. do 50 j=1,ipt1.num(/1)
  68. if (icpr(ipt1.num(j,i)).eq.0) then
  69. ia=ia+1
  70. icpr(ipt1.num(j,i))=ia
  71. endif
  72. 50 continue
  73. 60 continue
  74. if (ia.lt.ib*5 ) then
  75. * write (6,*) ' superelement detecte ',ia,ib
  76. ia=1
  77. endif
  78. do i=1,icpr(/1)
  79. icpr(i)=0
  80. enddo
  81. if (ia.gt.2000) then
  82. nucro=2
  83. izrosf=16
  84. endif
  85. if (ia.le.2000) nucro=0
  86. IF(NUCROU.EQ.1) nucro=0
  87. IF(NUCROU.EQ.2) nucro=2
  88. * en cas de frottement forcément nested dissection pour placer correctement les mult de frot
  89. if (ifrot.eq.1) nucro=2
  90. CALL LIRMOT(MVAL,1,IRET,0)
  91. if (iret.eq.0) then
  92. * a t'on deja fait l'operation ???
  93. segini icpren,idcp
  94. incren=0
  95. do isous=2,lisous(/1)
  96. ipt3=lisous(isous)
  97. segact ipt3
  98. * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans
  99. * l'ordre "usuel"
  100. do j=1,ipt3.num(/2)
  101. do i=1,ipt3.num(/1)
  102. ip=ipt3.num(i,j)
  103. if (icpren(ip).eq.0) then
  104. incren=incren+1
  105. icpren(ip)=incren
  106. endif
  107. enddo
  108. enddo
  109. enddo
  110. do i=1,icpren(/1)
  111. if (icpren(i).ne.0) idcp(icpren(i))=i
  112. enddo
  113.  
  114. do 150 ip=1,30
  115. if (prenum(ip).ne.0) then
  116. ipt1=prenum(ip)
  117. segact ipt1
  118. * write (6,*) ' prenum ',ip,lisous(/1),ipt1.lisous(/1)
  119. if (lisous(/1)+1.eq.ipt1.lisous(/1)) then
  120. *SG Attention ! On a osé stocker le type de renumérotation qui avait été
  121. *SG calculée dans le itypel
  122. ipt2=ipt1.lisous(ipt1.lisous(/1))
  123. segact ipt2
  124. nucroa=ipt2.itypel
  125. segdes ipt2
  126. if (nucro.ne.nucroa) goto 11
  127. * verif maillage identique
  128. * write (6,*) ' maillage 1 ',lisous(/1)
  129. * write (6,*) ' maillage 2 ',ipt1.lisous(/1)
  130. do isous=2,lisous(/1)
  131. ipt3=lisous(isous)
  132. ipt4=ipt1.lisous(isous)
  133. segact ipt3,ipt4
  134. * write (6,*) ipt3.num(/1),ipt4.num(/1),ipt3.num(/2),ipt4.num(/2)
  135. * write (6,*) ' itypel ',ipt3.itypel,ipt4.itypel
  136. if (ipt3.itypel.ne.ipt4.itypel) goto 10
  137. if (ipt3.num(/1).ne.ipt4.num(/1)) goto 10
  138. if (ipt3.num(/2).ne.ipt4.num(/2)) goto 10
  139. * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans
  140. * l'ordre "usuel"
  141. do j=1,ipt3.num(/2)
  142. do i=1,ipt3.num(/1)
  143. * write (6,*) i,j,ipt3.num(i,j),
  144. * > icpren(ipt3.num(i,j)),ipt4.num(i,j)
  145. if (icpren(ipt3.num(i,j)).ne.ipt4.num(i,j)) goto 10
  146. enddo
  147. enddo
  148. segdes ipt3,ipt4
  149. enddo
  150. if (iimpi.ne.0) write (6,*)
  151. > ' preconditionnement de la numerotation ',ip,
  152. > (prenum(i),i=1,30)
  153. ipt2=ipt1.lisous(ipt1.lisous(/1))
  154. segact ipt2
  155. segact icpr*MOD
  156. nodes=ipt2.num(/2)
  157. * write (6,*) ' icpr(/1),nodes ',icpr(/1),nodes
  158. do i=1,nodes
  159. if (idcp(ipt2.num(1,i)).ne.0) icpr(idcp(ipt2.num(1,i)))=i
  160. enddo
  161. ia=nodes
  162. segdes ipt1,ipt2
  163. * write (6,*) ' apres precond dans numopt '
  164. * write (6,*) (icpr(i),i=1,icpr(/1))
  165. return
  166.  
  167. 10 continue
  168. segdes ipt3,ipt4
  169. 11 continue
  170. endif
  171. endif
  172. 150 continue
  173. if (nucro.eq.1) then
  174. call numop1(MELEME,ICPR,NODES)
  175. goto 300
  176. endif
  177. if (nucro.eq.2) then
  178. call numop2(MELEME,ICPR,NODES)
  179. segact icpr*mod
  180. goto 300
  181. endif
  182. endif
  183. if (iret.eq.1) call refus
  184. IENORM=2000000000
  185. NODES=XCOOR(/1)/(IDIM+1)
  186. SEGACT ICPR*MOD
  187. SEGACT MELEME
  188. DO 200 I=1,ICPR(/1)
  189. 200 ICPR(I)=0
  190. IPT1=MELEME
  191. IKOU=0
  192. DO 202 IO=1,MAX(1,LISOUS(/1))
  193. IF (LISOUS(/1).NE.0) THEN
  194. IPT1=LISOUS(IO)
  195. SEGACT IPT1
  196. ENDIF
  197. DO 203 I=1,IPT1.NUM(/1)
  198. DO 203 J=1,IPT1.NUM(/2)
  199. IJ=IPT1.NUM(I,J)
  200. IF (ICPR(IJ).NE.0) GOTO 203
  201. IKOU=IKOU+1
  202. ICPR(IJ)=IKOU
  203. 203 CONTINUE
  204. 202 CONTINUE
  205. NODES=IKOU
  206. SEGINI JNT,JMEM,NEWJT,JOINT,IPOME
  207. DO 1 I=1,NODES
  208. 1 JMEM(I)=0
  209. IPT1=MELEME
  210. DO 3 IO=1,MAX(1,LISOUS(/1))
  211. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  212. DO 4 I=1,IPT1.NUM(/1)
  213. DO 4 J=1,IPT1.NUM(/2)
  214. JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1
  215. 4 CONTINUE
  216. 3 CONTINUE
  217. IPOME(1)=0
  218. DO 6 I=1,NODES
  219. IPOME(I+1)=IPOME (I) + JMEM(I)
  220. 6 CONTINUE
  221. NKON=IPOME(NODES+1)
  222. SEGINI MEMJT1,memjt2
  223. DO 90 J=1,NODES
  224. 90 JMEM(J)=0
  225. IPT1=MELEME
  226. DO 101 IO=1,MAX(1,LISOUS(/1))
  227. IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  228. DO 100 I=1,IPT1.NUM(/2)
  229. DO 100 J=1,IPT1.NUM(/1)
  230. IND=ICPR(IPT1.NUM(J,I))
  231. JMEM(IND)=JMEM(IND)+1
  232. MEMJT1(IPOME(IND)+JMEM(IND))=I
  233. MEMJT2(IPOME(IND)+JMEM(IND))=IO
  234. 100 CONTINUE
  235. 101 CONTINUE
  236. IDIFF=1
  237. CALL OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT,IDIFF,IPOME,
  238. # ICPR,NODES,NOOPTI)
  239. DO 110 I=1,NODES
  240. JNT(I)=NODES-JNT(I)+1
  241. 110 CONTINUE
  242. C PERMUTER LES COORDONNEES ET CORRIGER IPAD
  243. DO 111 I=1,icpr(/1)
  244. IF (ICPR(I).EQ.0) GOTO 111
  245. ICPR(I)=JNT(ICPR(I))
  246. 111 CONTINUE
  247. IF(NOOPTI .EQ.0) GO TO 116
  248. IA=0
  249. DO 115 I=1,icpr(/1)
  250. IF(ICPR(I).EQ.0) GO TO 115
  251. IA=IA+1
  252. ICPR(I)=IA
  253. 115 CONTINUE
  254. 116 CONTINUE
  255. SEGSUP MEMJT1,MEMJT2,JMEM,NEWJT,JOINT,IPOME
  256. SEGSUP JNT
  257. * Mise en commentaire du retuen par SG car comme cela on préconditionne
  258. * aussi le Cuthill-McKee
  259. * RETURN
  260. 300 continue
  261. * sauver le resultat au cas ou on veuille recommencer
  262. segini,ipt1=meleme
  263. nbsous=ipt1.lisous(/1)+1
  264. nbref=ipt1.lisref(/1)
  265. nbnn=ipt1.num(/1)
  266. nbelem=ipt1.num(/2)
  267. segadj ipt1
  268. nbnn=1
  269. nbsous=0
  270. nbref=0
  271. nbelem=nodes
  272. segini ipt2
  273. *SG Attention ! On ose stocker le type de renumérotation qui a été
  274. *SG calculée dans le itypel
  275. ipt2.itypel=nucro
  276. ia=0
  277. do 120 i=1,icpr(/1)
  278. if (icpr(i).gt.nodes.or.icpr(i).eq.0) goto 120
  279. ia=ia+1
  280. ipt2.num(1,icpr(i))=icpren(i)
  281. 120 continue
  282. * call ecmail(ipt2)
  283. ipt1.lisous(ipt1.lisous(/1))=ipt2
  284. segdes ipt2
  285. do 125 is=1,ipt1.lisous(/1)-1
  286. ipt2=ipt1.lisous(is)
  287. segini,ipt3=ipt2
  288. segdes ipt2
  289. * SG 2011/10/07 on a échangé l'ordre des boucles pour le remettre dans
  290. * l'ordre "usuel"
  291. do il=1,ipt3.num(/2)
  292. do ip=1,ipt3.num(/1)
  293. ipt3.num(ip,il)=icpren(ipt3.num(ip,il))
  294. enddo
  295. enddo
  296. segdes ipt3
  297. ipt1.lisous(is)=ipt3
  298. 125 continue
  299. if (ipt1.lisous(/1).eq.1) goto 131
  300. segdes ipt1
  301. do 130 ip=29,1,-1
  302. prenum(ip+1)=prenum(ip)
  303. 130 continue
  304. prenum(1)=ipt1
  305. 131 continue
  306. if (icpren.ne.0) segsup icpren,idcp
  307. segact icpr*mod
  308. * write (6,*) ' fin de numopt '
  309. * write (6,*) (icpr(i),i=1,icpr(/1))
  310. *
  311. RETURN
  312. END
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  
  323.  
  324.  
  325.  
  326.  

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