C EXTO5C    SOURCE    GOUNAND   26/06/09    21:15:05     12566          
      SUBROUTINE EXTO5C(JELEM2,TRAVJ,
     $     TRAVX)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : EXTO5C
C DESCRIPTION : Extraction de la topologie locale proprement dite
C               s'appuyant sur les noeuds stocke dans le maillage
C                JELEM2
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SEMT/LTA)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C APPELES          :
C APPELES (E/S)    :
C APPELES (BLAS)   :
C APPELES (CALCUL) :
C APPELE PAR       :
C***********************************************************************
C SYNTAXE GIBIANE    :
C ENTREES            : JELEM2, TRAVJ
C ENTREES/SORTIES    : TRAVX
C SORTIES            :
C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
C***********************************************************************
C VERSION    : v1, 13/11/2025, version initiale
C HISTORIQUE : v1, 13/11/2025, création
C HISTORIQUE :
C HISTORIQUE :
C***********************************************************************
-INC PPARAM
-INC CCOPTIO
-INC SMLENTI
      POINTEUR JNBL.MLENTI
      POINTEUR NEXTO.MLENTI
-INC TMATOP2
-INC TMATOP1
      POINTEUR TRAVX.TRAVJ
      POINTEUR JELEM2.MELEMX
*
      logical lchang
*
* Executable statements
*
      if (impr.ge.5) WRITE(IOIMP,*) 'Entrée dans exto5c.eso'
*
      IDIMP=IDIM+1
      TOPINV=TRAVJ.TOPI
      JNBL=TRAVJ.NBL
      NEXTO=TRAVX.NBL
*     On gère le cas où certains noeuds de JELEM2 sont nuls ou ne sont
*     plus dans la topologie
      NPOJEL=0
      NL2=JELEM2.NLCOU
      DO IPO=1,NL2
         IP=JELEM2.NUMX(1,IPO)
         IF (IP.NE.0) THEN
            IF (TDC(IP).NE.0) THEN
               NPOJEL=NPOJEL+1
            ENDIF
         ENDIF
      ENDDO
*
*     Dans le cas où NPOJEL<IDIMP : maillage vide
*
      IF (NPOJEL.LT.IDIMP) THEN
         NVXCOU=0
         TRAVX.NVCOU=NVXCOU
      ELSE
*
*     Les éléments des autres noeuds de JELEM
*     + on compte le nombre d'éléments à construire
*
         NLEXT=0
         DO IPO=1,NL2
            IP=JELEM2.NUMX(1,IPO)
            IF (IP.NE.0) THEN
               LDG=TDC(IP)
               IF (LDG.NE.0) THEN
                  LAST=TIC(IP)
                  DO IDG=1,LDG
                     IL=((LAST-1)/IDIMP)+1
                     JNBL.LECT(IL)=JNBL.LECT(IL)+1
                     IF (JNBL.LECT(IL).EQ.IDIMP) NLEXT=NLEXT+1
                     LAST=TLC(LAST)
                  ENDDO
                  if (impr.ge.5) then
*                  write(ioimp,*) 'Apres point IELEM(',IPOJEL,',1)=',IP
*     $                 ,' ; NBL='
                     write(ioimp,188) IPO,IP
                     write(ioimp,187)  (JNBL.LECT(I),I=1,jnbl.lect(/1))
                  endif
               ENDIF
            ENDIF
         ENDDO
*
*     On parcourt une dernière fois le IMIN pour construire le maillage
*     extrait et mettre à zéro TRAVV
*
         NVXCOU=NLEXT
         CALL TOPADV(TRAVX,NVXCOU,1,lchang,'exto5c : TRAVX npojel>1')
         if (ierr.ne.0) return
         if (iveri.ge.2.and.lchang) then
            call vetopi(travx,'exto5c : Apres extension travx npojel>1')
            if (ierr.ne.0) return
         endif
*
         NEXTO=TRAVX.NBL
*
         IELL=1
         DO IPO=1,NL2
            IP=JELEM2.NUMX(1,IPO)
            IF (IP.NE.0) THEN
               LDG=TDC(IP)
               IF (LDG.NE.0) THEN
                  LAST=TIC(IP)
                  DO IDG=1,LDG
                     IL=((LAST-1)/IDIMP)+1
                     IF (JNBL.LECT(IL).EQ.IDIMP) THEN
*     Remplissage à l'envers (inverse l'ordre des éléments par rapport a
*     JTOPO)
*               IEL=IELL
*     Remplissage à l'endroit (garde l'ordre des éléments par rapport a
*     JTOPO)
                        IEL=NLEXT+1-IELL
                        nexto.lect(iel)=il
                        IELL=IELL+1
                     ENDIF
* Nettoyage TRAVV NBL
                     JNBL.LECT(IL)=0
                     LAST=TLC(LAST)
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
      ENDIF
*      if (impr.gt.2) then
*         write(ioimp,*)
*     $        'Elements de la topologie extraits :'
*         write(ioimp,187)  (nexto.lect(I),I=1,nvxcou)
*      endif
*
* Normal termination
*
      RETURN
*
* Format handling
*
 187  FORMAT (5X,10I8)
 188  FORMAT ('Apres point IELEM(',I2,',1)=',I6,' ; NBL=')
*
* Error handling
*
 9999 CONTINUE
      MOTERR(1:8)='EXTO5C  '
* 349 2
*Problème non prévu dans le s.p. %m1:8 contactez votre assistance
      CALL ERREUR(349)
      RETURN
*
* End of subroutine EXTO5C
*
      END