Télécharger mluniq.eso

Retour à la liste

Numérotation des lignes :

  1. C MLUNIQ SOURCE CHAT 05/01/13 01:46:43 5004
  2. SUBROUTINE MLUNIQ(GPMELS,
  3. $ KJSPGT,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : MLUNIQ
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : Un groupe de maillages => un maillage
  11. C contenant tous les points.
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELE PAR : PRASEM
  18. C***********************************************************************
  19. C ENTREES : GPMELS
  20. C SORTIES : KJSPGT
  21. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  22. C***********************************************************************
  23. C VERSION : v1, 30/09/99, version initiale
  24. C HISTORIQUE : v1, 30/09/99, création
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  29. C en cas de modification de ce sous-programme afin de faciliter
  30. C la maintenance !
  31. C***********************************************************************
  32. -INC CCOPTIO
  33. -INC SMCOORD
  34. -INC SMELEME
  35. POINTEUR MELCOU.MELEME
  36. POINTEUR SOUMEL.MELEME
  37. INTEGER NBELEM,NBNN,NBREF,NBSOUS
  38. POINTEUR KJSPGT.MELEME
  39. -INC SMLENTI
  40. INTEGER JG
  41. POINTEUR KRSPGT.MLENTI
  42. *
  43. * Includes persos
  44. *
  45. SEGMENT MELS
  46. POINTEUR LISMEL(NBMEL).MELEME
  47. ENDSEGMENT
  48. POINTEUR GPMELS.MELS
  49. *
  50. INTEGER IMPR,IRET
  51. *
  52. INTEGER IMEL,ISOUS,IPOEL,IELEM
  53. INTEGER NMEL,NSOUS,NPOEL,NELEM
  54. INTEGER NUMNO
  55. INTEGER ILDG,LDG,LAST,IPREC
  56. *
  57. * Executable statements
  58. *
  59. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans mluniq'
  60. *
  61. JG=XCOOR(/1)/(IDIM+1)
  62. SEGINI KRSPGT
  63. SEGACT GPMELS
  64. NMEL=GPMELS.LISMEL(/1)
  65. *
  66. * Parcourons les maillages
  67. *
  68. * degré et fin de la liste chaînée
  69. * le degré de la liste chaînée est aussi le nombre
  70. * de points de KJSPGT
  71. LDG=0
  72. LAST=-1
  73. DO 1 IMEL=1,NMEL
  74. MELCOU=GPMELS.LISMEL(IMEL)
  75. SEGACT MELCOU
  76. NSOUS=MELCOU.LISOUS(/1)
  77. DO 12 ISOUS=1,MAX(1,NSOUS)
  78. IF (NSOUS.EQ.0) THEN
  79. SOUMEL=MELCOU
  80. ELSE
  81. SOUMEL=MELCOU.LISOUS(ISOUS)
  82. SEGACT SOUMEL
  83. ENDIF
  84. NPOEL=SOUMEL.NUM(/1)
  85. NELEM=SOUMEL.NUM(/2)
  86. DO 122 IELEM=1,NELEM
  87. DO 1222 IPOEL=1,NPOEL
  88. NUMNO=SOUMEL.NUM(IPOEL,IELEM)
  89. IF (KRSPGT.LECT(NUMNO).EQ.0) THEN
  90. LDG=LDG+1
  91. KRSPGT.LECT(NUMNO)=LAST
  92. LAST=NUMNO
  93. ENDIF
  94. 1222 CONTINUE
  95. 122 CONTINUE
  96. IF (NSOUS.NE.0) SEGDES SOUMEL
  97. 12 CONTINUE
  98. SEGDES MELCOU
  99. 1 CONTINUE
  100. SEGDES GPMELS
  101. *
  102. * On transère la liste chaînée dans KJSPGT (maillage de points)
  103. *
  104. NBNN=1
  105. NBELEM=LDG
  106. NBSOUS=0
  107. NBREF=0
  108. SEGINI KJSPGT
  109. KJSPGT.ITYPEL=1
  110. DO 2 ILDG=1,LDG
  111. IPREC=KRSPGT.LECT(LAST)
  112. KJSPGT.NUM(1,ILDG)=LAST
  113. LAST=IPREC
  114. 2 CONTINUE
  115. SEGDES KJSPGT
  116. SEGSUP KRSPGT
  117. *
  118. * Normal termination
  119. *
  120. IRET=0
  121. RETURN
  122. *
  123. * Format handling
  124. *
  125. *
  126. * Error handling
  127. *
  128. 9999 CONTINUE
  129. IRET=1
  130. WRITE(IOIMP,*) 'An error was detected in subroutine mluniq'
  131. RETURN
  132. *
  133. * End of subroutine MLUNIQ
  134. *
  135. END
  136.  
  137.  
  138.  

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