Télécharger noeinc.eso

Retour à la liste

Numérotation des lignes :

noeinc
  1. C NOEINC SOURCE OF166741 23/03/03 21:15:03 11416
  2.  
  3. C***********************************************************************
  4. C NOM : noeinc.eso
  5. C DESCRIPTION : Tableau des MELEME / POINTS nommes dont les numeros de
  6. C noeuds sont strictement inclus dans ICPR1
  7. C***********************************************************************
  8. C HISTORIQUE : 10/10/2018 : BERTHINC : Creation
  9. C 01/08/2022 : OF : Modifications diverses
  10. C***********************************************************************
  11. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  12. C en cas de modification de ce sous-programme afin de faciliter
  13. C la maintenance !
  14. C***********************************************************************
  15. C APPELE PAR : SORMED.ESO
  16. C***********************************************************************
  17. C ENTREES : CTYP, ICPR1
  18. C SORTIES : IREP1
  19. C***********************************************************************
  20.  
  21. SUBROUTINE NOEINC(ICPR1,CTYP,IREP1)
  22.  
  23. IMPLICIT INTEGER(i-n)
  24. IMPLICIT REAL*8(a-h,o-z)
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC CCMED
  29.  
  30. -INC SMELEME
  31. -INC SMMED
  32.  
  33. CHARACTER*(*) CTYP
  34.  
  35. C Segment de travail
  36. SEGMENT icpr(ic)
  37.  
  38. icpr = ICPR1
  39. c* segact,icpr <- suppose actif en entree
  40. IREP1 = 0
  41.  
  42. C***********************************************************************
  43. C On recupere les entites nommes et leurs noms
  44. CALL REPER1(CTYP, SREPER)
  45. IF (IERR.NE.0) RETURN
  46.  
  47. NBENT = SREPER.IREPER(/1)
  48. NBENT1 = 0
  49.  
  50. C ****************************************************************
  51. C * CAS des objets de type 'MAILLAGES'
  52. C ****************************************************************
  53. C Note : Les maillages nommes ne sont pas necessairement actives !
  54. C Ils sont actives puis desactives si non retenus.
  55. IF (CTYP .EQ. 'MAILLAGE') THEN
  56. C On repere quel MELEME nomme est inclus dans IMEL1
  57. DO ii = 1, NBENT
  58. IPT1 = SREPER.IREPER(ii)
  59. SEGACT,IPT1
  60. NBSOUS = IPT1.LISOUS(/1)
  61. ides = 1
  62. C Cas MELEME SIMPLE
  63. IF (NBSOUS .EQ. 0) THEN
  64. DO iel = 1, IPT1.NUM(/2)
  65. DO inoe = 1, IPT1.NUM(/1)
  66. IF(icpr(IPT1.NUM(inoe,iel)) .EQ. 0) GOTO 10
  67. ENDDO
  68. ENDDO
  69. C Cas MELEME COMPLEXE
  70. ELSE
  71. DO isous=1,NBSOUS
  72. IPT2 = IPT1.LISOUS(isous)
  73. SEGACT,IPT2
  74. DO iel=1,IPT2.NUM(/2)
  75. DO inoe=1,IPT2.NUM(/1)
  76. IF(icpr(IPT2.NUM(inoe,iel)) .EQ. 0) GOTO 10
  77. ENDDO
  78. ENDDO
  79. ENDDO
  80. ENDIF
  81. ides = 0
  82.  
  83. NBENT1=NBENT1+1
  84. SREPER.IREPER(NBENT1)=IPT1
  85. SREPER.CREPER(NBENT1)=SREPER.CREPER(ii)
  86.  
  87. 10 CONTINUE
  88. IF (ides.EQ.1) SEGDES,IPT1
  89. ENDDO
  90.  
  91. C ****************************************************************
  92. C * CAS des objets de type 'POINT'
  93. C ****************************************************************
  94. ELSE IF (CTYP .EQ. 'POINT ')THEN
  95. C On repere quel POINT nomme est inclus dans IMEL1
  96. DO ii = 1, NBENT
  97. inoe = SREPER.IREPER(ii)
  98. IF (icpr(inoe) .NE. 0) THEN
  99. NBENT1=NBENT1+1
  100. SREPER.IREPER(NBENT1)=inoe
  101. SREPER.CREPER(NBENT1)=SREPER.CREPER(ii)
  102. END IF
  103. ENDDO
  104.  
  105. ELSE
  106. CALL ERREUR(5)
  107. ENDIF
  108.  
  109. C Ajustement final
  110. IF (NBENT1 .NE. NBENT) THEN
  111. NBENT=NBENT1
  112. SEGADJ,SREPER
  113. ENDIF
  114. IREP1 = SREPER
  115.  
  116. c segdes,icpr
  117.  
  118. c return
  119. END
  120.  
  121.  
  122.  

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