Télécharger noeinc.eso

Retour à la liste

Numérotation des lignes :

  1. C NOEINC SOURCE CB215821 19/03/18 21:15:46 10161
  2. SUBROUTINE NOEINC(IMEL1,CTYP,SREPE1)
  3. C***********************************************************************
  4. C NOM : noeinc.eso
  5. C DESCRIPTION : Tableau des MELEME / POINTS nommes dont les numéros de
  6. C noeuds sont strictement inclus dans IMEL1
  7. C***********************************************************************
  8. C HISTORIQUE : 10/10/2018 : BERTHINC : Creation
  9. C HISTORIQUE :
  10. C***********************************************************************
  11. C Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  12. C en cas de modification de ce sous-programme afin de faciliter
  13. C la maintenance !
  14. C***********************************************************************
  15. C APPELÉ PAR : SORMED.ESO
  16. C***********************************************************************
  17. C ENTRÉES : IMEL1
  18. C SORTIES : SREPE1
  19. C***********************************************************************
  20.  
  21. IMPLICIT INTEGER(i-n)
  22. IMPLICIT REAL*8(a-h,o-z)
  23.  
  24. -INC CCNOYAU
  25. -INC CCASSIS
  26. -INC CCOPTIO
  27. -INC SMELEME
  28. -INC SMCOORD
  29.  
  30. CHARACTER*8 CTYP
  31.  
  32. C SEGMENT pour repertorier les objets nommes et leur nom
  33. SEGMENT SREPER
  34. INTEGER IREPER(NBENT)
  35. CHARACTER*(LONOM) CREPER(NBENT)
  36. C NBENT : Nombre d'objets
  37. C IREPER : OBJETS (Pointeur ou ENTIER pour les 'POINT')
  38. C CREPER : Noms des OBJETS
  39. ENDSEGMENT
  40. POINTEUR SREPE1.SREPER
  41.  
  42. C SegmentS de travail
  43. SEGMENT ICPR(iiicpr)
  44.  
  45. C***********************************************************************
  46. C DEBUT DES INSTRUCTIONS
  47. C***********************************************************************
  48. IF (CTYP.NE.'MAILLAGE' .AND. CTYP.NE.'POINT ') THEN
  49. CALL ERREUR(5)
  50. ENDIF
  51.  
  52. C On recupere les entites nommes et leurs noms
  53. CALL REPER1(CTYP, SREPER)
  54. IF (IERR.NE.0) RETURN
  55.  
  56. C***********************************************************************
  57. C On place les noeuds tests dans ICPR
  58. SEGACT,MCOORD
  59. iiicpr=XCOOR(/1) / (IDIM+1)
  60. SEGINI,ICPR
  61.  
  62. IPT1=IMEL1
  63. SEGACT,IPT1
  64. NBSOUS=IPT1.LISOUS(/1)
  65. IF(NBSOUS .EQ. 0)THEN
  66. C Cas MELEME SIMPLE
  67. DO iel=1,IPT1.NUM(/2)
  68. DO inoe=1,IPT1.NUM(/1)
  69. ICPR(IPT1.NUM(inoe,iel)) = 1
  70. ENDDO
  71. ENDDO
  72.  
  73. ELSE
  74. C Cas MELEME COMPLEXE
  75. DO isous=1,NBSOUS
  76. IPT2=IPT1.LISOUS(isous)
  77. SEGACT,IPT2
  78. DO iel=1,IPT2.NUM(/2)
  79. DO inoe=1,IPT2.NUM(/1)
  80. ICPR(IPT2.NUM(inoe,iel)) = 1
  81. ENDDO
  82. ENDDO
  83. ENDDO
  84. ENDIF
  85.  
  86.  
  87. NBENT1=SREPER.IREPER(/1)
  88. NBENT=NBENT1
  89. SEGINI,SREPE1
  90. NBENT2=0
  91.  
  92. IF (CTYP .EQ. 'MAILLAGE') THEN
  93. C ****************************************************************
  94. C * CAS des objets de type 'MAILLAGES'
  95. C ****************************************************************
  96. C On repere quel MELEME nommes est inclu dans IMEL1
  97. DO 10 iii=1,NBENT1
  98. IPT1=SREPER.IREPER(iii)
  99. SEGACT,IPT1
  100. NBSOUS=IPT1.LISOUS(/1)
  101. IF(NBSOUS .EQ. 0)THEN
  102. C Cas MELEME SIMPLE
  103. DO iel=1,IPT1.NUM(/2)
  104. DO inoe=1,IPT1.NUM(/1)
  105. IF(ICPR(IPT1.NUM(inoe,iel)) .NE. 1) GOTO 10
  106. ENDDO
  107. ENDDO
  108.  
  109. ELSE
  110. C Cas MELEME COMPLEXE
  111. DO isous=1,NBSOUS
  112. IPT2=IPT1.LISOUS(isous)
  113. SEGACT,IPT2
  114. DO iel=1,IPT2.NUM(/2)
  115. DO inoe=1,IPT2.NUM(/1)
  116. IF(ICPR(IPT2.NUM(inoe,iel)) .NE. 1) GOTO 10
  117. ENDDO
  118. ENDDO
  119. ENDDO
  120. ENDIF
  121.  
  122. NBENT2=NBENT2+1
  123. SREPE1.IREPER(NBENT2)=SREPER.IREPER(iii)
  124. SREPE1.CREPER(NBENT2)=SREPER.CREPER(iii)
  125. 10 CONTINUE
  126.  
  127. ELSEIF(CTYP .EQ. 'POINT ')THEN
  128. C ****************************************************************
  129. C * CAS des objets de type 'POINT'
  130. C ****************************************************************
  131. C On repere quel POINT nommes est inclu dans IMEL1
  132. DO 20 iii=1,NBENT1
  133. inoe=SREPER.IREPER(iii)
  134. IF(ICPR(inoe) .NE. 1) GOTO 20
  135.  
  136. NBENT2=NBENT2+1
  137. SREPE1.IREPER(NBENT2)=SREPER.IREPER(iii)
  138. SREPE1.CREPER(NBENT2)=SREPER.CREPER(iii)
  139. 20 CONTINUE
  140.  
  141. ELSE
  142. CALL ERREUR(5)
  143. ENDIF
  144.  
  145. C Ajustement final
  146. IF (NBENT2 .NE. NBENT) THEN
  147. NBENT=NBENT2
  148. SEGADJ,SREPE1
  149. ENDIF
  150. SEGSUP,ICPR
  151.  
  152. END
  153.  
  154.  

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