Sources Esope | Cast3M

ponbpo
C PONBPO    SOURCE    GOUNAND   25/04/30    21:15:27     12258          
      SUBROUTINE PONBPO(P2ELPR,MELDUA,
     $     POPPOD,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : PONBPO
C PROJET      : Noyau linéaire NLIN
C DESCRIPTION : Maillage + liste indexée d'entiers (poelm2) => liste
C               d'entiers (un point)->(nb. de points adjacents
C               i.e. appartenant aux mêmes éléments).
C
C         Construire la liste d'entiers suivante (POPPOD) :
C         * Nombre d'entiers = nb points P1 de MELPRI ;
C         * pour chaque P1 : nb. de points P2 de MELDUA avec lesquels il
C           a une liaison.
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          : ACTMEL, INIRPL, RPELEM
C APPELES (ESOPE)  : OOOETA
C APPELE PAR       : MAKPRM
C***********************************************************************
C ENTREES            : P2ELPR, MELDUA
C SORTIES            : POPPOD
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v2, 15/12/99
C HISTORIQUE : v1, 05/10/99, création
C HISTORIQUE : v2, 15/12/99, utilisation de listes chaînées
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
C Prière de PRENDRE LE TEMPS de compléter les commentaires
C en cas de modification de ce sous-programme afin de faciliter
C la maintenance !
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMELEME
      POINTEUR MELDUA.MELEME
      POINTEUR SOUMDU.MELEME
-INC SMLENTI
      INTEGER JG
      POINTEUR POPPOD.MLENTI
      POINTEUR RPDUAL.MLENTI
      POINTEUR IWORK.MLENTI
*
* Includes perso
*
*-INC SLSTIND
*
*     Segment LSTIND (liste séquentielle indexée)
*
      SEGMENT LSTIND
      INTEGER IDX(NBM+1)
      INTEGER IVAL(NBTVAL)
      ENDSEGMENT
*
*     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
*
*     NBM      : NOMBRE DE MULTIPLETS
*     NBTVAL   : NOMBRE TOTAL DE VALEURS
*     IDX(I)   : INDICE DE LA PREMIERE VALEUR DU IEME
*                MULTIPLET DANS LE TABLEAU IVAL
*     IVAL(IDX(I) -> IDX(I+1)-1) : VALEURS DU IEME MULTIPLET
      POINTEUR P2ELPR.LSTIND
      INTEGER IMPR,IRET
      INTEGER P2LETA
*
      INTEGER IELDUA,IPLDU, IPPRI
      INTEGER NUMELD,NBPLDU,NPPRI
      INTEGER NOELDU,NOSODU,NPODUA
      INTEGER LDG,ILDG,LAST,IPREC
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ponbpo'
      SEGACT P2ELPR
      NPPRI=P2ELPR.IDX(/1)-1
      JG=nbpts
      SEGINI IWORK
* Activations
      CALL ACTMEL(MELDUA)
* In INIRPL : SEGINI RPDUAL
      CALL INIRPL(MELDUA,
     $     RPDUAL,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
      JG=NPPRI
      SEGINI POPPOD
      DO 5 IPPRI=1,NPPRI
         LDG=0
* Fin de la liste chaînée
         LAST=-1
         DO 52 IELDUA=P2ELPR.IDX(IPPRI),
     $                P2ELPR.IDX(IPPRI+1)-1
            NUMELD=P2ELPR.IVAL(IELDUA)
            CALL RPELEM(NUMELD,RPDUAL,
     $           NOSODU,NOELDU,
     $           IMPR,IRET)
            IF (IRET.NE.0) GOTO 9999
            IF (NOSODU.NE.0) THEN
               SOUMDU=MELDUA.LISOUS(NOSODU)
            ELSE
               SOUMDU=MELDUA
            ENDIF
            NBPLDU=SOUMDU.NUM(/1)
            DO 522 IPLDU=1,NBPLDU
               NPODUA=SOUMDU.NUM(IPLDU,NOELDU)
               IF (IWORK.LECT(NPODUA).EQ.0) THEN
                  LDG=LDG+1
                  IWORK.LECT(NPODUA)=LAST
                  LAST=NPODUA
               ENDIF
 522        CONTINUE
 52      CONTINUE
*     Le nombre de points distincts trouvés est:
         POPPOD.LECT(IPPRI)=LDG
*     On remet la liste chaînée à 0
         DO 54 ILDG=1,LDG
            IPREC=IWORK.LECT(LAST)
            IWORK.LECT(LAST)=0
            LAST=IPREC
 54      CONTINUE
 5    CONTINUE
      SEGSUP RPDUAL
      SEGSUP IWORK
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine ponbpo'
      RETURN
*
* End of subroutine PONBPO
*
      END