Télécharger renuel.eso

Retour à la liste

Numérotation des lignes :

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

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