C MUPOSC    SOURCE    GOUNAND   11/10/07    21:16:00     7151           
      SUBROUTINE MUPOSC(IPOI1,IPOI2,IEPS,IRET)
C=======================================================================
C
C  ENTREE
C     IPOI1=CHPOINT
C     IPOI2=CHPOINT
C     IEPS =1  MULTIPLICATION   -1  DIVISION
C  SORTIES
C     IRET =POINTEUR SUR  CHPOINT RESULTANT
C          =0   SINON (UN MESSAGE D ERREUR EST ALORS IMPRIME )
C
C  REGLE DE MULTIPLICATION : TOUT POINT AYANT DANS UN CHPOINT UNE
C  COMPOSANTE UNIQUE DE NOM "SCAL" VOIT TOUTES LES VALEURS DES
C  COMPOSANTES DE L'AUTRE CHPOINT MULTIPLIER PAR LA VALEUR SCALAIRE.
C
C  LE CHPOINT RESULTAT NE COMPORTE QUE LES POINTS CITES CI-DESSUS.
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMCHPOI
-INC SMCOORD
-INC CCOPTIO
-INC SMELEME
-INC TMTRAV
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
      SEGMENT ICOR(XCOOR(/1)/(IDIM+1))
      SEGMENT ICOM(0)
      SEGMENT SCOM
       CHARACTER*4 COM(0)
      ENDSEGMENT
      SEGMENT NOHA(0)
      IRET=0
      MCHPO1=IPOI1
      MCHPO2=IPOI2
      MCHPOI=MCHPO1
      IPASS=0
      IA=0
      SEGINI ICPR ,SCOM ,NOHA
C
C     ON FABRIQUE MTRAV A LA DIMENSION MAX   POUR CELA FABRICATION DE
C     ICPR QUI DONNE NNNOE PUIS DE ICOM QUI SERA NNIN
 1000 CONTINUE
      SEGACT MCHPOI
      NSOUP =IPCHP(/1)
      DO 1 I = 1,NSOUP
      MSOUPO=IPCHP(I)
      SEGACT MSOUPO
      IF(I.EQ.1.AND.IPASS.EQ.0) THEN
      COM(**)=NOCOMP(1)
      NOHA(**)=NOHARM(1)
      ENDIF
      DO 2 J=1,NOCOMP(/2)
      NNIN=COM(/2)
      DO 3 K=1,NNIN
      IF(NOCOMP(J).EQ.COM(K)) GO TO 2
  3   CONTINUE
      COM(**)=NOCOMP(J)
      NOHA(**)=NOHARM(J)
  2   CONTINUE
      MELEME=IGEOC
      SEGACT MELEME
      DO 4 J=1,NUM(/2)
      IF(ICPR(NUM(1,J)).NE.0) GO TO 4
      IA=IA+1
      ICPR(NUM(1,J))=IA
    4 CONTINUE
      SEGDES MELEME,MSOUPO
    1 CONTINUE
      IF(IIMPI.NE.0) WRITE(IOIMP,100) IA
 100  FORMAT(' NOMBRE DE NOEUDS CONCERNES PAR LES 2 CHPOINTS',I5)
      SEGDES MCHPOI
      IF(IPASS.EQ.0) THEN
      IPASS=1
      MCHPOI=MCHPO2
      GO TO 1000
      ENDIF
      NNNOE=IA
      NNIN=COM(/2)
      SEGINI MTRAV
C
C     ON REMPLIT INCO ET IGEO
C
      DO 5 I=1,NNIN
      NHAR(I)=NOHA(I)
      INCO(I)=COM(I)
   5  CONTINUE
      SEGSUP SCOM,NOHA
      MCHPOI=MCHPO1
      IPASS=0
1001  CONTINUE
      SEGACT MCHPOI
      NSOUP = IPCHP(/1)
      DO 6 I=1,NSOUP
      MSOUPO=IPCHP(I)
      SEGACT MSOUPO
      MELEME=IGEOC
      SEGACT MELEME
      DO 7 J = 1,NUM(/2)
      IA=ICPR(NUM(1,J))
      IGEO(IA)=NUM(1,J)
   7  CONTINUE
      SEGDES MELEME,MSOUPO
   6  CONTINUE
      SEGDES MCHPOI
      IF(IPASS.EQ.0) THEN
      IPASS=1
      MCHPOI=MCHPO2
      GO TO 1001
      ENDIF
C
C  ON EFFECTUE LE TRAVAIL. ON ISOLE D'ABORD LA PARTIE CONCERNANT
C  UNIQUEMENT UNE COMPOSANTE DE NOM "SCAL".
C
      MCHPOI=MCHPO1
      MCHPO3=MCHPO2
      IPASS=0
 1003 CONTINUE
      SEGACT MCHPO3
      DO 10 I=1,MCHPO3.IPCHP(/1)
      MSOUP3=MCHPO3.IPCHP(I)
      SEGACT MSOUP3
      IF(MSOUP3.NOCOMP(/2).NE.1.OR.MSOUP3.NOCOMP(1).NE.'SCAL') THEN
      SEGDES MSOUP3
      GO TO 10
      ENDIF
C ON FABRIQUE UNE CORRESPONDANCE ICOR(I)=J VEUT DIRE QUE LE NOEUD I EST
C EN J EME POSITION DANS CE MELEME
C
      SEGINI ICOR
      IPT3=MSOUP3.IGEOC
      SEGACT IPT3
      DO 11 J=1,IPT3.NUM(/2)
      ICOR(IPT3.NUM(1,J))=J
   11 CONTINUE
      MPOVA3=MSOUP3.IPOVAL
      SEGDES MSOUP3,IPT3
      SEGACT MPOVA3
      SEGACT MCHPOI
      DO 12 J=1,IPCHP(/1)
      MSOUPO=IPCHP(J)
      SEGACT MSOUPO
      IF(IPASS.NE.0) THEN
C  TEST POUR NE PAS REFAIRE LA MULTIPLICATION SCAL PAR SCAL
      IF(NOCOMP(/2).EQ.1.AND.NOCOMP(1).EQ.'SCAL') THEN
      SEGDES MSOUPO
      GO TO 12
      ENDIF
      ENDIF
      SEGINI ICOM
      DO 13 K=1,NOCOMP(/2)
      DO 13 L=1,NNIN
      IF(NOCOMP(K).EQ.INCO(L)) ICOM(**) = L
   13 CONTINUE
      MELEME=IGEOC
      MPOVAL=IPOVAL
      SEGACT MELEME,MPOVAL
      DO 14 K=1,NUM(/2)
      IC=ICOR(NUM(1,K))
      IF(IC.EQ.0) GO TO 14
      IB=ICPR(NUM(1,K))
      DO 15 L=1,NOCOMP(/2)
      IE=ICOM(L)
      IBIN(IE,IB)=1
      IF(IEPS.EQ.1)BB(IE,IB)=BB(IE,IB)+MPOVA3.VPOCHA(IC,1)*VPOCHA(K,L)
      IF(IEPS.EQ.-1)BB(IE,IB)=BB(IE,IB)+VPOCHA(K,L)/MPOVA3.VPOCHA(IC,1)
  15  CONTINUE
  14  CONTINUE
      SEGDES MELEME,MPOVAL,MSOUPO
      SEGSUP ICOM
  12  CONTINUE
      SEGDES MPOVA3,MCHPOI
      SEGSUP ICOR
  10  CONTINUE
      SEGDES MCHPO3
      IF(IPASS.EQ.0) THEN
      MCHPOI=MCHPO2
      MCHPO3=MCHPO1
      IPASS=1
      GO TO 1003
      ENDIF
      KTRAV=MTRAV
*SG Emettre une erreur ne semble pas forcément utile
*SG On laisse la création d'un chpoint vide par CRECHP
C      DO 50 I=1,NNIN
C      DO 50 J=1,NNNOE
C      IF(IBIN(I,J).NE.0) GO TO 60
C  50  CONTINUE
C      CALL ERREUR(179)
C      SEGSUP MTRAV,ICPR
C      RETURN
C   60 CONTINUE
      CALL CRECHP(KTRAV,IRET)
      MTRAV=KTRAV
      SEGSUP MTRAV,ICPR
      RETURN
      END