Télécharger doubl1.eso

Retour à la liste

Numérotation des lignes :

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

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