C ADCHPO    SOURCE    CHAT      09/04/08    21:15:01     6355           
      SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2)
C=======================================================================
C     
C     COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS
C  ENTREE
C     IPO1=POINTEUR SUR LE 1 CHAMPS PAR POINT
C     IPO2=POINTEUR SUR LE 2 CHAMPS PAR POINT
C     XCO1 ET XCO2 COEFFICIENTS APPLIQUES SUR LES CHAMPS
C  SORTIE
C     IRET= POINTEUR SUR LE CHAMP SOMME
C         = 0   SI SOMME IMPOSSIBLE
C     
C              MESSAGE D ERREUR DECLENCHE SI IRET=0
C     
C     CODE EBERSOLT JUILLET 84  MODIF HAMY NOVEMBRE 84
C     
C     POUR L INSTANT ON AUTORISE L ADDITION DE CHPOINTS DE SOUS
C     TYPE DIFFERENTS ( STOCKES DANS MTYPOI )
C     
C     CETTE ROUTINE FAIT APPEL A LA ROUTINE CRECHP
C     
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMCHPOI
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC TMTRAV
      SEGMENT/MTRA/(NOPOIN(XCOOR(/1)/(IDIM+1)))
      SEGMENT MTR1
      CHARACTER*4 IPCOM(0)
      ENDSEGMENT
      SEGMENT/MTR2/(IICOM(0))
      SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2)))
      SEGMENT/MTR4/(IPHAR(0))
      SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2),
     >     IZON(XCOOR(/1)/(IDIM+1)))
      segment mtr6
      character*4 mpcom(ncmax)
      integer     micom(ncmax),nicom(ncmax)
      integer     mphar(ncmax)
      endsegment
      logical errela
C     
C-----------------------------------------------------------------------
C               --- DESCRIPTION DES SEGMENTS DE TRAVAIL ---
C * MTRAV : - BB(I,J) EST LA VALEUR DE LA IEME INCONNUE DE CHAMP POUR
C          LE JIEME NOEUD DU TABLEAU IGEO .
C           - INCO(NNIN) CONTIENT LE NOM DES NNIN INCONNUES DIFFERENTES
C           - IBIN(I,J)=1 OU 0 INDIQUE QUE LA IEME INCONNUE DU CHAMP
C          EXISTE POUR LE JIEME NOEUD DU TABLEAU IGEO .
C           - IGEO(I) EST LE NUMERO A METTRE DANS UN OBJET MELEME POUR
C          REFERENCER LE IEME NOEUD .
C     
C * MTRA  : - NOPOIN(I) ADRESSE DE COLONNE DANS BB ET IBIN DES VALEURS
C          CORRESPONDANT AU NOEUD I .
C     
C * MTR1  : - IPCOM LISTE DES NOMS DES INCONNUES PERMET DE CREER INCO .
C     
C * MTR2  : - IICOM ADRESSE DANS IPCOM DES INCONNUES CORRESPONDANT AU
C          2IEME CH POINT .
C     
C * MTR3  : - INDEX TABLEAU DE CORRESPONDANCE ENTRE LES SUPPORTS GEOME-
C          TRIQUES DU 1ER CHPOINT ET DU 2IEME CHPOINT .
C-----------------------------------------------------------------------
      DIMENSION IPO(2),XXT(2)
      CHARACTER*8 MOT
C-----------------------------------------------------------------------
C     
C     MODIFIER ICI SI ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2
C     
C-----------------------------------------------------------------------
      XXT(1)=XCO1
      XXT(2)=XCO2
      XX=XXT(1)+XXT(2)
      errela = .false.
      werrla = 0.D0
      if (iret.eq.-2) errela = .true.
C     
      IF(IPO1.NE.IPO2) GOTO 60
C     
C-----------------------------------------------------------------------
C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX
C-----------------------------------------------------------------------
C     
      MCHPO1=IPO1
      SEGACT MCHPO1
      NSOUPO=MCHPO1.IPCHP(/1)
      NAT=MCHPO1.JATTRI(/1)
      SEGINI MCHPOI
      DO 10 I=1,NAT
         JATTRI(I)=MCHPO1.JATTRI(I)
 10   CONTINUE
      IRET=MCHPOI
      MOCHDE=MCHPO1.MOCHDE
      MTYPOI=MCHPO1.MTYPOI
      IFOPOI=IFOMOD
      DO 50 IA=1,NSOUPO
         MSOUP1=MCHPO1.IPCHP(IA)
         SEGACT MSOUP1
         NC=MSOUP1.NOCOMP(/2)
         SEGINI MSOUPO
         IPCHP(IA)=MSOUPO
         DO 20 IB=1,NC
            NOCOMP(IB)=MSOUP1.NOCOMP(IB)
            NOHARM(IB)=MSOUP1.NOHARM(IB)
 20      CONTINUE
         IGEOC=MSOUP1.IGEOC
         MPOVA1=MSOUP1.IPOVAL
         SEGACT MPOVA1
         N  =MPOVA1.VPOCHA(/1)
         NC1=MPOVA1.VPOCHA(/2)
         IF(NC1.EQ.NC)  GOTO 30
C     
C     ERREUR PB DIMENSION TABLEAU VOIR ROUTINE ADCHPO
C     
         IRET=0
         SEGDES MPOVA1,MSOUP1,MCHPO1
         SEGSUP MSOUPO,MCHPOI
         CALL ERREUR(114)
         GOTO 666
 30      CONTINUE
         SEGINI MPOVAL
         IPOVAL=MPOVAL
         DO 40 IC=1,NC
            DO 41 IB=1,N
               VPOCHA(IB,IC)=XX*MPOVA1.VPOCHA(IB,IC)
 41         CONTINUE
 40      CONTINUE
         SEGDES MPOVAL,MPOVA1,MSOUPO,MSOUP1
 50   CONTINUE
      SEGDES MCHPOI,MCHPO1
      GOTO 666
C     
C-----------------------------------------------------------------------
C *** CAS  OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
C-----------------------------------------------------------------------
C     
 60   CONTINUE
      MCHPO1=IPO1
      MCHPO2=IPO2
      IPO(1)=IPO1
      IPO(2)=IPO2
      SEGACT MCHPO1,MCHPO2
      MOT=MCHPO1.MTYPOI
      IF(MOT.NE.MCHPO2.MTYPOI) THEN
         MOT='adchpo'
      ENDIF
C     
C     ON REGARDE SI UN CHAMP EST INCLUS DANS L'AUTRE
C 
      segact mcoord    
      MCHPO1=IPO1
      MCHPO2=IPO2
      SEGACT MCHPO1,MCHPO2
      NSOUP1=MCHPO1.IPCHP(/1)
      NSOUP2=MCHPO2.IPCHP(/1)
      NAT1 = MCHPO1.JATTRI(/1)
      NAT2 = MCHPO2.JATTRI(/1)
C     
C     ON REGARDE SI on peut se passer de repartionner la geometrie
C     
      SEGINI MTR5
      SEGINI MTR3
      ncmax2=0
      nposr=0
      DO 100 IB=1,NSOUP2
         MSOUP2=MCHPO2.IPCHP(IB)
         SEGACT MSOUP2
         ncmax2=max(ncmax2,msoup2.nocomp(/2))
         ipt2=MSOUP2.IGEOC
         segact ipt2
         do 101 iel=1,ipt2.num(/2)
            izon(ipt2.num(1,iel))=ib
 101     continue
 100  continue
      ncmax1=0
      do 105 ia=1,nsoup1
         msoup1=mchpo1.ipchp(ia)
         segact msoup1
         ncmax1=max(ncmax1,msoup1.nocomp(/2))
         ipt1=msoup1.igeoc
         segact ipt1
         ib=0
         if (ipt1.num(/2).gt.0) ib=izon(ipt1.num(1,1))
         if (ib.eq.0) then
            do 106 iel=1,ipt1.num(/2)
               if (izon(ipt1.num(1,iel)).ne.0) then
                  if (iimpi.eq.1954)
     >                 write (ioimp,*)
     $                 ' adchpo zone 1ch coupe zone 2ch ',ia
     $                 ,izon(ipt1.num(1,iel))
                  goto 109
               endif
 106        continue
            goto 105
         endif
         MSOUP2=MCHPO2.IPCHP(IB)
*  si meme nombre d'elements on compare les meleme
         ipt2=msoup2.igeoc
         IF(ipt1.eq.ipt2) GO TO 90
         if (ipt1.num(/2).ne.ipt2.num(/2))then
            if (iimpi.eq.1954)
     >           write (ioimp,*) ' adchpo nbel diff ',ipt1.num(/2)
     $           ,ipt2.num(/2)
            goto 109
         endif
         do 84 iel=1,ipt1.num(/2)
            if (izon(ipt1.num(1,iel)).ne.ib) then
               if (iimpi.eq.1954)
     >              write (ioimp,*) ' adchpo zone mismatch '
               goto 109
            endif
 84      continue
 90      CONTINUE
         nposr=nposr+1
         ipos1(ia)=1
         ipos2(ib)=1
         INDEX(ia)=IB
 105  CONTINUE
      npaq1=0
      do 82 ipaq=1,nsoup1
         npaq1=npaq1+ipos1(ipaq)
 82   continue
      npaq2=0
      do 83 ipaq=1,nsoup2
         npaq2=npaq2+ipos2(ipaq)
 83   continue
      if (iimpi.eq.1954) write (ioimp,*) ' adchpo rapide '
      goto 108
 109  continue
C     
C     tous les meleme de l'un ne sont pas inclus dans l'autre
C     
      SEGDES MSOUP1,MCHPO1,MCHPO2
      SEGSUP MTR3,MTR5
      GO TO 300
 108  continue
C     
C *** CAS OU LES SUPPORTS GEOMETRIQUES DE L'UN SONT INCLUS DANS L'AUTRE
C     
      NSOUPO=NSOUP1+NSOUP2-nposr
      NAT=MAX(NAT1,NAT2,1)
      SEGINI MCHPOI
      IF ( MIN(NAT1,NAT2) .GE. 1) THEN
         IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
            JATTRI(1)= MCHPO1.JATTRI(1)
         ELSE
            JATTRI(1)=0
         ENDIF
      ELSE
         JATTRI(1)=0
      ENDIF
      IRET=MCHPOI
      MTYPOI=MOT
      MOCHDE=MCHPO1.MOCHDE
      IFOPOI=IFOMOD
      ncmax=ncmax1+ncmax2
*goo      SEGINI mtr6
      nposr=0
      DO 250 IA=1,NSOUP1
         SEGINI mtr6
         if (ipos1(ia).eq.0) goto 250
         MSOUP1=MCHPO1.IPCHP(IA)
         MSOUP2=MCHPO2.IPCHP(INDEX(IA))
         SEGACT MSOUP1,MSOUP2
C     
C     COMPARAISON DES NOMS DES COMPOSANTES
C     
         NC1=MSOUP1.NOCOMP(/2)
         NC2=MSOUP2.NOCOMP(/2)
         DO 130 IB=1,NC1
            mpcom(ib)=MSOUP1.NOCOMP(IB)
            mphar(ib)=MSOUP1.NOHARM(IB)
 130     CONTINUE
         mc=nc1
         DO 160 IB=1,NC2
            DO 140 IC=1,NC1
               IF(MSOUP2.NOCOMP(IB).NE.MSOUP1.NOCOMP(IC)) GOTO 140
              IF(MSOUP2.NOHARM(IB).EQ.MSOUP1.NOHARM(IC)) GOTO 150
 140        CONTINUE
            mc=mc+1
            mpcom(mc)=MSOUP2.NOCOMP(IB)
            mphar(mc)=MSOUP2.NOHARM(IB)
            micom(ib)=mc
            GO TO 160
 150        CONTINUE
            micom(ib)=ic
            nicom(ic)=1
 160     CONTINUE
C     
         MPOVA1=MSOUP1.IPOVAL
         MPOVA2=MSOUP2.IPOVAL
         SEGACT MPOVA1,MPOVA2
         N1=MPOVA1.VPOCHA(/1)
         N2=MPOVA2.VPOCHA(/1)
         NCX1=MPOVA1.VPOCHA(/2)
         NCX2=MPOVA2.VPOCHA(/2)
         IF(NCX1.NE.NC1) GOTO 170
         IF(NCX2.NE.NC2) GOTO 170
         IF(N1.NE.N2)    GOTO 170
         GOTO 180
 170     CONTINUE
         SEGDES MSOUP1,MSOUP2,MPOVA1,MPOVA2,MCHPO1,MCHPO2
         SEGSUP MTR6,MCHPOI,MTR3,MTR5
C     
C     PB AVEC LES DIMENSIONS DES CHPOINTS
C     
         CALL ERREUR(114)
         IRET=0
         GOTO 666
*
 180     CONTINUE
*
         N=N1
         NC=mc
         SEGINI MPOVAL
C     
C     recopier le premier chpo
C     
         DO 210 IC=1,NC1
            if (nicom(ic).eq.0) then
               DO 200 IB=1,N
                  VPOCHA(IB,IC)=XXT(1)*MPOVA1.VPOCHA(IB,IC)
                  if(errela) VPOCHA(IB,IC)= dabs(VPOCHA(IB,IC))
 200           CONTINUE
            endif
 210     CONTINUE
C     
C     rajouter le second
C     
         ipt1=msoup1.igeoc
         ipt2=msoup2.igeoc
*  si les numerotations sont differentes il faut reordonner
         if (ipt1.ne.ipt2) then
            do 229 iel=1,ipt2.num(/2)
               izon(ipt2.num(1,iel))=iel
 229        continue
            DO 230 IC=1,NC2
               IIC=micom(ic)
               if (iic.gt.nc1) then
                  DO 221 IB=1,N
                     VPOCHA(IB,IIC)=XXT(2)*
     $                    MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
                     if(errela) VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC))
 221              CONTINUE
               else
                  DO 220 IB=1,N
                     VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)
     $                    +XXT(2)*MPOVA2.VPOCHA(izon(ipt1.num(1,ib))
     $                    ,IC)
                     if(errela.and. MPOVA2.VPOCHA(izon(ipt1.num(1,ib)
     $                    ),IC).ne.0)
     $                    VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC)
     $                    /MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC))
 220              CONTINUE
               endif
 230        CONTINUE
         else
*  meme pointeur geometrique on se passe de izon
            DO 235 IC=1,NC2
               IIC=micom(ic)
               if (iic.gt.nc1) then
                  DO 236 IB=1,N
                     VPOCHA(IB,IIC)=XXT(2)*MPOVA2.VPOCHA(IB,IC)
                     if(errela) VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC))
 236              CONTINUE
               else
                  DO 237 IB=1,N
                     VPOCHA(IB,IIC)=XXT(1)*mpova1.VPOCHA(IB,IIC)+
     >                    XXT(2)*MPOVA2.VPOCHA(IB,IC)
                     if(errela.and.MPOVA2.VPOCHA(IB,IC).ne.0)
     &                    VPOCHA(IB,IIC)= dabs(VPOCHA(IB,IIC)
     $                    /MPOVA2.VPOCHA(IB,IC))
 237              CONTINUE
               endif
 235        CONTINUE
         endif
         SEGDES MPOVA2
         SEGDES MPOVA1
C     
         SEGINI MSOUPO
         DO 240 IB=1,NC
            NOCOMP(IB)=mpcom(ib)
            NOHARM(IB)=mphar(ib)
 240     CONTINUE
         IPOVAL=MPOVAL
         SEGDES MPOVAL
         IPT3=IPT1
         IGEOC=IPT3
         SEGDES IPT1,ipt2,ipt3
         nposr=nposr+1
         IPCHP(nposr)=MSOUPO
         SEGDES MSOUP1,MSOUP2
         SEGSUP MTR6
 250  CONTINUE
*goo      SEGSUP MTR6
*  il faut maintenant adjoindre les paquets de 1 pas dans 2 ou inversement
      DO 251 IA=1,NSOUP1
         if (ipos1(ia).ne.0) goto 251
         nposr=nposr+1
         msoupo=mchpo1.ipchp(ia)
         segini,msoup1=msoupo
         ipchp(nposr)=msoup1
         ipt1=msoup1.igeoc
*       segini,ipt2=ipt1
         ipt2=ipt1
         msoup1.igeoc=ipt2
         mpoval=msoup1.ipoval
         segact mpoval
         n=vpocha(/1)
         nc=vpocha(/2)
         segini,mpova1
         do 254 jb=1,nc
            do 2541 ja=1,n
               mpova1.vpocha(ja,jb)=xxt(1)*vpocha(ja,jb)
               if(errela) MPOVA1.VPOCHA(JA,JB)= 
     $              dabs(MPOVA1.VPOCHA(JA,JB))
 2541       continue
 254     continue
         msoup1.ipoval=mpova1
         segdes ipt1,msoupo,ipt2,mpoval,mpova1
 251  continue
      DO 252 IB=1,NSOUP2
         if (ipos2(ib).ne.0) goto 252
         nposr=nposr+1
         msoupo=mchpo2.ipchp(ib)
         segini,msoup1=msoupo
         ipchp(nposr)=msoup1
         ipt1=msoup1.igeoc
*       segini,ipt2=ipt1
         ipt2=ipt1
         msoup1.igeoc=ipt2
         mpoval=msoup1.ipoval
         segact mpoval
         n=vpocha(/1)
         nc=vpocha(/2)
         segini,mpova1
         do 253 jb=1,nc
            do 2531 ja=1,n
               mpova1.vpocha(ja,jb)=xxt(2)*vpocha(ja,jb)
               if(errela) MPOVA1.VPOCHA(JA,JB)= 
     $              dabs(MPOVA1.VPOCHA(JA,JB))
 2531       continue
 253     continue
         msoup1.ipoval=mpova1
         segdes ipt1,msoupo,ipt2,mpoval,mpova1
 252  continue
*  verification que les composantes sont bien differentes entre paquets
      do 255 isoupo=1,ipchp(/1)
         msoup1=ipchp(isoupo)
         SEGACT MSOUP1
         nc1=msoup1.nocomp(/2)
         do 256 jsoupo=isoupo+1,ipchp(/1)
            msoup2=ipchp(jsoupo)
            SEGACT MSOUP2
            nc2=msoup2.nocomp(/2)
            if (nc1.ne.nc2) goto 256
            do 257 ic1=1,nc1
               do 258 ic2=1,nc2
                  if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2))
     $                 goto 258
                  if (msoup1.nocomp(ic1).eq.msoup2.nocomp(ic2))
     $                 goto 257
 258           continue
               goto 256
 257        continue
*  pas de chance composantes en double
            if (iimpi.eq.1954) write (ioimp,*)
     $           ' pacquets en double => lent '
            segsup mtr3,mtr5
            goto 300
 256     continue
         segdes msoup1
 255  continue
      SEGSUP MTR3,MTR5
      SEGDES MCHPOI,MCHPO1,MCHPO2
      GOTO 666
C     
C *** CAS OU LES SUPPORTS GEOMETRIQUES NE SONT PAS IDENTIQUES
C *** A UNE PERMUTATION PRES
C     
 300  CONTINUE
C     
      SEGINI MTRA,MTR1,MTR4
C     
      MCHPOI=IPO1
      SEGACT MCHPOI
      MSOUPO=IPCHP(1)
      SEGACT MSOUPO
      IPCOM(**)=NOCOMP(1)
      IPHAR(**)=NOHARM(1)
      SEGDES MSOUPO,MCHPOI
      NC=1
      IK=0
C     
C     CREATION DE NOPOIN ET DE IPCOM
C     
      DO 360 ICH=1,2
         MCHPOI=IPO(ICH)
         SEGACT MCHPOI
         NSOUPO=IPCHP(/1)
C     
C     BOUCLE SUR LES SOUS REFERENCES D 1 CHPOINT
C     
         DO 350 IA=1,NSOUPO
            MSOUPO=IPCHP(IA)
            SEGACT MSOUPO
            MELEME=IGEOC
            SEGACT MELEME
            NBNN  =NUM(/1)
            NBELEM=NUM(/2)
C     IF(NBNN.NE.1) GOTO 777
            DO 310 IB=1,NBELEM
               K=NUM(1,IB)
               IF(NOPOIN(K).NE.0) GO TO 310
               IK=IK+1
               NOPOIN(K)=IK
 310        CONTINUE
            SEGDES MELEME
            NCBBB=NOCOMP(/2)
            DO 330 IB=1,NCBBB
               NC=IPCOM(/2)
               DO 320 IC=1,NC
                  IF(IPCOM(IC).NE.NOCOMP(IB)) GO TO 320
                  IF(IPHAR(IC).EQ.NOHARM(IB))  GO TO 330
 320           CONTINUE
               IPCOM(**)=NOCOMP(IB)
               IPHAR(**)=NOHARM(IB)
               NC=NC+1
 330        CONTINUE
            SEGDES MSOUPO
 350     CONTINUE
         SEGDES MCHPOI
 360  CONTINUE
C     
      NNIN=NC
      NNNOE=IK
      SEGINI MTRAV
C     
C     CREATION DE INCO
C     
      DO 380 IA=1,NNIN
         INCO(IA)=IPCOM(IA)
         NHAR(IA)=IPHAR(IA)
 380  CONTINUE
C     
C     CREATION DE BB,IBIN,IGEO
C     
      MCHPOI=IPO(1)
      SEGACT MCHPOI
      NSOUPO=IPCHP(/1)
      DO 1430 IA=1,NSOUPO
         MSOUPO=IPCHP(IA)
         SEGACT MSOUPO
         MELEME=IGEOC
         SEGACT MELEME
         MPOVAL=IPOVAL
         SEGACT MPOVAL
         NBELEM=NUM(/2)
         N=VPOCHA(/1)
         NC=VPOCHA(/2)
         NC1=NOCOMP(/2)
C     
         DO 1420 IB=1,NC1
            DO 1390 IC=1,NNIN
               IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 1390
               IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 1400
 1390       CONTINUE
 1400       CONTINUE
            DO 1410 ID=1,NBELEM
               KI=NOPOIN(NUM(1,ID))
               IGEO(KI)=NUM(1,ID)
               IBIN(IC,KI)=1
               BB(IC,KI)=XXT(1)*VPOCHA(ID,IB)
 1410       CONTINUE
 1420    CONTINUE
         SEGDES MELEME,MSOUPO,MPOVAL
 1430 CONTINUE
      SEGDES MCHPOI
      MCHPOI=IPO(2)
      XSIGN=XXT(2)
      SEGACT MCHPOI
      NSOUPO=IPCHP(/1)
      DO 430 IA=1,NSOUPO
         MSOUPO=IPCHP(IA)
         SEGACT MSOUPO
         MELEME=IGEOC
         SEGACT MELEME
         MPOVAL=IPOVAL
         SEGACT MPOVAL
         NBELEM=NUM(/2)
         N=VPOCHA(/1)
         NC=VPOCHA(/2)
         NC1=NOCOMP(/2)
C     
         DO 420 IB=1,NC1
            DO 390 IC=1,NNIN
               IF(NOCOMP(IB).NE.IPCOM(IC)) GO TO 390
               IF(NOHARM(IB).EQ.IPHAR(IC)) GO TO 400
 390        CONTINUE
 400        CONTINUE
            DO 410 ID=1,NBELEM
               KI=NOPOIN(NUM(1,ID))
               IGEO(KI)=NUM(1,ID)
               IBIN(IC,KI)=1
               BB(IC,KI)=BB(IC,KI)+XXT(2)*VPOCHA(ID,IB)
 410        CONTINUE
 420     CONTINUE
         SEGDES MELEME,MSOUPO,MPOVAL
 430  CONTINUE
      SEGDES MCHPOI
      ITRAV=MTRAV
      SEGDES MTRAV
C     
C     RECONSTUCTION DE LA PARTITION
C     
      CALL CRECHP(ITRAV,ICHPOI)
C     
      SEGSUP MTRAV,MTRA,MTR1,MTR4
      IRET=ICHPOI
      MCHPOI=ICHPOI
      MCHPO1 = IPO1
      MCHPO2 = IPO2
      SEGACT MCHPOI,MCHPO1,MCHPO2
      NAT1 = MCHPO1.JATTRI(/1)
      NAT2 = MCHPO2.JATTRI(/1)
      NAT=MAX(NAT1,NAT2,1)
      NSOUPO = IPCHP(/1)
      SEGADJ MCHPOI
      IRET=MCHPOI
      MTYPOI=MOT
      IF ( MIN(NAT1,NAT2) .GE. 1) THEN
         IF (MCHPO1.JATTRI(1) .EQ. MCHPO2.JATTRI(1)) THEN
            JATTRI(1)= MCHPO1.JATTRI(1)
         ELSE
            JATTRI(1)=0
         ENDIF
      ELSE
         JATTRI(1)=0
      ENDIF
      SEGDES MCHPOI,MCHPO1,MCHPO2
C     
 666  CONTINUE
      RETURN
      END