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 PPARAM
  43. -INC CCOPTIO
  44. -INC SMELEME
  45. POINTEUR MCLAS.MELEME
  46. POINTEUR MCLPO1.MELEME
  47. -INC SMLENTI
  48. POINTEUR PONBEL.MLENTI
  49. POINTEUR KRIPO1.MLENTI
  50. *
  51. * Executable statements
  52. *
  53. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans poinbl.eso'
  54. SEGACT MCLPO1
  55. NBSOUS=MCLPO1.LISOUS(/1)
  56. NOTYP =MCLPO1.ITYPEL
  57. IF (NBSOUS.NE.0.OR.(NBSOUS.EQ.0.AND.NOTYP.NE.1)) THEN
  58. WRITE(IOIMP,*) 'MCLPO1 must contain only POI1 elements'
  59. GOTO 9999
  60. ENDIF
  61. C In KRIPAD : SEGINI KRIPO1
  62. CALL KRIPAD(MCLPO1,KRIPO1)
  63. NBPOI1=MCLPO1.NUM(/2)
  64. SEGDES MCLPO1
  65. JG=NBPOI1
  66. SEGINI PONBEL
  67. *
  68. * Parcourons le maillage géométrique des classes de points
  69. *
  70. SEGACT MCLAS
  71. NBSOUS=MCLAS.LISOUS(/1)
  72. IF (NBSOUS.EQ.0) NBSOUS=1
  73. DO 1 INBSOU=1,NBSOUS
  74. IF (NBSOUS.GT.1) THEN
  75. IPT1=MCLAS.LISOUS(INBSOU)
  76. SEGACT IPT1
  77. ELSE
  78. IPT1=MCLAS
  79. ENDIF
  80. NBPOEL=IPT1.NUM(/1)
  81. NBELEM=IPT1.NUM(/2)
  82. DO 12 INBEL=1,NBELEM
  83. DO 122 INBPO=1,NBPOEL
  84. NOPOI1=KRIPO1.LECT(IPT1.NUM(INBPO,INBEL))
  85. IF (NOPOI1.NE.0) THEN
  86. PONBEL.LECT(NOPOI1)=PONBEL.LECT(NOPOI1)+1
  87. ELSE
  88. WRITE(IOIMP,*) 'Erreur grave MCLPO1 n''est pas'
  89. WRITE(IOIMP,*) 'le maillage de points correspondant'
  90. WRITE(IOIMP,*) 'à MCLAS.'
  91. GOTO 9999
  92. ENDIF
  93. 122 CONTINUE
  94. 12 CONTINUE
  95. IF (NBSOUS.GT.1) SEGDES IPT1
  96. 1 CONTINUE
  97. SEGDES MCLAS
  98. SEGSUP KRIPO1
  99. IF (IMPR.GT.2) THEN
  100. WRITE(IOIMP,*) 'On a créé PONBEL=',PONBEL
  101. IF (IMPR.GT.3) THEN
  102. WRITE(IOIMP,4000) 'PONBEL',NBPOI1
  103. WRITE(IOIMP,5000) (PONBEL.LECT(I),I=1,NBPOI1)
  104. ENDIF
  105. ENDIF
  106. SEGDES PONBEL
  107. *
  108. * Normal termination
  109. *
  110. IRET=0
  111. RETURN
  112. *
  113. * Format handling
  114. *
  115. 4000 FORMAT (A,'(1..',I8,')')
  116. 5000 FORMAT (8(1X,I8))
  117. *
  118. * Error handling
  119. *
  120. 9999 CONTINUE
  121. IRET=1
  122. WRITE(IOIMP,*) 'An error was detected in subroutine poinbl'
  123. RETURN
  124. *
  125. * End of subroutine POINBL
  126. *
  127. END
  128.  
  129.  
  130.  
  131.  

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