Sources Esope | Cast3M

poelm2
C POELM2    SOURCE    CB215821  19/08/20    21:20:17     10287          
      SUBROUTINE POELM2(MAIL,KRIPO1,PONBEL,
     $     LSTPL,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C***********************************************************************
C NOM         : POELM2
C DESCRIPTION : Maillage + tableau de repérage de points + liste
C               d'entiers (ponbl2) => liste indexée d'entiers (un
C               point)->(numéro des éléments du maillage le contenant).
C
C         Construit une liste indexée LSTPL (type LSTIND)
C         * Nombre de multiplets = nb d'éléments de PONBEL ;
C         * chaque multiplet i : numéros des éléments de
C           MAIL contenant un point dont le numéro n
C           est tel que KRIPO1(n)=i.
C       (Le nombre de ces éléments est PONBEL(i), cf. ponbl2).
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 APPELE PAR       : MAKPRM
C***********************************************************************
C SYNTAXE GIBIANE    : -
C ENTREES            :
C ENTREES/SORTIES    : -
C SORTIES            : LSTPL (type LSTIND)
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 20/05/99, version initiale
C HISTORIQUE : v1, 20/05/99, création
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 SMELEME
      POINTEUR MAIL.MELEME
      POINTEUR SOUMAI.MELEME
-INC SMLENTI
      POINTEUR PONBEL.MLENTI
      POINTEUR KRIPO1.MLENTI
*
*     Segment LSTIND (liste séquentielle indexée)
*
      SEGMENT LSTIND
      INTEGER IDX(NBM+1)
      INTEGER IVAL(NBTVAL)
      ENDSEGMENT
*
*     LISTE SEQUENTIELLE INDEXEE D'ENTIERS
*
*     NBL      : 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
*
*-INC SLSTIND
      POINTEUR LSTPL.LSTIND
      POINTEUR ICOUR.LSTIND
*
      INTEGER IMPR,IRET
      INTEGER MAETA,KRETA,POETA,SMETA
      INTEGER INBEL,INBM,INBNO,INBSOU,IDEPA,IDXCOU
      INTEGER  NBEL, NBM, NBNO,NBSOUS
      INTEGER NBTVAL,NLOCP1,NPONB,NUELMA,NUMNO
*
* Executable statements
*
      IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans poelm2.eso'
      CALL OOOETA(PONBEL,POETA,IMOD)
      IF (POETA.NE.1) SEGACT PONBEL
      NPONB=PONBEL.LECT(/1)
C   On initialise le segment LSTPL
C              et le segment ICOUR
C     dans ICOUR, seul le tableau IDX nous intéresse
      NBM=NPONB
      NBTVAL=0
      SEGINI LSTPL
      IDEPA=1
      DO 2 INBM=1,NBM
         LSTPL.IDX(INBM)=IDEPA
         IDEPA=IDEPA+PONBEL.LECT(INBM)
 2    CONTINUE
      LSTPL.IDX(NBM+1)=IDEPA
      SEGINI,ICOUR=LSTPL
      NBTVAL=IDEPA-1
      SEGADJ LSTPL
      CALL OOOETA(KRIPO1,KRETA,IMOD)
      IF (KRETA.NE.1) SEGACT KRIPO1
*
*   Parcourons le maillage
*
      NUELMA=0
      CALL OOOETA(MAIL,MAETA,IMOD)
      IF (MAETA.NE.1) SEGACT MAIL
      NBSOUS=MAX(1,MAIL.LISOUS(/1))
      DO 4 INBSOU=1,NBSOUS
         IF (NBSOUS.EQ.1) THEN
            SOUMAI=MAIL
         ELSE
            SOUMAI=MAIL.LISOUS(INBSOU)
            CALL OOOETA(SOUMAI,SMETA,IMOD)
            IF (SMETA.NE.1) SEGACT SOUMAI
         ENDIF
         NBNO=SOUMAI.NUM(/1)
         NBEL=SOUMAI.NUM(/2)
         DO 42 INBEL=1,NBEL
            NUELMA=NUELMA+1
            DO 422 INBNO=1,NBNO
               NUMNO=SOUMAI.NUM(INBNO,INBEL)
               NLOCP1=KRIPO1.LECT(NUMNO)
               IF (NLOCP1.NE.0) THEN
                  IDXCOU=ICOUR.IDX(NLOCP1)
                  LSTPL.IVAL(IDXCOU)=NUELMA
                  ICOUR.IDX(NLOCP1)=IDXCOU+1
               ENDIF
 422        CONTINUE
 42      CONTINUE
 4    CONTINUE
      SEGDES LSTPL
      SEGSUP ICOUR
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine poelm2'
*
* End of subroutine POELM2
*
      END