C MUPOSC    SOURCE    CB215821  20/11/25    13:34:45     10792          
      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 PPARAM
-INC CCOPTIO
-INC SMELEME
-INC TMTRAV
      SEGMENT ICPR(nbpts)
      SEGMENT ICOR(nbpts)
      SEGMENT ICOM(0)
      SEGMENT SCOM
       CHARACTER*(LOCOMP) COM(0)
      ENDSEGMENT
      SEGMENT NOHA(0)


      CHARACTER*4 MOTCLE(3),MONATU(1)
      DATA MOTCLE/'INDE','DIFF','DISC'/
      DATA MONATU/'NATU'/



      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
    1 CONTINUE

      IF(IIMPI.NE.0) WRITE(IOIMP,100) IA

 100  FORMAT(' NOMBRE DE NOEUDS CONCERNES PAR LES 2 CHPOINTS',I5)
      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
   6  CONTINUE

      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
      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
      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
      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
      SEGSUP ICOM
  12  CONTINUE
      SEGSUP ICOR
  10  CONTINUE
      IF(IPASS.EQ.0) THEN
      MCHPOI=MCHPO2
      MCHPO3=MCHPO1
      IPASS=1
      GO TO 1003
      ENDIF
      KTRAV=MTRAV
CSG Emettre une erreur ne semble pas forcément utile
CSG 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)


C     nature du champoint
      MCHPO3 = IRET
      SEGACT,MCHPO1
      SEGACT,MCHPO2
      SEGACT,MCHPO3*MOD
      CALL LIRMOT(MONATU,1,IVAL,0)

      IF ( IVAL .EQ.1 ) THEN
C       Cas de la lecture imposée de la 'NATURE' du champ résultat
        CALL LIRMOT(MOTCLE,3,IVAL,1)
        IF ( IERR .NE. 0) RETURN
        MCHPO3.JATTRI(1) = IVAL-1

      ELSE
C       Cas du calcul de la 'NATURE' du champ résultat
        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
      IRET=MCHPO3

      MTRAV=KTRAV
      SEGSUP MTRAV,ICPR
      END