Télécharger numopt.eso

Retour à la liste

Numérotation des lignes :

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

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