C ISOVA5    SOURCE    PV        20/03/24    21:18:24     10554          
      SUBROUTINE ISOVA5(NEWNOD,ELEMS,ITYPL)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : ISOVA5
C DESCRIPTION : La pile NEWNOD contient généralement des noeuds
*               géométriquement confondus : on les élimine.
*               Puis, on incrémente le segment MCOORD avec le nouveaux
*               noeuds non géométriquement confondus
*               et on met à jour les piles d'éléments.
C
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C VERSION    : v1, 15/09/2014, version initiale
C HISTORIQUE : v1, 15/09/2014, création
C HISTORIQUE :
C***********************************************************************

-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMLENTI
-INC CCREEL
-INC SMCOORD
*
* Segments ajustables 1D contenant les noeuds des éléments créés ainsi
* que leur couleur
* ELEM(1) contient des POI1
* ELEM(2) contient des SEG2
* ELEM(3) contient des TRI3
* ELEM(4) contient des TET4
* ELEM(5) contient des PYR5
* ELEM(6) contient des PRI6
* ELEM(7) contient des QUA4
*
      PARAMETER (NTYEL=7)
      SEGMENT ELEMS
      POINTEUR ELEM(NTYEL).MLENTI
      ENDSEGMENT
* Défini dans isova1
      INTEGER ITYPL(NTYEL)
*
* Pile des nouveaux noeuds
      SEGMENT NEWNOD
      INTEGER NNOD
      INTEGER NOEINF(MAXNOD)
      INTEGER NOESUP(MAXNOD)
      REAL*8  COEINF(MAXNOD)
      ENDSEGMENT
*
      segment newnum(nnod)
*
      SEGMENT ICPR(nbpts)
      segment inode(ino)
      segment jelnum(imaxel,ino)
      segment kelnum(imaxel,ino)
      segment xelnum(imaxel,ino)
*
      LOGICAL LFOUND
*
* Executable statements
*
**********************************************************************
*             Traitement des noeuds redondants
**********************************************************************
*
* Trouver les noeuds redondants dans NEWNOD
*
* Création d'une numérotation locale
      segini icpr
      ino=0
      do jnod=1,nnod
         ia=noesup(jnod)
         if(icpr(ia).eq.0) then
            ino=ino+1
            icpr(ia)=ino
         endif
      enddo
* on compte combien de segment touche un noeud
      segini inode
      do jnod=1,nnod
         ia=noesup(jnod)
         ib=icpr(ia)
         inode(ib)=inode(ib)+1
      enddo
      imaxel=0
      do i=1,ino
         imaxel=max(imaxel,inode(i))
*         inode(i)=0
      enddo
      segsup inode
* on crée les noeuds uniques et une nouvelle numérotation
* dans newnum(jnod) : si newnum(jnod)=knod>0 le noeud jnod est à garder
*                     et est numéroté knod dans la nouvelle num
*                     si newnum(jnod)=-knod<0 le noeud jnod est à
*                     supprimer, il est remplacé par knod dans la
*                     nouvelle num
      knod=0
      ired=0
      segini jelnum
      segini kelnum
      segini xelnum
      segini newnum
      do jnod=1,nnod
         ia=noesup(jnod)
         ib=icpr(ia)
         lfound=.false.
         do j=1,imaxel
            if (jelnum(j,ib).eq.0) then
               jelnum(j,ib)=noeinf(jnod)
               xelnum(j,ib)=coeinf(jnod)
               knod=knod+1
               kelnum(j,ib)=knod
               newnum(jnod)=knod
               goto 103
            elseif (jelnum(j,ib).eq.noeinf(jnod)) then
*               if (xelnum(j,ib).eq.coeinf(jnod)) then
* On met xzprec*10.D0 pour mimer le XTOL mis dans isoval.eso
               if (abs(xelnum(j,ib)-coeinf(jnod)).le.(xzprec*10.d0))
     $              then
                  lfound=.true.
                  newnum(jnod)=-kelnum(j,ib)
                  goto 103
               endif
            endif
         enddo
 103     continue
         if (lfound) then
            ired=ired+1
         else
            if (ired.gt.0) then
               noeinf(jnod-ired)=noeinf(jnod)
               noesup(jnod-ired)=noesup(jnod)
               coeinf(jnod-ired)=coeinf(jnod)
            endif
         endif
      enddo
      segsup jelnum
      segsup kelnum
      segsup xelnum
      if (ired.gt.0) then
*dbg         write(ioimp,*) 'il y a ired=',ired,' noeuds a eliminer'
*dbg2         write(ioimp,*) 'Nouvelle numerotation :'
*dbg2         write(ioimp,*) (newnum(i),i=1,newnum(/1))
         nnod=nnod-ired
         maxnod=nnod
         segadj,newnod
*
* Passage dans la nouvelle numérotation dans les piles
*
         do ipil=1,7
            mlenti=elem(ipil)
            nnode=nbnne(itypl(ipil))
            jg=lect(/1)
            ng=jg/(nnode+1)
            do ig=1,ng
               do iloc=1,nnode
                  idx=(nnode+1)*(ig-1)+iloc
*                  write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
*                  write(ioimp,*) '  idx=',idx
                  inod=lect(idx)
* esope n'aime pas trop la forme suivante
*                  if (inod.le.0) lect(idx)=-abs(newnum(-inod))
                  if (inod.le.0) lect(idx)=-abs(newnum(0-inod))
               enddo
            enddo
         enddo
      endif
      segsup newnum
*
* Création des nouveaux noeuds dans MCOORD et mise à jour
* des numéros dans les piles d'éléments
*
      SEGACT MCOORD*MOD
      IDIM1=IDIM+1
      NBANC=nbpts
*dbg      write(ioimp,*) 'Nombre de nouveaux/anciens noeuds=',NNOD,' ',NBANC
      NBPTS=NBANC+NNOD
      SEGADJ,MCOORD
      DO JNOD=1,NNOD
         num1=noeinf(jnod)
         num2=noesup(jnod)
         x1=coeinf(jnod)
         x2=1.D0-x1
         DO II=1,IDIM+1
            XCOOR((NBANC+JNOD-1)*IDIM1+II)=
     $           (XCOOR((NUM2-1)*IDIM1+II)*X2)+
     $           (XCOOR((NUM1-1)*IDIM1+II)*X1)
         ENDDO
      ENDDO
      SEGACT MCOORD
      SEGSUP NEWNOD
*
* Mise à jour des noeuds dans les piles (cette étape peut être faite
*juste avant la modif de MCOORD, on la garde pour clarté).
*
      do ipil=1,7
         mlenti=elem(ipil)
         nnode=nbnne(itypl(ipil))
         jg=lect(/1)
         ng=jg/(nnode+1)
         do ig=1,ng
            do iloc=1,nnode
               idx=(nnode+1)*(ig-1)+iloc
*                  write(ioimp,*) 'nnode=',nnode,' ig=',ig,' iloc=',iloc
*                  write(ioimp,*) '  idx=',idx
               inod=lect(idx)
               if (inod.le.0) lect(idx)=nbanc-inod
            enddo
         enddo
      enddo
*
* End of subroutine ISOVA5
*
      END