C PART4     SOURCE    PV        09/03/27    21:15:14     6347           
*  partitionne meleme dans itab en fonction du contenu de ipos
*
      SUBROUTINE PART4(MELEME,IPOS,ICPR,NB,ITAB,IADJ,JADJC)
*
      IMPLICIT INTEGER(I-N)
-INC SMELEME
-INC CCOPTIO
      segment ifait(2**nb)
      segment ipos(0)
      segment icpr(0)
      segment iadj(0)
      segment jadjc(0)
      CALL CRTABL(ITAB)
      CALL ECCTAB(ITAB,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,
     #                  0,'MOT',0,0.D0,'ESCLAVE',.TRUE.,0)
  90  continue
      segini ifait
      nodes=ipos(/1)/3
*  boucle sur les zones de maillages à creer
      izr=0
      do 10 iz=1,2**nb
      segact meleme
      nbnn=0
      nbelem=0
      nbref=0
      nbsous=max(1,lisous(/1))
      segini,ipt4
      jsous=0
      ipt1=meleme
      do 20 isous=1,max(1,lisous(/1))
      if (lisous(/1).ne.0) ipt1=lisous(isous)
      segact ipt1
      segini,ipt5=ipt1
      do 30 j=1,ipt5.num(/2)
      ifro=1
      do 40 i=1,ipt5.num(/1)
        ip=icpr(ipt5.num(i,j))
        if (ipos(2*nodes+ip).lt.nb) goto 40
        ifro=0
        if (ifait(iz).eq.0) then
          do k=1,iz-1
           if (ifait(k).eq.ipos(nodes+ip)) goto 35
          enddo
          ifait(iz)=ipos(nodes+ip)
        endif
        if (ifait(iz).eq.ipos(nodes+ip)) goto 37
  40  continue
      if (ifro.eq.1) then
* embetant tous les noeuds sont sur la frontiere
* recherche de la zone voisine la plus grande
       izone=0
**     write (6,*) ' element sur la frontiere ',ipt5.num(/1)

       do 60 i=1,ipt5.num(/1)
        ip=icpr(ipt5.num(i,j))
        do 65 iv=iadj(ip),iadj(ip+1)-1
         K=JADJC(iv)
*        write (6,*) ' noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
*    >  'nb ',nb
         if (ipos(2*nodes+k).lt.nb) goto 65
         izone=max(izone,ipos(nodes+k))
  65    continue
  60   continue
       if (izone.eq.0) then
* on essaye un peu plus loin
       do 80 i=1,ipt5.num(/1)
        ip=icpr(ipt5.num(i,j))
        do 85 iv=iadj(ip),iadj(ip+1)-1
        ivv=jadjc(iv)
        do 85 iw=iadj(ivv),iadj(ivv+1)-1
         K=JADJC(iw)
*        write (6,*) ' noeud ',ip,' vois ',k,' zone ',ipos(2*nodes+k),
*    >  'nb ',nb
         if (ipos(2*nodes+k).lt.nb) goto 85
         izone=max(izone,ipos(nodes+k))
  85    continue
  80   continue
        if (izone.eq.0) call erreur(920)
        if (ierr.ne.0) return
       endif
        if (ifait(iz).eq.0) then
          do k=1,iz-1
           if (ifait(k).eq.izone) goto 35
          enddo
          ifait(iz)=izone
        endif
       if (izone.eq.ifait(iz)) goto 37
      endif
  35  continue
* on annule l'element
      ipt5.num(1,j)=0
  37  continue
  30  continue
*  compaction de ipt5
      jf=0
      do 50 j=1,ipt5.num(/2)
      if (ipt5.num(1,j).eq.0) goto 50
      jf=jf+1
      ipt5.icolor(jf)=ipt5.icolor(j)
      do i=1,ipt5.num(/1)
        ipt5.num(i,jf)=ipt5.num(i,j)
      enddo
  50  continue
      nbnn=ipt5.num(/1)
      nbelem=jf
      nbsous=0
      nbref=0
      segadj ipt5
      segdes ipt5
      if (jf.ne.0) then
        jsous=jsous+1
        ipt4.lisous(jsous)=ipt5
      else
        segsup ipt5
      endif
      segdes ipt1
  20  continue
      nbsous=jsous
      nbref=0
      nbnn=0
      nbelem=0
      segadj ipt4
      if (jsous.eq.1) then
         ipt5=ipt4.lisous(1)
         segsup ipt4
         ipt4=ipt5
      endif
      segdes meleme,ipt4
      if (jsous.eq.0) goto 10
      izr=izr+1
      CALL ECCTAB(ITAB,'ENTIER',izr,0.D0,' ',.TRUE.,
     #                   0,'MAILLAGE',0,0.D0,' ',.TRUE.,ipt4)
  10  continue
      segsup ifait,ipos,icpr,iadj,jadjc
      end