Télécharger doubl1.eso

Retour à la liste

Numérotation des lignes :

  1. C DOUBL1 SOURCE BP208322 16/11/18 21:16:30 9177
  2. SUBROUTINE DOUBL1(MELEME,NMESH)
  3. C----------------------------------------------------
  4. C
  5. C DÉTECTION DES ÉLÉMENTS EN DOUBLON D'UN MAILLAGE
  6. C
  7. C----------------------------------------------------
  8. C
  9. C Création : Pascal Maugis, 04/08/2005
  10. C
  11. C----------------------------------------------------
  12. C
  13. C Appelé par VERMAI
  14. C
  15. C Entrée :
  16. C MELEME : maillage
  17. C
  18. C Sortie :
  19. C NMESH : nombre de doubons détectés et nommés
  20. C
  21. C----------------------------------------------------
  22. C
  23. C Variables
  24. C
  25. C CHAIN1 : le nom de la maille à nommer,
  26. C pas plus de 999999
  27. C
  28. C----------------------------------------------------
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31. -INC CCOPTIO
  32. -INC CCGEOME
  33. -INC SMELEME
  34. -INC SMLENTI
  35. -INC SMLREEL
  36. C
  37. CHARACTER*8 CHAIN1
  38. C
  39. SEGACT,MELEME
  40. NMESH=0
  41. C
  42. C BOUCLE SUR LES ZONES DU MAILLAGE
  43. C
  44. IPT1=MELEME
  45. DO IZON=1,MAX(1,LISOUS(/1))
  46. IF (LISOUS(/1).NE.0) THEN
  47. IPT1=LISOUS(IZON)
  48. SEGACT,IPT1
  49. ENDIF
  50.  
  51. MBELEM = IPT1.NUM(/2)
  52. NBNN = IPT1.NUM(/1)
  53. ITYP = IPT1.ITYPEL
  54.  
  55. C Il faut qu'il y ait quelque chose à trier
  56. IF ((MBELEM.GT.1).AND.(NBNN.GT.0)) THEN
  57. C
  58. C tri préalable des points de chaque élément surfacique
  59. C selon la somme des numéros de noeud
  60. C
  61. JG=MBELEM
  62. SEGINI,MLENT1,MLENTI
  63. DO IE2=1,MBELEM
  64. MLENTI.LECT(IE2)=IE2
  65. MLENT1.LECT(IE2)=0
  66. DO IE3=1,NBNN
  67. MLENT1.LECT(IE2)=MLENT1.LECT(IE2)+IPT1.NUM(IE3,IE2)
  68. ENDDO
  69. ENDDO
  70. SEGINI,MLENT2=MLENTI
  71. CALL GENOR2(MLENT1.LECT,MLENT2.LECT,MBELEM)
  72. C
  73. C Quand on trouve une occurence multiple,
  74. C on permute les indices dans la liste MLENTI.LECT
  75. CALL DOUBL4(IPT1.NUM,NBNN,MBELEM,
  76. > MLENT1.LECT,MLENT2.LECT,MLENTI.LECT)
  77. C
  78. C NOTIFICATION ET SAUVEGARDE DES MAILLES EN DOUBLE
  79. DO IE2=1,MBELEM
  80. IF(LECT(IE2).NE.0)THEN
  81. IF(LECT(IE2).NE.IE2)THEN
  82. C un multiplon détecté
  83. write(IOIMP,*) 'AVERTISSEMENT : ',
  84. & ' une maille de type ',NOMS(ITYP),
  85. & ' figure ',(LECT(IE2)-IE2+1),
  86. & ' fois dans la sous-zone ',IZON
  87.  
  88. DO IE4=IE2,LECT(IE2)
  89. LECT(IE4)=0
  90.  
  91. C Création d'une maille nommée
  92. C ----------------------------
  93. CHAIN1='MESH'
  94. NMESH=NMESH+1
  95. C chaîne de caractères du nom de la maille
  96. NNO=NMESH
  97. IF (NNO.LE.9) THEN
  98. WRITE(CHAIN1(5:5),FMT='(I1)')NNO
  99. ELSEif(NNO.LE.99) THEN
  100. WRITE(CHAIN1(5:6),FMT='(I2)')NNO
  101. ELSEif(NNO.LE.999) THEN
  102. WRITE(CHAIN1(5:7),FMT='(I3)')NNO
  103. ELSEif(NNO.LE.9999) THEN
  104. WRITE(CHAIN1(5:8),FMT='(I4)')NNO
  105. ELSEif(NNO.LE.99999) THEN
  106. WRITE(CHAIN1(4:8),FMT='(I5)')NNO
  107. ELSEif(NNO.LE.999999) THEN
  108. WRITE(CHAIN1(3:8),FMT='(I6)')NNO
  109. ELSE
  110. C Numéro du point ou de l'élément trop grand
  111. CALL ERREUR(262)
  112. ENDIF
  113.  
  114. C Maillage à UN élément
  115. NBELEM=1
  116. NBSOUS=0
  117. NBREF=0
  118. SEGINI,IPT3
  119. DO IE3=1,NBNN
  120. IPT3.NUM(IE3,1)=IPT1.NUM(IE3,IE4)
  121. ENDDO
  122. IPT3.ICOLOR(1)=IPT1.ICOLOR(IE4)
  123. SEGDES,IPT3
  124. CALL NOMOBJ('MAILLAGE',CHAIN1,IPT3)
  125.  
  126. C Message :
  127. write(IOIMP,*) ' maille concernée : ',CHAIN1
  128. ENDDO
  129. ENDIF
  130. ENDIF
  131. ENDDO
  132.  
  133. SEGSUP,MLENTI,MLENT1,MLENT2
  134. ENDIF
  135. C
  136. C FIN BOUCLE SUR LES ZONES DU MAILLAGE
  137. C
  138. SEGDES,IPT1
  139. ENDDO
  140.  
  141. RETURN
  142. END
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  

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