C ADCHPO    SOURCE    GOUNAND   25/11/12    21:15:02     12399          
      SUBROUTINE ADCHPO(IPO1,IPO2,IRET,XCO1,XCO2)
C=======================================================================
C
C     COMBINAISON LINEAIRE DE 2 CHPS PAR POINTS
C-----------------------------------------------------------------------
C     ON VEUT FAIRE FLO1*CHP1 + FLO2*CHP2
C-----------------------------------------------------------------------
C  ENTREE
C     IPO1=POINTEUR SUR LE 1 CHAMP PAR POINT
C     IPO2=POINTEUR SUR LE 2 CHAMP 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 PPARAM
-INC CCOPTIO

-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
-INC TMTRAV
      SEGMENT/MTRA/(NOPOIN(nbpts))
      SEGMENT MTR1
        CHARACTER*(LOCOMP) IPCOM(0)
      ENDSEGMENT
      SEGMENT/MTR2/(IICOM(0))
      SEGMENT/MTR3/(INDEX(max(nsoup1,nsoup2)))
      SEGMENT/MTR4/(IPHAR(0))
      SEGMENT/MTR5/(IPOS1(NSOUP1),IPOS2(NSOUP2),
     >     IZON(nbpts))
      segment mtr6
      character*(LOCOMP) mpcom(ncmax)
      integer     micom(ncmax),nicom(ncmax)
      integer     mphar(ncmax)
      endsegment

      character*(LOCOMP)MOCOMP
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)
      CHARACTER*8 MOT
C
      IF(IPO1.NE.IPO2) GOTO 60
C
C-----------------------------------------------------------------------
C *** CAS OU LES 2 POINTEURS IPO1 ET IPO2 SONT EGAUX
C-----------------------------------------------------------------------
C
      XX = XCO1 + XCO2
C
      if (ierr.ne.0) return
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='CHPOINT cree par ADCHPO'
      MTYPOI=MCHPO1.MTYPOI
      IFOPOI=MCHPO1.IFOPOI
      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
         SEGSUP MSOUPO,MCHPOI
         CALL ERREUR(114)
         RETURN
 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
 50   CONTINUE
      RETURN
C
C-----------------------------------------------------------------------
C *** CAS  OU LES POINTEURS IPO1 ET IPO2 SONT DIFFERENTS
C-----------------------------------------------------------------------
C
 60   CONTINUE
      IPO(1)=IPO1
      IPO(2)=IPO2
      XXT1 = XCO1
      XXT2 = XCO2

      MCHPO1=IPO1
      MCHPO2=IPO2
      if (ierr.ne.0) return
      SEGACT MCHPO1,MCHPO2
      NSOUP1=MCHPO1.IPCHP(/1)
      NSOUP2=MCHPO2.IPCHP(/1)
      NAT1 = MCHPO1.JATTRI(/1)
      NAT2 = MCHPO2.JATTRI(/1)
      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
C     Cas de l'un ou l'autre des CHPOINT 'VIDE'
      IF    (NSOUP1.EQ.0 .AND. NSOUP2.EQ.0)THEN
C       Cela revient a faire un 'CHPOINT' 'VIDE' en recopiant les attributs
         NSOUPO=0
         CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
         NAT=INAT
         SEGINI,MCHPOI
         IRET=MCHPOI
         JATTRI(1)=IATTR
         MTYPOI=MOT
         MOCHDE='CHPOINT cree par ADCHPO'
         IFOPOI=IFOUR
         RETURN

      ELSEIF(NSOUP1.EQ.0 .AND. NSOUP2.NE.0)THEN
C       Cela revient a une multiplication de MCHPO2 par XCO2
        IOPERA=2
        IARGU =2
        I1    =0
        CALL OPCHP1(MCHPO2,IOPERA,IARGU,I1,XCO2,IRET,IOK)
        RETURN

      ELSEIF(NSOUP1.NE.0 .AND. NSOUP2.EQ.0)THEN
C       Cela revient a une multiplication de MCHPO1 par XCO1
        IOPERA=2
        IARGU =2
        I1    =0
        CALL OPCHP1(MCHPO1,IOPERA,IARGU,I1,XCO1,IRET,IOK)
        RETURN
      ENDIF
C
C Cas general : les 2 champs ne sont pas vides
C
      ifo1 = MCHPO1.IFOPOI
      ifo2 = MCHPO2.IFOPOI
      ifos = ifo1
      IF (ifo1 .NE. ifo2) THEN
        moterr(1:8)='CHPOINT'
        interr(1)=ifo1
        interr(2)=ifo2
        interr(3)=IFOUR
c-dbg      write(ioimp,*) '1132 ADCHPO',ipo1,ipo2
        call erreur(1132)
        ifos = IFOUR
      END IF
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
      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
      CALL COMBNA(MCHPO1,MCHPO2,INAT,IATTR)
      NAT=INAT
      SEGINI MCHPOI
      JATTRI(1)=IATTR
      IRET=MCHPOI
      MTYPOI=MOT
      MOCHDE='CHPOINT cree par ADCHPO'
      IFOPOI=ifos
      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
         SEGSUP MTR6,MCHPOI,MTR3,MTR5
C
C     PB AVEC LES DIMENSIONS DES CHPOINTS
C
         CALL ERREUR(114)
         IRET=0
         RETURN
*
 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)=XXT1*MPOVA1.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)=XXT2*
     $                    MPOVA2.VPOCHA(izon(ipt1.num(1,ib)),IC)
 221              CONTINUE
               else
                  DO 220 IB=1,N
                     VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)
     $                    +XXT2*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)=XXT2*MPOVA2.VPOCHA(IB,IC)
 236              CONTINUE
               else
                  DO 237 IB=1,N
                     VPOCHA(IB,IIC)=XXT1*mpova1.VPOCHA(IB,IIC)+
     >                    XXT2*MPOVA2.VPOCHA(IB,IC)
 237              CONTINUE
               endif
 235        CONTINUE
         endif
C
         SEGINI MSOUPO
         DO 240 IB=1,NC
            NOCOMP(IB)=mpcom(ib)
            NOHARM(IB)=mphar(ib)
 240     CONTINUE
         IPOVAL=MPOVAL
         IPT3=IPT1
         IGEOC=IPT3
         nposr=nposr+1
         IPCHP(nposr)=MSOUPO
         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
         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)=xxt1*vpocha(ja,jb)
 2541       continue
 254     continue
         msoup1.ipoval=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
         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)=xxt2*vpocha(ja,jb)
 2531       continue
 253     continue
         msoup1.ipoval=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
 255  continue
      SEGSUP MTR3,MTR5

      RETURN
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)
      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
            NBELEM=NUM(/2)
            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
            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
 350     CONTINUE
 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)
         if (nbelem.ne.vpocha(/1)) then
          call erreur(114)
          iret=0
         RETURN
         endif
         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)=XXT1*VPOCHA(ID,IB)
 1410       CONTINUE
 1420    CONTINUE
 1430 CONTINUE

      MCHPOI=IPO(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)+XXT2*VPOCHA(ID,IB)
 410        CONTINUE
 420     CONTINUE
 430  CONTINUE
      ITRAV=MTRAV
C
C     RECONSTUCTION DE LA PARTITION
C
      CALL CRECHP(ITRAV,ICHPOI)
C
      SEGSUP MTRAV,MTRA,MTR1,MTR4
      IRET   = ICHPOI
      MCHPOI = ICHPOI
      CALL COMBNA(IPO1,IPO2,INAT,IATTR)
      NAT=INAT
      NSOUPO = IPCHP(/1)
      SEGADJ,MCHPOI
      IRET  =MCHPOI
      JATTRI(1)=IATTR
      RETURN
      END