Sources Esope | Cast3M

popoin
C POPOIN    SOURCE    PV        20/03/30    21:22:19     10567          
      SUBROUTINE POPOIN(P2ELPR,MELDUA,POPPOD,
     $     LPPPD,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : POPOIN
C DESCRIPTION : Maillage + liste indexée d'entiers (poelm2) + liste
C               d'entiers (ponbpo) => liste indexée d'entiers (un
C               point)->(numéro des points adjacents).
C
C     - Construire la liste indexée suivante (LPPPD) :
C         * Nombre de multiplets = nb points P1 de MELPRI
C         * pour chaque P1 : numéro des points P2 de MELDUA avec
C           lesquels il a une liaison.
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES (ESOPE)  : OOOETA
C APPELES          : ACTMEL, INIRPL, RPELEM, DESMEL
C APPELE PAR       : MAKPRM
C***********************************************************************
C ENTREES            : P2ELPR, MELDUA, POPPOD
C SORTIES            : LPPPD
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v2, 15/12/99
C HISTORIQUE : v1, 06/10/99, création
C HISTORIQUE : v2, 15/12/99, utilisation de liste 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 persos
*
*-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
      POINTEUR LPPPD.LSTIND
*
      INTEGER IMPR,IRET
*
      INTEGER POETA,P2LETA
      INTEGER ILPPPD,IDEPA,IELDUA,IPLDU,IPPRI
      INTEGER NBTVAL,NOELDU,NOSODU,NPODUA,NBPLDU,NPPRI,NUMELD,NBM
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans popoin.eso'
      CALL OOOETA(POPPOD,POETA,IMOD)
      IF (POETA.NE.1) SEGACT POPPOD
      NPPRI=POPPOD.LECT(/1)
C   On initialise le segment LPPPD
      NBM=NPPRI
      NBTVAL=0
      SEGINI LPPPD
      IDEPA=1
      DO 2 IPPRI=1,NPPRI
         LPPPD.IDX(IPPRI)=IDEPA
         IDEPA=IDEPA+POPPOD.LECT(IPPRI)
 2    CONTINUE
      LPPPD.IDX(NPPRI+1)=IDEPA
      IF (POETA.NE.1) SEGDES POPPOD
      NBTVAL=IDEPA-1
      SEGADJ LPPPD
* Activations
      CALL OOOETA(P2ELPR,P2LETA,IMOD)
      IF (P2LETA.NE.1) SEGACT P2ELPR
      JG=nbpts
      SEGINI IWORK
      CALL ACTMEL(MELDUA)
* In INIRPL : SEGINI RPDUAL
      CALL INIRPL(MELDUA,
     $     RPDUAL,
     $     IMPR,IRET)
      IF (IRET.NE.0) GOTO 9999
*
*   Parcourons le maillage
*
      DO 5 IPPRI=1,NPPRI
         ILPPPD=LPPPD.IDX(IPPRI)-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
                  ILPPPD=ILPPPD+1
                  LPPPD.IVAL(ILPPPD)=NPODUA
                  IWORK.LECT(NPODUA)=ILPPPD
               ENDIF
 522        CONTINUE
 52      CONTINUE
*     On remet le segment de travail à zéro
         DO 54 ILPPPD=LPPPD.IDX(IPPRI),LPPPD.IDX(IPPRI+1)-1
            IWORK.LECT(LPPPD.IVAL(ILPPPD))=0
 54      CONTINUE
 5    CONTINUE
      SEGSUP RPDUAL
      CALL DESMEL(MELDUA)
      SEGSUP IWORK
      IF (P2LETA.NE.1) SEGDES P2ELPR
      SEGDES LPPPD
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine popoin'
      RETURN
*
* End of subroutine POPOIN
*
      END