Télécharger poelm2.eso

Retour à la liste

Numérotation des lignes :

  1. C POELM2 SOURCE CHAT 05/01/13 02:16:26 5004
  2. SUBROUTINE POELM2(MAIL,KRIPO1,PONBEL,
  3. $ LSTPL,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : POELM2
  9. C DESCRIPTION : Maillage + tableau de repérage de points + liste
  10. C d'entiers (ponbl2) => liste indexée d'entiers (un
  11. C point)->(numéro des éléments du maillage le contenant).
  12. C
  13. C Construit une liste indexée LSTPL (type LSTIND)
  14. C * Nombre de multiplets = nb d'éléments de PONBEL ;
  15. C * chaque multiplet i : numéros des éléments de
  16. C MAIL contenant un point dont le numéro n
  17. C est tel que KRIPO1(n)=i.
  18. C (Le nombre de ces éléments est PONBEL(i), cf. ponbl2).
  19. C
  20. C LANGAGE : ESOPE
  21. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  22. C mél : gounand@semt2.smts.cea.fr
  23. C***********************************************************************
  24. C APPELES (ESOPE) : OOOETA
  25. C APPELE PAR : MAKPRM
  26. C***********************************************************************
  27. C SYNTAXE GIBIANE : -
  28. C ENTREES :
  29. C ENTREES/SORTIES : -
  30. C SORTIES : LSTPL (type LSTIND)
  31. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  32. C***********************************************************************
  33. C VERSION : v1, 20/05/99, version initiale
  34. C HISTORIQUE : v1, 20/05/99, 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 MAIL.MELEME
  45. POINTEUR SOUMAI.MELEME
  46. -INC SMLENTI
  47. POINTEUR PONBEL.MLENTI
  48. POINTEUR KRIPO1.MLENTI
  49. *
  50. * Segment LSTIND (liste séquentielle indexée)
  51. *
  52. SEGMENT LSTIND
  53. INTEGER IDX(NBM+1)
  54. INTEGER IVAL(NBTVAL)
  55. ENDSEGMENT
  56. *
  57. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  58. *
  59. * NBL : NOMBRE DE MULTIPLETS
  60. * NBTVAL : NOMBRE TOTAL DE VALEURS
  61. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  62. * MULTIPLET DANS LE TABLEAU IVAL
  63. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  64. *
  65. *-INC SLSTIND
  66. POINTEUR LSTPL.LSTIND
  67. POINTEUR ICOUR.LSTIND
  68. *
  69. INTEGER IMPR,IRET
  70. INTEGER MAETA,KRETA,POETA,SMETA
  71. INTEGER INBEL,INBM,INBNO,INBSOU,IDEPA,IDXCOU
  72. INTEGER NBEL, NBM, NBNO,NBSOUS
  73. INTEGER NBTVAL,NLOCP1,NPONB,NUELMA,NUMNO
  74. *
  75. * Executable statements
  76. *
  77. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans poelm2.eso'
  78. CALL OOOETA(PONBEL,POETA)
  79. IF (POETA.NE.1) SEGACT PONBEL
  80. NPONB=PONBEL.LECT(/1)
  81. C On initialise le segment LSTPL
  82. C et le segment ICOUR
  83. C dans ICOUR, seul le tableau IDX nous intéresse
  84. NBM=NPONB
  85. NBTVAL=0
  86. SEGINI LSTPL
  87. IDEPA=1
  88. DO 2 INBM=1,NBM
  89. LSTPL.IDX(INBM)=IDEPA
  90. IDEPA=IDEPA+PONBEL.LECT(INBM)
  91. 2 CONTINUE
  92. LSTPL.IDX(NBM+1)=IDEPA
  93. IF (POETA.NE.1) SEGDES PONBEL
  94. SEGINI,ICOUR=LSTPL
  95. NBTVAL=IDEPA-1
  96. SEGADJ LSTPL
  97. CALL OOOETA(KRIPO1,KRETA)
  98. IF (KRETA.NE.1) SEGACT KRIPO1
  99. *
  100. * Parcourons le maillage
  101. *
  102. NUELMA=0
  103. CALL OOOETA(MAIL,MAETA)
  104. IF (MAETA.NE.1) SEGACT MAIL
  105. NBSOUS=MAX(1,MAIL.LISOUS(/1))
  106. DO 4 INBSOU=1,NBSOUS
  107. IF (NBSOUS.EQ.1) THEN
  108. SOUMAI=MAIL
  109. ELSE
  110. SOUMAI=MAIL.LISOUS(INBSOU)
  111. CALL OOOETA(SOUMAI,SMETA)
  112. IF (SMETA.NE.1) SEGACT SOUMAI
  113. ENDIF
  114. NBNO=SOUMAI.NUM(/1)
  115. NBEL=SOUMAI.NUM(/2)
  116. DO 42 INBEL=1,NBEL
  117. NUELMA=NUELMA+1
  118. DO 422 INBNO=1,NBNO
  119. NUMNO=SOUMAI.NUM(INBNO,INBEL)
  120. NLOCP1=KRIPO1.LECT(NUMNO)
  121. IF (NLOCP1.NE.0) THEN
  122. IDXCOU=ICOUR.IDX(NLOCP1)
  123. LSTPL.IVAL(IDXCOU)=NUELMA
  124. ICOUR.IDX(NLOCP1)=IDXCOU+1
  125. ENDIF
  126. 422 CONTINUE
  127. 42 CONTINUE
  128. IF (NBSOUS.NE.1.AND.SMETA.NE.1) SEGDES SOUMAI
  129. 4 CONTINUE
  130. IF (MAETA.NE.1) SEGDES MAIL
  131. IF (KRETA.NE.1) SEGDES KRIPO1
  132. SEGDES LSTPL
  133. SEGSUP ICOUR
  134. *
  135. * Normal termination
  136. *
  137. IRET=0
  138. RETURN
  139. *
  140. * Format handling
  141. *
  142. *
  143. * Error handling
  144. *
  145. 9999 CONTINUE
  146. IRET=1
  147. WRITE(IOIMP,*) 'An error was detected in subroutine poelm2'
  148. RETURN
  149. *
  150. * End of subroutine POELM2
  151. *
  152. END
  153.  
  154.  
  155.  
  156.  

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