Télécharger renuel.eso

Retour à la liste

Numérotation des lignes :

  1. C RENUEL SOURCE PV 20/03/30 21:24:02 10567
  2. subroutine renuel(ipt6)
  3. *
  4. * renumerote les elements dans un meleme de proche en proche
  5. * ne fonctionne que pour un meleme simple
  6. *
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMELEME
  11. -INC SMCOORD
  12. SEGMENT IADJ(NODES+1)
  13. SEGMENT JADJC(JADDIM)
  14. C IADJ(i) pointe sur JADJC qui contient les voisins de i entre
  15. C IADJ(i) et IADJ(i+1)-1
  16. SEGMENT IELFAI(NBELEM)
  17. SEGMENT IPTFAI(NODES)
  18. SEGMENT ICPR(nbpts)
  19. SEGMENT IPLIST(NODES)
  20. *
  21. segini icpr
  22. segact ipt6*mod
  23. meleme=ipt6
  24. do 10000 isous=1,max(1,ipt6.lisous(/1))
  25. if (ipt6.lisous(/1).ne.0) meleme=ipt6.lisous(isous)
  26. segact meleme*mod
  27. segini,ipt1=meleme
  28. ipt2=meleme
  29. nodes=0
  30. do 100 il=1,ipt1.num(/2)
  31. do 100 ip=1,ipt1.num(/1)
  32. if (icpr(num(ip,il)).ne.0) goto 100
  33. nodes=nodes+1
  34. icpr(num(ip,il))=nodes
  35. 100 continue
  36. ** iadj: nombre d'elements touchant un noeud
  37. segini iadj
  38. do 200 il=1,ipt1.num(/2)
  39. do 200 ip=1,ipt1.num(/1)
  40. ipt=icpr(num(ip,il))
  41. iadj(ipt)=iadj(ipt)+1
  42. 200 continue
  43. ** position fin dans jadjc
  44. do ipt=1,nodes
  45. iadj(ipt+1)=iadj(ipt)+iadj(ipt+1)
  46. enddo
  47. ** iadjc: element touchant noeud
  48. JADDIM=iadj(nodes+1)
  49. segini jadjc
  50. do 300 il=1,ipt1.num(/2)
  51. do 300 ip=1,ipt1.num(/1)
  52. ipt=icpr(num(ip,il))
  53. jadjc(iadj(ipt))=il
  54. iadj(ipt)=iadj(ipt)-1
  55. 300 continue
  56. * creation tableau des elements faits, tableau des noeuds faits, et
  57. * et nouveau meleme
  58. nbsous=0
  59. nbref=0
  60. nbnn=ipt1.num(/1)
  61. nbelem=ipt1.num(/2)
  62. segini ielfai,iptfai
  63. ipt2.itypel=ipt1.itypel
  64. * remplissage maillage ordonnee et noeuds ordonné
  65. ielcou=0
  66. segini iplist
  67. * point de depart chosi par minimum degre
  68. nbconn=100000
  69. idep=0
  70. do ip=1,nodes
  71. nbc=iadj(ip+1)-iadj(ip)
  72. if (nbc.lt.nbconn) then
  73. nbconn=nbc
  74. idep=ip
  75. endif
  76. enddo
  77. if (idep.eq.0) call erreur(5)
  78. iplist(1)=idep
  79. iptfai(idep)=1
  80. ipc=1
  81. ipf=1
  82. 1000 continue
  83. if (ipc.gt.nodes) goto 2000
  84. i=iplist(ipc)
  85. ipre=iadj(i)+1
  86. ider=iadj(i+1)
  87. do 1010 jel=ipre,ider
  88. iel=jadjc(jel)
  89. if (ielfai(iel).eq.1) goto 1010
  90. ielcou=ielcou+1
  91. do ip=1,nbnn
  92. ipt2.num(ip,ielcou)=ipt1.num(ip,iel)
  93. ipt=icpr(ipt1.num(ip,iel))
  94. if (iptfai(ipt).eq.0) then
  95. ipf=ipf+1
  96. iplist(ipf)=ipt
  97. iptfai(ipt)=1
  98. endif
  99. enddo
  100. ielfai(iel)=1
  101. 1010 continue
  102. ipc=ipc+1
  103. if (ipc.le.ipf) goto 1000
  104. if (ipc.gt.nodes) goto 2000
  105. * plusieurs composantes connexes on cherche un nouveau point de depart
  106. nbconn=100000
  107. idep=0
  108. do ip=1,nodes
  109. if (iptfai(ip).eq.0) then
  110. nbc=iadj(ip+1)-iadj(ip)
  111. if (nbc.lt.nbconn) then
  112. nbconn=nbc
  113. idep=ip
  114. endif
  115. endif
  116. enddo
  117. if (idep.eq.0) call erreur(5)
  118. ipf=ipf+1
  119. iptfai(idep)=1
  120. iplist(ipf)=idep
  121. goto 1000
  122. * on a fini
  123. 2000 continue
  124. if (ipf.ne.nodes) write (6,*) ' probleme ',ipc,ipf,nodes
  125. segsup iadj,jadjc,ielfai,iptfai,icpr,iplist
  126. segdes ipt1,ipt2
  127. 10000 continue
  128. return
  129. end
  130.  
  131.  
  132.  

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