Télécharger noeinc.eso

Retour à la liste

Numérotation des lignes :

  1. C NOEINC SOURCE PV 20/03/30 21:21:34 10567
  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 PPARAM
  27. -INC CCOPTIO
  28. -INC SMELEME
  29. -INC SMCOORD
  30.  
  31. CHARACTER*8 CTYP
  32.  
  33. C SEGMENT pour repertorier les objets nommes et leur nom
  34. SEGMENT SREPER
  35. INTEGER IREPER(NBENT)
  36. CHARACTER*(LONOM) CREPER(NBENT)
  37. C NBENT : Nombre d'objets
  38. C IREPER : OBJETS (Pointeur ou ENTIER pour les 'POINT')
  39. C CREPER : Noms des OBJETS
  40. ENDSEGMENT
  41. POINTEUR SREPE1.SREPER
  42.  
  43. C SegmentS de travail
  44. SEGMENT ICPR(iiicpr)
  45.  
  46. C***********************************************************************
  47. C DEBUT DES INSTRUCTIONS
  48. C***********************************************************************
  49. IF (CTYP.NE.'MAILLAGE' .AND. CTYP.NE.'POINT ') THEN
  50. CALL ERREUR(5)
  51. ENDIF
  52.  
  53. C On recupere les entites nommes et leurs noms
  54. CALL REPER1(CTYP, SREPER)
  55. IF (IERR.NE.0) RETURN
  56.  
  57. C***********************************************************************
  58. C On place les noeuds tests dans ICPR
  59. iiicpr=nbpts
  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.  
  155.  

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