Télécharger poinbl.eso

Retour à la liste

Numérotation des lignes :

  1. C POINBL SOURCE CHAT 05/01/13 02:16:47 5004
  2. SUBROUTINE POINBL(MCLAS,MCLPO1,
  3. $ PONBEL,IMPR,IRET)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C***********************************************************************
  7. C NOM : POINBL
  8. C DESCRIPTION : Construit une liste d'entiers : PONBEL (type MLENTI)
  9. C PONBEL(i) est le nombre d'éléments de MCLAS
  10. C contenant le ieme point du maillage MCLPO1.
  11. C MCLPO1 est un maillage de POI1.
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES : KRIPAD : MELEME -> (num. globale->locale)
  18. C APPELES (E/S) : -
  19. C APPELES (BLAS) : -
  20. C APPELES (CALCUL) : -
  21. C APPELE PAR : POIELE, ELPOEL
  22. C***********************************************************************
  23. C SYNTAXE GIBIANE : -
  24. C ENTREES : MCLAS (type MELEME) : maillage de classe de
  25. C points (sommet, face) par
  26. C élément (MMAIL,ELTFA)
  27. C MCLPO1 (type MELEME) : maillage de points
  28. C correspondant à MCLAS
  29. C ENTREES/SORTIES : -
  30. C SORTIES : PONBEL (type MLENTI)
  31. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32. C***********************************************************************
  33. C VERSION : v1, 29/10/98, version initiale
  34. C HISTORIQUE : v1, 29/10/98, création
  35. C HISTORIQUE :
  36. C HISTORIQUE :
  37. C***********************************************************************
  38. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  39. C en cas de modification de ce sous-programme afin de faciliter
  40. C la maintenance !
  41. C***********************************************************************
  42. -INC CCOPTIO
  43. -INC SMELEME
  44. POINTEUR MCLAS.MELEME
  45. POINTEUR MCLPO1.MELEME
  46. -INC SMLENTI
  47. POINTEUR PONBEL.MLENTI
  48. POINTEUR KRIPO1.MLENTI
  49. *
  50. * Executable statements
  51. *
  52. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans poinbl.eso'
  53. SEGACT MCLPO1
  54. NBSOUS=MCLPO1.LISOUS(/1)
  55. NOTYP =MCLPO1.ITYPEL
  56. IF (NBSOUS.NE.0.OR.(NBSOUS.EQ.0.AND.NOTYP.NE.1)) THEN
  57. WRITE(IOIMP,*) 'MCLPO1 must contain only POI1 elements'
  58. GOTO 9999
  59. ENDIF
  60. C In KRIPAD : SEGINI KRIPO1
  61. CALL KRIPAD(MCLPO1,KRIPO1)
  62. NBPOI1=MCLPO1.NUM(/2)
  63. SEGDES MCLPO1
  64. JG=NBPOI1
  65. SEGINI PONBEL
  66. *
  67. * Parcourons le maillage géométrique des classes de points
  68. *
  69. SEGACT MCLAS
  70. NBSOUS=MCLAS.LISOUS(/1)
  71. IF (NBSOUS.EQ.0) NBSOUS=1
  72. DO 1 INBSOU=1,NBSOUS
  73. IF (NBSOUS.GT.1) THEN
  74. IPT1=MCLAS.LISOUS(INBSOU)
  75. SEGACT IPT1
  76. ELSE
  77. IPT1=MCLAS
  78. ENDIF
  79. NBPOEL=IPT1.NUM(/1)
  80. NBELEM=IPT1.NUM(/2)
  81. DO 12 INBEL=1,NBELEM
  82. DO 122 INBPO=1,NBPOEL
  83. NOPOI1=KRIPO1.LECT(IPT1.NUM(INBPO,INBEL))
  84. IF (NOPOI1.NE.0) THEN
  85. PONBEL.LECT(NOPOI1)=PONBEL.LECT(NOPOI1)+1
  86. ELSE
  87. WRITE(IOIMP,*) 'Erreur grave MCLPO1 n''est pas'
  88. WRITE(IOIMP,*) 'le maillage de points correspondant'
  89. WRITE(IOIMP,*) 'à MCLAS.'
  90. GOTO 9999
  91. ENDIF
  92. 122 CONTINUE
  93. 12 CONTINUE
  94. IF (NBSOUS.GT.1) SEGDES IPT1
  95. 1 CONTINUE
  96. SEGDES MCLAS
  97. SEGSUP KRIPO1
  98. IF (IMPR.GT.2) THEN
  99. WRITE(IOIMP,*) 'On a créé PONBEL=',PONBEL
  100. IF (IMPR.GT.3) THEN
  101. WRITE(IOIMP,4000) 'PONBEL',NBPOI1
  102. WRITE(IOIMP,5000) (PONBEL.LECT(I),I=1,NBPOI1)
  103. ENDIF
  104. ENDIF
  105. SEGDES PONBEL
  106. *
  107. * Normal termination
  108. *
  109. IRET=0
  110. RETURN
  111. *
  112. * Format handling
  113. *
  114. 4000 FORMAT (A,'(1..',I8,')')
  115. 5000 FORMAT (8(1X,I8))
  116. *
  117. * Error handling
  118. *
  119. 9999 CONTINUE
  120. IRET=1
  121. WRITE(IOIMP,*) 'An error was detected in subroutine poinbl'
  122. RETURN
  123. *
  124. * End of subroutine POINBL
  125. *
  126. END
  127.  
  128.  
  129.  
  130.  

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