Télécharger uniqma.eso

Retour à la liste

Numérotation des lignes :

  1. C UNIQMA SOURCE PASCAL 18/11/28 21:15:11 10011
  2. C
  3. subroutine uniqma(ipt1,nbdif)
  4. C
  5. C construit un maillage constitué des éléments unique d'un autre maillage
  6. C
  7. C uniqma gere les chapeaux du meleme, uniqm1 gere les lisous
  8. C
  9. implicit real*8 (a-h,o-z)
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC SMCOORD
  13. segment netn(xcoor(/1)/(idim+1)+1)
  14. segment ietn(letn)
  15. C
  16. segact mcoord
  17. C* call lirobj('MAILLAGE',ipt1,1,iretou)
  18. C* if (ierr.ne.0) return
  19. segact ipt1
  20. nbdif=0
  21. nbdi1=0
  22.  
  23. if (ipt1.lisous(/1).eq.0) then
  24. C Cas MELEME SIMPLE
  25. C if (ipt1.num(/2).ne.0) then
  26. call uniqm1(ipt1,ipt2,nbdif)
  27. C else
  28. C segini,ipt2=ipt1
  29. C endif
  30. goto 1000
  31. endif
  32.  
  33. C Cas MELEME COMPLEXE
  34. segini,ipt2=ipt1
  35. do 100 is=1,ipt2.lisous(/1)
  36. ipt3=ipt2.lisous(is)
  37. if (ipt3.eq.0) goto 100
  38. segact ipt3
  39. C verif pas d'autre paquet semblables
  40. do 110 is2=is+1,ipt2.lisous(/1)
  41. ipt4=ipt2.lisous(is2)
  42. if (ipt4.eq.0) goto 110
  43. segact ipt4
  44. if (ipt4.itypel.ne.ipt3.itypel) goto 110
  45. if (ipt4.num(/1).ne.ipt3.num(/1)) goto 110
  46.  
  47. C concatenation de ipt3 et ipt4
  48. nbnn =ipt3.num(/1)
  49. nbelem=ipt3.num(/2)+ipt4.num(/2)
  50. nbsous=0
  51. nbref =0
  52. segini ipt5
  53. ipt5.itypel=ipt3.itypel
  54. do j=1,ipt3.num(/2)
  55. do i=1,ipt3.num(/1)
  56. ipt5.num(i,j)=ipt3.num(i,j)
  57. enddo
  58. ipt5.icolor(j)=ipt3.icolor(j)
  59. enddo
  60.  
  61. do j=1,ipt4.num(/2)
  62. j1=j+ipt3.num(/2)
  63. do i=1,ipt4.num(/1)
  64. ipt5.num(i,j1)=ipt4.num(i,j)
  65. enddo
  66. ipt5.icolor(j1)=ipt4.icolor(j)
  67. enddo
  68.  
  69. segdes ipt3,ipt4
  70. ipt3=ipt5
  71. ipt2.lisous(is2)=0
  72. 110 continue
  73. call uniqm1(ipt3,ipt4,nbdi1)
  74. nbdif = nbdif + nbdi1
  75. ipt2.lisous(is)=ipt4
  76. 100 continue
  77. C compression du segment
  78. nbsous=0
  79. do 200 is=1,ipt2.lisous(/1)
  80. if (ipt2.lisous(is).ne.0) then
  81. nbsous=nbsous+1
  82. ipt2.lisous(nbsous)=ipt2.lisous(is)
  83. endif
  84. 200 continue
  85. nbref =0
  86. nbnn =0
  87. nbelem=0
  88. segadj ipt2
  89. if (nbsous.eq.1) then
  90. ipt2=ipt2.lisous(1)
  91. endif
  92. C
  93. 1000 continue
  94. ipt1=ipt2
  95. return
  96. end
  97.  
  98.  
  99.  
  100.  
  101.  

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