C MUCHP1    SOURCE    PV        22/01/18    21:15:07     11267          
      SUBROUTINE MUCHP1(IPOI1,IPOI2,LMOT1,LMOT2,LMOT3,IPLREE,IEPS,IRET)
C=======================================================================
C
C  entree
C     ipoi1=chpoint
C     ipoi2=chpoint
C     lmot1=liste de mots1
C     lmot2=liste de mots2
C     lmot3=liste de mots3
C  sorties
C     iret =   pointeur sur  chpoint resultant
C          = 0 sinon (un message d erreur est alors imprime )
C
C 2018/01/19 gounand ajout du listreel de ponderation
C
C======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMCHPOI

-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMLMOTS
-INC SMCOORD
-INC SMLREEL

C   le tableau icpr contient la mise en ordre des 3 chpoint
      SEGMENT ICPR
C                     nbre harm. comp   points         chpoints
             REAL*8 VALCPR(nbpts,NCOMP1,NHAR)
      ENDSEGMENT
C  nocmp1 et le nombre de composante dans chaque listmot
C  nhar est le nombre d'harmonique de Fourrier présent
C ce segment contient les numéro des différents harmoniques trouvées
C et l'inversion du tableau
      SEGMENT NUMHAR(NHAR)
      SEGMENT IHARNU(NVHAR)
C ce tableau sert de correspondance entre les composantes des liste mot
C et celles des champ point pour chaque sous zone
      SEGMENT ICOR1(NCOMP1)
      SEGMENT ICOR2(NCOMP1)
C
C ces segment servent au moment de l'assemblage du nouveau chpoint
C celui stocke le nombre de sous zone du nouveau chpoint
      SEGMENT JCHACO(4,NSOUP1)
C    indice 1 et 2 voir muchpo2 , 3 nombre de pts , 4 nbre de composante
C  kchaco donne l'adresse dans jchaco de la sous zone
      SEGMENT KCHACO(NSOUPO)
      SEGMENT MCORES
C   correspondence comp listmot comp sous zone
       INTEGER ICOR3(NCOMP1,NSOUPO)
C      indice 1 contient sum 2**i si i présent
C      indice 2 contient le nombre de i present
       INTEGER KCOMP(2,NSOUPO)
       INTEGER KHARM(NSOUPO)
      ENDSEGMENT


      LOGICAL IVCHPO


C
C  ce tableau contient les pointeurs des deux champ point et des listemots
      DIMENSION ICHP(2),ILMO(2),NR(2)
      CHARACTER*4 MOTCLE(3),MONATU(1)
      DATA MOTCLE/'INDE','DIFF','DISC'/
      DATA MONATU/'NATU'/
C
C     executable
      IRET=0
C     verification de la dimension des listmots
      MLMOT1=LMOT1
      MLMOT2=LMOT2
      MLMOT3=LMOT3
      MLREE3=0
      NCOMP1 = MLMOT1.MOTS(/2)
      NCOMP2 = MLMOT2.MOTS(/2)
      NCOMP3 = MLMOT3.MOTS(/2)
      IF (NCOMP1.NE.NCOMP2.OR.NCOMP3.NE.NCOMP1) THEN
C        erreur dans la dimension des lismots
         CALL ERREUR(854)
         RETURN
      ENDIF
      if (IPLREE.gt.0) then
         MLREE3 = IPLREE
         if (mlree3.prog(/1).ne.ncomp1) then
            MOTERR      ='LIST****'
            MOTERR(9:16)='termes  '
            call erreur(403)
            return
         endif
      endif

C determination du nombre d'harmonique de Fourrier
C     expédition rapide du cas sans harmonique
      NR(1)  = 0
      NR(2)  = 0
      ILMO(1)= LMOT1
      ILMO(2)= LMOT2
      ICHP(1)= IPOI1
      ICHP(2)= IPOI2
C
      MCHPO1 = IPOI1
      MCHPO2 = IPOI2
      NHAR = 1
      NSUM = 0
C  boucle sur les 2 champoints
      DO 300 K=1,2
         MCHPO1 = ICHP(K)
         DO 200 I=1,MCHPO1.IPCHP(/1)
            MSOUPO = MCHPO1.IPCHP(I)
            MELEME = IGEOC
            NR(K)  = NR(K) + NUM(/2)
            DO 100 J=1,NOHARM(/1)
               NSUM = NSUM + NOHARM(J)
 100        CONTINUE
 200     CONTINUE
 300  CONTINUE
C
C  combien y a t'il d'harmoniques ?
C
      IF (NSUM .NE. 0) THEN
C  il y en a plusieurs
C           write(6,*) 'Appel de noharm'
         CALL NHARMO(IPOI1,IPOI2,NHAR,NUMHAR,NMIN,IHARNU)
         NVHAR=IHARNU(/1)
      ELSE
C  cas simple toutes les harmoniques sont nulles
         NHAR = 1
         NVHAR= 1
         SEGINI NUMHAR,IHARNU
         NUMHAR(1)=0
         IHARNU(1)=1
         NMIN=0
      ENDIF
C
C      write(6,*) 'points',nbpts,'Comp',ncomp1,'nhar',nhar
C
C initialisation du tableau
      SEGINI ICPR
C  ordre des opérations
C  cela va dépendre des remplissage respectifs NR1 et NR2
C
      NRR1  = MAX(NR(1),NR(2))
      NRR2  = MIN(NR(1),NR(2))
      DNRR1 = REAL(NRR1)
      DNRR2 = REAL(NRR2)
      TAUX = DNRR2 / (DNRR1+0.1)
C      write(6,*) 'Taux de remplissage',taux
C  on classe les champ point dans l'ordre de taille
      IF ((NRR1.NE.NR(1).AND.TAUX.LT.0.5).OR.
     &     (NRR1.EQ.NR(1).AND.TAUX.GE.0.5)) THEN
C          write(6,*) 'Inversion de l ordre des champoints'
C          write(6,*) 'Taux de remplissage' ,taux
         IDUM1 = ICHP(1)
         IDUM2 = ILMO(1)
         ICHP(1)=ICHP(2)
         ILMO(1)=ILMO(2)
         ICHP(2)=IDUM1
         ILMO(2)=IDUM2
         IVCHPO=.TRUE.
      ELSE
         IVCHPO=.FALSE.
      ENDIF
C remplissage du tableau en bouclant sur les champ par points
C on boucle sur les deux champ point
C pour chaque sous zone on établi la correspondance de composantes du
C liste mots vers les nom de composantes de la sous zone
      SEGINI ICOR1,ICOR2
C pseudo boucle sur les champ points
      MCHPOI = ICHP(1)

      MLMOTS = ILMO(1)
      DO  900 J=1,IPCHP(/1)
         MSOUPO = IPCHP(J)
C           on établi la correspondance de composantes du
C           liste mots vers les nom de composantes de la sous zone
         NC = NOHARM(/1)
         NC1 = 0
         DO 600 K=1,NCOMP1
            ICOR1(K)=0
            DO 500 L=1,NC
C     write(6,*) MOTS(K),NOCOMP(L)
               IF(MOTS(K).EQ.NOCOMP(L)) THEN
C                      write(6,*) 'chp1 sz',j,'ccomp',l,'lcomp',k
                  ICOR1(K)=L
C                     nbre de composante présente sur la sous zone
                  NC1 = NC1 + 1
                  ICOR2(NC1)=K
                  GOTO 600
               ENDIF
 500        CONTINUE
 600     CONTINUE

C on remplit chaque point du meleme
         MELEME = IGEOC
         MPOVAL = IPOVAL
C     boucle sur les composantes
         DO 800 K=1,NC1
            KK = ICOR2(K)
            LC = ICOR1(KK)
C                     numero local de l'harmonique
            IHA = IHARNU(NOHARM(LC)-NMIN+1)
C         boucle sur les points
            DO 700 L=1,NUM(/2)
               NBP = NUM(1,L)
C             remplissage ici
               VALCPR(NBP,KK,IHA)
     &              =VPOCHA(L,LC)
 700        CONTINUE
 800     CONTINUE
 900  CONTINUE
C
C on passe au second champ point
      MCHPOI = ICHP(2)
      MLMOTS = ILMO(2)
      DO  1400 J=1,IPCHP(/1)
         MSOUPO = IPCHP(J)
C           on établi la correspondance de composantes du
C           liste mots vers les nom de composantes de la sous zone
         NC = NOHARM(/1)
         NC1 = 0
C
         ncomp1 = mots(/2)
C
         DO 1100 K=1,NCOMP1
            ICOR1(K)=0
            DO 1000 L=1,NC
C                   write(6,*) 'mots=',MOTS(K),'Comp=',NOCOMP(L)
               IF(MOTS(K).EQ.NOCOMP(L)) THEN
C                      write(6,*) 'chp2 sz',j,'ccomp',l,'lcomp',k
                  ICOR1(K)=L
C                     nbre de composante présente sur la sous zone
                  NC1 = NC1 + 1
                  ICOR2(NC1)=K
                  GOTO 1100
               ENDIF
 1000       CONTINUE
 1100    CONTINUE

C on remplit chaque point du meleme
         MELEME = IGEOC
         MPOVAL = IPOVAL
C   boucle sur les composantes
         DO 1300 K=1,NC1
            KK = ICOR2(K)
            LC = ICOR1(KK)
C     numero local de l'harmonique
            IHA = IHARNU(NOHARM(LC)-NMIN+1)
C         boucle sur les points
            DO 1200 L=1,NUM(/2)
               NBP = NUM(1,L)
C             multiplication ou division ici
               IF (IEPS.EQ.1) THEN
                  VALCPR(NBP,KK,IHA)
     &                 =VALCPR(NBP,KK,IHA)*VPOCHA(L,LC)
               ELSE
                  IF (IVCHPO) THEN
                     VALCPR(NBP,KK,IHA)
     &                    =VPOCHA(L,LC)/VALCPR(NBP,KK,IHA)
                  ELSE
                     VALCPR(NBP,KK,IHA)
     &                    =VALCPR(NBP,KK,IHA)/VPOCHA(L,LC)
                  ENDIF
               ENDIF
 1200       CONTINUE
 1300    CONTINUE
 1400 CONTINUE
      SEGSUP ICOR1,ICOR2
C
C
C      impression de icpr
C       WRITE(6,*) 'PTS',nbpts,'COMP',ncomp1,'Nhar',nhar
C       do 6003 i=1,nbpts
C          write(6,5001) i
C          do 6002 j=1,ncomp1
C          do 6001 k=1,nhar
C              write(6,5002) j,k,valcpr(i,j,k)
C 6001    continue
C 6002    continue
C 6003    continue

C 5001  format('Point numero',I4)
C 5002  format('Composante',I2,'Harmonique',I2,'Valeur',G12.5)


C
C  il faut maintenant creer le champ point résultat
C  on commence par
      MCHPOI=ICHP(2)
      MLMOTS=ILMO(2)
C
C  muchp2 determine le nombre de sous zone de notre chpoint
C
C      write(6,*) 'Appel à muchp2'
      CALL MUCHP2(MCHPOI,MLMOTS,MCORES,JCHACO,KCHACO,IHARNU,NMIN)
C en sortie de mcuchp2 les segment sont actifs
C
C  création du nouveau champ par point
C
C      nini = jchaco(/2)
C      write(6,*)'tableau jchaco 1: kcomp  2:khar  3:nbre pts 4:nb comp'
C      do 6005 i=1,nini
C        write(6,5003) jchaco(1,i),jchaco(2,i),jchaco(3,i),jchaco(4,i)
C 6005 continue
C 5003 format('    ',4(I5,2X))
C
C      nini = kchaco(/1)
C      write(6,*)'tableau kchaco correspondace 1 -> 3'
C      write(6,5004) (kchaco(i),i=1,nini)
C 5004 format('    ',6(I2,2X))
C
C      write(6,*) 'Tableau mcores - icor3'
C      nono = icor3(/1)
C      write(6,*) 'icor3(/1)=' ,nono
C      do 6004 i=1,nini
C        write(6,*) 'sous zone' , i
C        write(6,5005) (icor3(j,i),j=1,nono)
C 6004 continue
C 5005 format(10(I2,2X))
C
C  attention inversion volontaire
      MCHPO1 = ICHP(2)
      MCHPO2 = ICHP(1)
      NSOUPO = JCHACO(/2)
      NAT = 1
      SEGINI MCHPO3
      NSOUP1 = NSOUPO
      NSOUPO= MCHPO1.IPCHP(/1)
      MCHPO3.MOCHDE = 'PRODUIT DE DEUX CHAMP POINT PAR *'
      MCHPO3.MTYPOI = '   '

C nature du champoint
      CALL LIRMOT(MONATU,1,IVAL,0)
      IF ( IVAL .EQ.1 ) THEN
         CALL LIRMOT(MOTCLE,3,IVAL,1)
         IF ( IERR .NE. 0) RETURN
         MCHPO3.JATTRI(1) = IVAL-1
      ELSE
         NATRI = MCHPO1.JATTRI(1) * MCHPO2.JATTRI(1)
         IF ( NATRI .EQ. 0) THEN
            MCHPO3.JATTRI(1) = 0
         ELSE IF ( NATRI .EQ. 1) THEN
            MCHPO3.JATTRI(1) = 1
         ELSE IF ( NATRI .EQ. 2) THEN
C     la nature discrete domine
            MCHPO3.JATTRI(1) = 2
         ELSE
            MCHPO3.JATTRI(1) = 2
         ENDIF
      ENDIF
      MCHPO3.IFOPOI = IFOUR
C
C  boucle sur les sous zones DE MCHPO3
C
      NBS=0
      DO 2200 I=1,NSOUP1
         NC     = JCHACO(4,I)
         IF(NC .EQ. 0)GOTO 2200
         NBELEM = JCHACO(3,I)
         IF(NBELEM .EQ. 0)GOTO 2200
C  cas ou la sous zone n'existe pas encore
         SEGINI MSOUP3
         NBS = NBS + 1
         
         MCHPO3.IPCHP(NBS)=MSOUP3
         NBNN = 1
C on cherche la première sous zone correspondante
         DO 1500 J=I,NSOUPO
            IF (KCHACO(J).EQ.I) GOTO 1600
 1500    CONTINUE
C  ici j est le numéro de la premièer sous zone de mchpo1 correspondante
 1600    CONTINUE
         MSOUP1 = MCHPO1.IPCHP(J)
         IPT1 = MSOUP1.IGEOC
         IF (NBELEM.EQ.IPT1.NUM(/2)) THEN
            IPT3 = IPT1
         ELSE
            NBSOUS = 0
            NBREF = 0
            NBNN = 1
            SEGINI IPT3
            DO 1650 K=1,IPT1.NUM(/2)
               IPT3.NUM(1,K)=IPT1.NUM(1,K)
 1650       CONTINUE
         ENDIF
         MSOUP3.IGEOC = IPT3
         NR3 = IPT1.NUM(/2)
         N = NBELEM
         SEGINI MPOVA3
         MSOUP3.IPOVAL= MPOVA3
C
C  nom des composantes et harmoniques
C
         IC = 0
         DO 1800 K=1,NCOMP1
            IF (ICOR3(K,J).NE.0) THEN
               IC = IC + 1
               MSOUP3.NOCOMP(IC) = MLMOT3.MOTS(K)
               MSOUP3.NOHARM(IC) = MSOUP1.NOHARM(ICOR3(K,J))
C
C  1 ier remplissage
C
               DO 1700 L=1,IPT1.NUM(/2)
                  NBP = IPT1.NUM(1,L)
                  XVAL=VALCPR(NBP,K,IHARNU(MSOUP3.NOHARM(IC)-NMIN+1))
                  IF (mlree3.ne.0) xval=xval*mlree3.prog(k)
                  MPOVA3.VPOCHA(L,IC)=XVAL
 1700          CONTINUE
            ENDIF
 1800    CONTINUE
C
C remplissage suivant
C
C         write(6,*) 'nr3=',nr3,'nbelem=',nbelem
         IF (NR3 .NE. NBELEM) THEN
C           write(6,*) 'Compactage de la sous zone'
C       on cherche la prochaine sous zone correspondante
            DO 2100 K=J+1,NSOUPO
               IF (KCHACO(K).EQ.I) THEN
C   k est le numéro de la sous zone de mchpo1
                  MSOUP1 = MCHPO1.IPCHP(K)
                  IPT1 = MSOUP1.IGEOC
                  IC = 0
                  DO 2000 L=1,NCOMP1
                     IF (ICOR3(L,K).NE.0) THEN
                        IC = IC + 1
                        DO 1900 M=1,IPT1.NUM(/2)
                           NBP = IPT1.NUM(1,M)
                           IPT3.NUM(1,NR3+M) = NBP
                           XVAL=VALCPR(NBP,L,IHARNU(MSOUP3.NOHARM(IC)
     $                          -NMIN+1))
                           IF (mlree3.ne.0) xval=xval*mlree3.prog(L)
                           MPOVA3.VPOCHA(NR3+M,IC)=XVAL
 1900                   CONTINUE
                     ENDIF
 2000             CONTINUE
                  NR3 = NR3 + IPT1.NUM(/2)
               ENDIF
 2100       CONTINUE
            IF ( NR3.NE.NBELEM.OR.NC.NE.IC)THEN
C            write(6,*)'nr3',nr3,'nbelem',nbelem,'nc',nc,'ic',ic
               WRITE(IOIMP,*) 'erreur dans muchpo1.eso'
               CALL ERREUR(5)
               RETURN
            ENDIF
C  on ferme la sous zone du nouveau chpoint

         ENDIF
 2200 CONTINUE

CC    Retassement du MCHPO3
      IF(NBS .NE. NSOUP1)THEN
        NSOUPO=NBS
        SEGADJ,MCHPO3
      ENDIF

C  on détruit les temporaires
      SEGSUP ICPR,IHARNU,NUMHAR,JCHACO,KCHACO,MCORES
      IRET = MCHPO3
      RETURN
      END