Télécharger ponbpo.eso

Retour à la liste

Numérotation des lignes :

  1. C PONBPO SOURCE CHAT 05/01/13 02:17:35 5004
  2. SUBROUTINE PONBPO(P2ELPR,MELDUA,
  3. $ POPPOD,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : PONBPO
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : Maillage + liste indexée d'entiers (poelm2) => liste
  11. C d'entiers (un point)->(nb. de points adjacents
  12. C i.e. appartenant aux mêmes éléments).
  13. C
  14. C Construire la liste d'entiers suivante (POPPOD) :
  15. C * Nombre d'entiers = nb points P1 de MELPRI ;
  16. C * pour chaque P1 : nb. de points P2 de MELDUA avec lesquels il
  17. C a une liaison.
  18. C
  19. C LANGAGE : ESOPE
  20. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  21. C mél : gounand@semt2.smts.cea.fr
  22. C***********************************************************************
  23. C APPELES : ACTMEL, INIRPL, RPELEM
  24. C APPELES (ESOPE) : OOOETA
  25. C APPELE PAR : MAKPRM
  26. C***********************************************************************
  27. C ENTREES : P2ELPR, MELDUA
  28. C SORTIES : POPPOD
  29. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  30. C***********************************************************************
  31. C VERSION : v2, 15/12/99
  32. C HISTORIQUE : v1, 05/10/99, création
  33. C HISTORIQUE : v2, 15/12/99, utilisation de listes chaînées
  34. C HISTORIQUE :
  35. C HISTORIQUE :
  36. C***********************************************************************
  37. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  38. C en cas de modification de ce sous-programme afin de faciliter
  39. C la maintenance !
  40. C***********************************************************************
  41. -INC CCOPTIO
  42. -INC SMCOORD
  43. -INC SMELEME
  44. POINTEUR MELDUA.MELEME
  45. POINTEUR SOUMDU.MELEME
  46. -INC SMLENTI
  47. INTEGER JG
  48. POINTEUR POPPOD.MLENTI
  49. POINTEUR RPDUAL.MLENTI
  50. POINTEUR IWORK.MLENTI
  51. *
  52. * Includes perso
  53. *
  54. *-INC SLSTIND
  55. *
  56. * Segment LSTIND (liste séquentielle indexée)
  57. *
  58. SEGMENT LSTIND
  59. INTEGER IDX(NBM+1)
  60. INTEGER IVAL(NBTVAL)
  61. ENDSEGMENT
  62. *
  63. * LISTE SEQUENTIELLE INDEXEE D'ENTIERS
  64. *
  65. * NBM : NOMBRE DE MULTIPLETS
  66. * NBTVAL : NOMBRE TOTAL DE VALEURS
  67. * IDX(I) : INDICE DE LA PREMIERE VALEUR DU IEME
  68. * MULTIPLET DANS LE TABLEAU IVAL
  69. * IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
  70. POINTEUR P2ELPR.LSTIND
  71. INTEGER IMPR,IRET
  72. INTEGER P2LETA
  73. *
  74. INTEGER IELDUA,IPLDU, IPPRI
  75. INTEGER NUMELD,NBPLDU,NPPRI
  76. INTEGER NOELDU,NOSODU,NPODUA
  77. INTEGER LDG,ILDG,LAST,IPREC
  78. *
  79. * Executable statements
  80. *
  81. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ponbpo'
  82. CALL OOOETA(P2ELPR,P2LETA)
  83. IF (P2LETA.NE.1) SEGACT P2ELPR
  84. NPPRI=P2ELPR.IDX(/1)-1
  85. JG=XCOOR(/1)/(IDIM+1)
  86. SEGINI IWORK
  87. * Activations
  88. CALL ACTMEL(MELDUA)
  89. * In INIRPL : SEGINI RPDUAL
  90. CALL INIRPL(MELDUA,
  91. $ RPDUAL,
  92. $ IMPR,IRET)
  93. IF (IRET.NE.0) GOTO 9999
  94. JG=NPPRI
  95. SEGINI POPPOD
  96. DO 5 IPPRI=1,NPPRI
  97. LDG=0
  98. * Fin de la liste chaînée
  99. LAST=-1
  100. DO 52 IELDUA=P2ELPR.IDX(IPPRI),
  101. $ P2ELPR.IDX(IPPRI+1)-1
  102. NUMELD=P2ELPR.IVAL(IELDUA)
  103. CALL RPELEM(NUMELD,RPDUAL,
  104. $ NOSODU,NOELDU,
  105. $ IMPR,IRET)
  106. IF (IRET.NE.0) GOTO 9999
  107. IF (NOSODU.NE.0) THEN
  108. SOUMDU=MELDUA.LISOUS(NOSODU)
  109. ELSE
  110. SOUMDU=MELDUA
  111. ENDIF
  112. NBPLDU=SOUMDU.NUM(/1)
  113. DO 522 IPLDU=1,NBPLDU
  114. NPODUA=SOUMDU.NUM(IPLDU,NOELDU)
  115. IF (IWORK.LECT(NPODUA).EQ.0) THEN
  116. LDG=LDG+1
  117. IWORK.LECT(NPODUA)=LAST
  118. LAST=NPODUA
  119. ENDIF
  120. 522 CONTINUE
  121. 52 CONTINUE
  122. * Le nombre de points distincts trouvés est:
  123. POPPOD.LECT(IPPRI)=LDG
  124. * On remet la liste chaînée à 0
  125. DO 54 ILDG=1,LDG
  126. IPREC=IWORK.LECT(LAST)
  127. IWORK.LECT(LAST)=0
  128. LAST=IPREC
  129. 54 CONTINUE
  130. 5 CONTINUE
  131. SEGDES POPPOD
  132. SEGSUP RPDUAL
  133. CALL DESMEL(MELDUA)
  134. SEGSUP IWORK
  135. IF (P2LETA.NE.1) SEGDES P2ELPR
  136. *
  137. * Normal termination
  138. *
  139. IRET=0
  140. RETURN
  141. *
  142. * Format handling
  143. *
  144. *
  145. * Error handling
  146. *
  147. 9999 CONTINUE
  148. IRET=1
  149. WRITE(IOIMP,*) 'An error was detected in subroutine ponbpo'
  150. RETURN
  151. *
  152. * End of subroutine PONBPO
  153. *
  154. END
  155.  
  156.  
  157.  
  158.  

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