Télécharger fusebo.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSEBO SOURCE CB215821 19/08/20 21:17:59 10287
  2.  
  3. C CE SOUS-PROGRAMME L'OPERATION "ET" SUR UN maillage pas beau
  4. C ( qui ne respecte pas la partition par type)pour le rendre beau.
  5. C On ne s'occupe pas des references
  6. C IPT1: en entree IPT3: en sortie
  7. C
  8. SUBROUTINE FUSEBO(IPT1,IPT3)
  9. IMPLICIT INTEGER(I-N)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC CCGEOME
  14. -INC SMELEME
  15. SEGMENT ISO1(NBSOU1)
  16. SEGMENT ISO2(NBSOU1)
  17. segment iso3(nbsou1)
  18. SEGACT IPT1
  19. NBSOU1= IPT1.LISOUS(/1)
  20. * write(6,*) ' entree dans fusebo nbsou1 ' , nbsou1
  21. segact ipt1
  22. SEGINI ISO1,ISO2,iso3
  23. DO 350 I=1,NBSOU1
  24. 350 ISO1(I)=IPT1.LISOUS(I)
  25. ity=0
  26. nbref=0
  27. nbsous=0
  28. DO 310 I1=1,NBSOU1
  29. IPT1=ISO1(I1)
  30. if(IPT1.EQ.0) go to 310
  31. ity = 1 + ity
  32. ias = 1
  33. iso3(ias)=ipt1
  34. segact ipt1
  35. nbnn = ipt1.num(/1)
  36. nbelem = ipt1.num(/2)
  37. do 330 i2 = i1+1, nbsou1
  38. IPT2=ISO1(I2)
  39. IF (IPT2.EQ.0) GOTO 330
  40. IPT2=ISO1(I2)
  41. IF (IPT2.EQ.0) GOTO 330
  42. SEGACT IPT2
  43. IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 340
  44. IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 340
  45. ias = ias+1
  46. iso3(ias)= ipt2
  47. iso1(i2)=0
  48. nbelem = nbelem + ipt2.num(/2)
  49. 340 continue
  50. 330 continue
  51. if(ias.eq.1) then
  52. iso2(ity) = ipt1
  53. else
  54. segini meleme
  55. idec=0
  56. itypel = ipt1.itypel
  57. DO 311 I2=1,ias
  58. IPT1=ISO3(I2)
  59. segact ipt1
  60. do 351 nbe=1,ipt1.num(/2)
  61. do 352 nbn=1,nbnn
  62. num(nbn,idec+nbe)=ipt1.num(nbn,nbe)
  63. 352 continue
  64. 351 continue
  65. do 353 nbe=1,ipt1.num(/2)
  66. 353 icolor(idec+nbe)=ipt1.icolor(nbe)
  67. idec = idec + ipt1.num(/2)
  68. 311 continue
  69. iso2(ity)=meleme
  70. endif
  71. 310 CONTINUE
  72. if( ity.eq.1) then
  73. ipt3 = iso2(1)
  74. else
  75. NBREF=0
  76. NBNN=0
  77. NBELEM=0
  78. nbsous = ity
  79. SEGINI IPT3
  80. DO 111 I=1,NBSOUs
  81. IPT3.LISOUS(I)=ISO2(I)
  82. 111 CONTINUE
  83. endif
  84. SEGSUP ISO1,ISO2,iso3
  85. 1020 RETURN
  86. END
  87.  
  88.  
  89.  

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