C FUCHPO    SOURCE    GOUNAND   25/05/05    21:15:04     12259          
      SUBROUTINE FUCHPO(IP1,IP2,IRET)
C======================================================================
C  fonction:
C  sous routine pour fusionner deux champs par points diffus
C
C  arguments:
C  ip1 (E) pointeur sur le premier des deux champ par point
C  ip2 (E) pointeur sur le second des deux champ par point
C  iret (S) pointeur sur le champ par point resultat
C
C  variables:
C
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
C  auteur: A de Gayffier 13/06/94
C======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMCHPOI

-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC TMTRAV
      SEGMENT/MTRA/(NOPOIN(nbpts))
      SEGMENT MTR1
       CHARACTER*(LOCOMP) IPCOM(0)
      ENDSEGMENT
      SEGMENT/MTR2/(IICOM(0))
      SEGMENT/MTR3/(INDEX(0))
      SEGMENT/MTR4/(IPHAR(0))
C     ordre de grandeur des composantes
      SEGMENT/MTR5/(DMOY(NNIN))
C
      DIMENSION IPO(2)
      CHARACTER*8 MOT
      DATA UN,ZERO/1.D0,0.D0/
      character*4 mcle(1)
      data mcle/'NOER'/
C
      IRET = 0

      noer=0
      call lirmot(mcle,1,noer,0)
      if (ierr.ne.0) return

      MCHPO1 = IP1
      MCHPO2 = IP2
      SEGACT,MCHPO1,MCHPO2

      NSOUP1 = MCHPO1.IPCHP(/1)
      NSOUP2 = MCHPO2.IPCHP(/1)

      NAT1 = MCHPO1.JATTRI(1)
      NAT2 = MCHPO2.JATTRI(1)

*     Si CHPOINT vide, on renvoie l'autre si il est non vide:
      IF (NSOUP1.EQ.0) THEN
        IRET = MCHPO2
        RETURN
      ENDIF
      IF (NSOUP2.EQ.0) then
        IRET = MCHPO1
        RETURN
      ENDIF
C
C    verification de la compatibilité des natures
C
      IF ( (NAT1*NAT2) .EQ. 0) THEN
C    une des deux natures est indeterminée
         CALL ERREUR(650)
         RETURN
      ELSE
        IF ((NAT1 .EQ. 2) .AND. (NAT2 .EQ. 2)) THEN
C      les deux champ sont discrets: on somme les composantes communes
           CALL ADCHPO(IP1,IP2,IRET,1D0,1D0)
           RETURN
        ENDIF
        IF ((NAT1 .NE. 1) .OR. (NAT2 .NE. 1)) THEN
C      les natures ne sont pas compatibles
           CALL ERREUR(649)
           RETURN
        ENDIF
      ENDIF
C
C Petite verification sur les modes de calcul
      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 FUCHPO',ip1,ip2
        call erreur(1132)
        ifos = IFOUR
      END IF

C   les deux champs sont de nature diffuse
C   on moyenne les composantes communes
C
      IF ( IP1 .NE. IP2) GOTO 60
C
C *** cas ou les 2 pointeurs ip1 et ip2 sont egaux
C
c*      SEGACT MCHPO1
      NSOUPO=NSOUP1
      NAT   =NAT1
      SEGINI MCHPOI
      DO 10 I=1,NAT
        JATTRI(I)=MCHPO1.JATTRI(I)
 10   CONTINUE
      MOCHDE=MCHPO1.MOCHDE
      MTYPOI=MCHPO1.MTYPOI
      IFOPOI=ifos
      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)
C
C     erreur pb dimension tableau voir routine adchpo
        IF (NC1.NE.NC) THEN
          IRET=0
          SEGSUP MSOUPO,MCHPOI
          CALL ERREUR(114)
          RETURN
        ENDIF
C
        SEGINI MPOVAL
        IPOVAL=MPOVAL
        DO 40 IC=1,NC
          DO 41 IB=1,N
            VPOCHA(IB,IC)=MPOVA1.VPOCHA(IB,IC)
   41     CONTINUE
   40   CONTINUE
   50 CONTINUE
C
C      on sort de la sous routine
      IRET=MCHPOI
      GOTO 666
C
C *** cas  ou les pointeurs ip1 et ip2 sont differents
C
  60  CONTINUE
      IPO(1)=IP1
      IPO(2)=IP2
      MOT=MCHPO1.MTYPOI
      IF(MOT.NE.MCHPO2.MTYPOI) THEN
        MOT='ET OU +'
      ENDIF
C
C     on verifie que les nbres de sous paquets sont egaux
C
      IF(NSOUP1.EQ.NSOUP2) GO TO 75
C      traitement par la methode générale
      GO TO 300
C
C     on regarde si les supports geometriques sont identiques a une
C     permutation pres
C
   75 SEGINI MTR3
      DO 100 IA=1,NSOUP1
        MSOUP1=MCHPO1.IPCHP(IA)
        SEGACT MSOUP1
        DO 80 IB=1,NSOUP2
          MSOUP2=MCHPO2.IPCHP(IB)
          SEGACT MSOUP2
          IF(MSOUP1.IGEOC.EQ.MSOUP2.IGEOC) GO TO 90
   80   CONTINUE
C
C     il n y a pas egalite des supports geometriques a une permutation
C     pres
C
        SEGSUP MTR3
C      traitement par la methode générale
        GO TO 300
C
   90   CONTINUE
C    la permutation est rangée dans  index
        INDEX(**)=IB
  100 CONTINUE
C
C *** cas ou il y a egalite des supports geometriques a une permutation
C     pres
C
      NSOUPO=NSOUP1
      NAT=MAX(NAT1,NAT2,1)
      SEGINI MCHPOI
      JATTRI(1) = 1
      IRET=MCHPOI
      MTYPOI=MOT
      MOCHDE=MCHPO1.MOCHDE
      IFOPOI=ifos
C
      DO 250 IA=1,NSOUP1
        MSOUP1=MCHPO1.IPCHP(IA)
        MSOUP2=MCHPO2.IPCHP(INDEX(IA))
        SEGACT MSOUP1,MSOUP2
C
C     comparaison des noms des composantes
C
        SEGINI MTR1,MTR4
        NC1=MSOUP1.NOCOMP(/2)
        NC2=MSOUP2.NOCOMP(/2)
        DO 130 IB=1,NC1
         IPCOM(**)=MSOUP1.NOCOMP(IB)
         IPHAR(**)=MSOUP1.NOHARM(IB)
  130   CONTINUE
        SEGINI MTR2
        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
C         la composante du IB n'est pas commune
         IPCOM(**)=MSOUP2.NOCOMP(IB)
         IPHAR(**)=MSOUP2.NOHARM(IB)
         IICOM(**)=IPCOM(/2)
         GO TO 160
  150    CONTINUE
C          la composante est commune
         IICOM(**)=IC
  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 MTR1,MTR2,MTR3,MCHPOI,MTR4
C
C     pb avec les dimensions des chpoints
C
        CALL ERREUR(114)
        RETURN
        IRET=0
C      on sort de la sous routine
        GOTO 666
C
  180   CONTINUE
        N=N1
        NC=IPCOM(/2)
        SEGINI MPOVAL
        NNIN = NC
        SEGINI MTR5
C
C     mise a 0 de vpocha
C
*        DO 190 IB=1,N
*        DO 190 IC=1,NC
*         VPOCHA(IB,IC)=ZERO
*  190   CONTINUE
C
C     addition des chpoints
C
C     on place les valeurs de MCHPO1
        DO 210 IC=1,NC1
          DO 200 IB=1,N
            VPOCHA(IB,IC) = MPOVA1.VPOCHA(IB,IC)+VPOCHA(IB,IC)
            DMOY(IC) = DMOY(IC) + ABS(VPOCHA(IB,IC)/N)
  200     CONTINUE
          IF (IIMPI.EQ.123)
     &      write (IOIMP,*) ' ic dmoy(ic) ',ic,dmoy(ic)
  210   CONTINUE
C
        DO 230 IC=1,NC2
          IIC=IICOM(IC)
          DO 220 IB=1,N
            IF (IIC .LE. NC1 ) THEN
C      il s'agit d'ne composante commune
              XX1 = MPOVA2.VPOCHA(IB,IC)
              XX2 = VPOCHA(IB,IIC)
              DXX = ABS ( XX2 - XX1)
*             SXX = MIN(ABS ( XX1 + XX2 ) / 2.D0,1.D-50)
              SXX = DMOY(IIC)
              IF (DXX .LE. (1.D-4*SXX) .or.noer.eq.1) THEN
                VPOCHA(IB,IIC)= ( XX1 + XX2 ) / 2.D0
              ELSE
C        les valeurs des champ diffus au meme point sont différentes
               IF (IIMPI.EQ.123)
     &           write (IOIMP,*) xx1,xx2,SXX,DXX
                 CALL ERREUR(651)
                 RETURN
               SEGSUP MTR1,MTR2,MTR3,MCHPOI,MTR4
C         on sort
               GOTO 666
              ENDIF
            ELSE
C    composantes non communes
              VPOCHA(IB,IIC) = MPOVA2.VPOCHA(IB,IC)+VPOCHA(IB,IIC)
            ENDIF
  220     CONTINUE
  230   CONTINUE
C
        SEGINI MSOUPO
        DO 240 IB=1,NC
         NOCOMP(IB)=IPCOM(IB)
         NOHARM(IB)=IPHAR(IB)
  240   CONTINUE
        SEGSUP MTR1,MTR2,MTR4
        IPOVAL=MPOVAL
        IPT2=MSOUP1.IGEOC
****    SEGINI,IPT1=IPT2
        IPT1 = IPT2
        IGEOC=IPT1
        IPCHP(IA)=MSOUPO
        SEGSUP MTR5
  250 CONTINUE
C
      SEGSUP MTR3
C     on sort
      GOTO 666
C
C *** cas ou les supports geometriques ne sont pas identiques
C     a une permutation pres
C
  300 CONTINUE
C
C ****  a-t-on affaires a des champoints vides?
C
      MCHPOI=IP1
c*      SEGACT MCHPOI
      NS1=IPCHP(/1)
      MCHPO2=IP2
c*      SEGACT MCHPO2
      NS2=MCHPO2.IPCHP(/1)
      IF(NS1*NS2.NE.0) GO TO 3001
      IF(NS1+NS2.NE.0) THEN
C un seul des chpoints est vide
          IF(NS1.EQ.0)  IP1=IP2
          CALL ECRCHA('GEOM')
          CALL ECROBJ('CHPOINT ',IP1)
          CALL COPIER
          CALL LIROBJ('CHPOINT',IRET,1,IRETOU)
      ELSE
C  les deux chpoints sont vides
         NSOUPO=0
         NAT=1
         SEGINI MCHPOI
         IFOPOI = ifos
         IRET = MCHPOI
      ENDIF
      RETURN
C
 3001 CONTINUE
      SEGINI MTRA,MTR1,MTR4
C
C     mise a zero de nopoin
C
*      DO 305 IA=1,nbpts
*      NOPOIN(IA)=0
*  305 CONTINUE
C
      MCHPOI=IP1
c*      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)
c*        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)
          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     initialisation a zero des tableaux
C
      SEGINI MTR5
C
*      DO 370 IB=1,NNNOE
*      DO 370 IA=1,NNIN
*      BB(IA,IB)=ZERO
*      IBIN(IA,IB)=0
*      IMOY(IA,IB) = 0
*  370 CONTINUE
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
      DO 450 ICH=1,2
        MCHPOI=IPO(ICH)
c*        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 411 ID=1,NBELEM
             DMOY(IB)=DMOY(IB)+ABS(VPOCHA(ID,IB)/NBELEM)
  411      CONTINUE
           DO 410 ID=1,NBELEM
              KI=NOPOIN(NUM(1,ID))
              IGEO(KI)=NUM(1,ID)
              IF (  IBIN(IC,KI) .EQ. 1) THEN
C          la valeur au point est defini dans les deux champs
               XX1 = BB(IC,KI)
               XX2 = VPOCHA(ID,IB)
               DXX = ABS ( XX2 - XX1 )
               SXX = DMOY(IB)
               IF ( DXX .LE. (1.D-4*SXX).or.noer.eq.1) THEN
                  BB(IC,KI) = ( XX1 + XX2 ) / 2.D0
               ELSE
C          les valeurs des champs au meme point sont différentes
                IF (IIMPI.EQ.123)
     &            write (IOIMP,*) xx1,xx2,sxx,DXX
                CALL ERREUR (651)
                RETURN
                SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5
                GOTO 666
               ENDIF
             ELSE
               BB(IC,KI)=BB(IC,KI)+VPOCHA(ID,IB)
*              DMOY(IC) = DMOY(IC) +ABS(BB(IC,KI)/NNNOE)
             ENDIF
             IBIN(IC,KI)=1
  410      CONTINUE
  420    CONTINUE
  430  CONTINUE
  450 CONTINUE
      ITRAV=MTRAV
C
C     reconstuction de la partition
C
      CALL CRECHP(ITRAV,ICHPOI)
C
      SEGSUP MTRAV,MTRA,MTR1,MTR4,MTR5
      IRET=ICHPOI
      MCHPOI=ICHPOI
c*      MCHPO1 = IP1
c*      MCHPO2 = IP2
c*      NAT1 = MCHPO1.JATTRI(/1)
c*      NAT2 = MCHPO2.JATTRI(/1)
      NAT=MAX(NAT1,NAT2,1)
      NSOUPO = IPCHP(/1)
      SEGADJ MCHPOI
      IRET=MCHPOI
      MTYPOI=MOT
      IFOPOI = ifos
      JATTRI(1) = 1
C
 666  CONTINUE
c*      RETURN
      END