C OPERMU    SOURCE    FANDEUR   12/04/11    21:15:24     7350           
      SUBROUTINE OPERMU
*_______________________________________________________________________
*
*     multiplie un champ par point par un objet rigidite.
*     multiplie un listreel par un flottant (ou un entier)
*     multiplie un listreel par un listreel terme a terme.
*     multiplie un objet rigidite par un flottant (ou 1 entier)
*     multiplie un champs par elemt par un flottant (ou 1 entier)
*     multiplie un champ par element par un autre champ par element
*     multiplie un champ par element par une evolution
*     multiplie un champ par point   par un autre champ par point
*     multiplie un champ par point par un flottant (ou 1 entier)
*     multiplie un champ par point par une evolution
*     multiplie 2 nombres (flottant ou entier)
*     multiplie un point par un nombre
*     multiplie un objet evolutio (ordonnees) par un flottant
*                                               (ou un entier)
*     multiplie un objet evolutio par un objet evolutio
*     multiplie une table soustype vecteur par un reel
*     multiplie une table soustype LIAISONS_STATIQUES ou
*            BASE_DE_MODES par une rigidite
*
*     passage aux nouveaux mchaml par jm campenon le 29 10 90
*
*_______________________________________________________________________
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
-INC CCOPTIO
-INC SMCOORD
-INC SMLENTI
-INC SMLREEL
-INC SMTABLE
*_______________________________________________________________________
*
*  produit de deux champoints
*_______________________________________________________________________
*
      CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 1
      CALL LIROBJ('CHPOINT',ICHP2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1
      ENDIF
      CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
      IF ( IRETOU .EQ. 1) THEN
        CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
        IF (IERR .NE. 0) RETURN
        CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
        IF (IERR .NE. 0) RETURN
        CALL MUCHP1(ICHP1,ICHP2,LMOT1,LMOT2,LMOT3,1,IRET)
        IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
      ELSE
        CALL MUPOSC(ICHP1,ICHP2,1,IRET)
        IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
      ENDIF
      RETURN
*
   1  CONTINUE
*_______________________________________________________________________
*
*  multiplication de deux entiers
*_______________________________________________________________________
*
      CALL LIRENT(IRE1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 2
      CALL LIRENT(IRE2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 2
      ENDIF
      CALL ECRENT(IRE1*IRE2)
      RETURN
*
   2  CONTINUE
*_______________________________________________________________________
*
*  multiplication de deux flottants
*_______________________________________________________________________
*
      CALL LIRREE(FLO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 3
      CALL LIRREE(FLO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 3
      ENDIF
      CALL ECRREE(FLO1*FLO2)
      RETURN
*
   3  CONTINUE
*_______________________________________________________________________
*
*  produit d'un reel par un point
*_______________________________________________________________________
*
      CALL LIRREE(FLO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 4
      CALL LIROBJ('POINT',IPT,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 4
      ENDIF
      SEGACT MCOORD*MOD
      XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+1)*FLO1
      XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+2)*FLO1
      XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+3)*FLO1
      IF (IDIM.EQ.3) XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+4)*FLO1
      IRET=XCOOR(/1)/(IDIM+1)
      CALL ECROBJ('POINT',IRET)
      RETURN
*
   4  CONTINUE
*_______________________________________________________________________
*
*  produit d'un chpoint par un reel
*_______________________________________________________________________
*
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 5
      CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 5
      ENDIF
      CALL MUCHPO(ICHP,FLO,IRET,1)
      IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
   5  CONTINUE
*_______________________________________________________________________
*
*  produit d'un mchaml par un reel
*_______________________________________________________________________
*
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 6
      CALL LIROBJ('MCHAML',IPCHP,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 6
      ENDIF
*
      CALL MUCHEL(IPCHP,FLO,IPCHMU,1)
*
      IF (IPCHMU.NE.0) CALL ECROBJ('MCHAML',IPCHMU)
*
      RETURN
*
   6  CONTINUE
*_______________________________________________________________________
*
*  produit d'une rigidite par un reel
*_______________________________________________________________________
*
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 7
      CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 7
      ENDIF
      CALL MUFLRI(IRIG,FLO,IRET,1)
      IF (IRET.NE.0) CALL ECROBJ('RIGIDITE',IRET)
      RETURN
*
   7  CONTINUE
*_______________________________________________________________________
*
*  produit d'un matrik par un reel
*_______________________________________________________________________
*
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 71
      CALL LIROBJ('MATRIK  ',IRIG,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 71
      ENDIF
      CALL PRDMF(FLO,IRIG,IRET)                                             
      IF (IRET.NE.0) CALL ECROBJ('MATRIK  ',IRET)
      RETURN
*
 71   CONTINUE
*_______________________________________________________________________
*
*  produit d'une rigidite par un champoint
*_______________________________________________________________________
*
      CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 8
      CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 8
      ENDIF
      CALL MUCPRI(ICHP,IRIG,IRET)
      CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
   8  CONTINUE
*_______________________________________________________________________
*
*  produit d'un matrik par un champoint
*_______________________________________________________________________
*
      CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 9
      CALL LIROBJ('MATRIK  ',IRIG,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 9
      ENDIF
      CALL PRDMCP(IRIG,ICHP,IRET)
      CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
 9    CONTINUE

*_______________________________________________________________________
*
*  produit de deux mchaml
*_______________________________________________________________________
*
      CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
      IF (IRETOU.EQ.0) IPMODL=0
      CALL LIROBJ('MCHAML',ICHP1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 10
      CALL LIROBJ('MCHAML',ICHP2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
         CALL REFUS
         GOTO 10
      ENDIF
*
      LMOT1 = -1
      LMOT2 = -1
      LMOT3 = -1
      ILREE = -1
      CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
      IF ( IRETOU .EQ. 1) THEN
        CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
        IF (IERR .NE. 0) RETURN
        CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
        IF (IERR .NE. 0) RETURN
        CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
        IF (IERR .NE. 0) RETURN
      ENDIF
*
      CALL MUCHSC(IPMODL,ICHP1,ICHP2,IPCHMU,LMOT1,LMOT2,LMOT3,ILREE,1)
*
      IF (IPCHMU.NE.0) CALL ECROBJ('MCHAML',IPCHMU)
*
      RETURN
*
  10  CONTINUE
*_______________________________________________________________________
*
*  produit flottant evolution
*_______________________________________________________________________
*
      CALL LIRREE(XFLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 11
      CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 11
      ENDIF
      CALL MUFLEV(IEVOL,XFLO,IRET,1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
*
  11  CONTINUE
*_______________________________________________________________________
*
*  produit de deux evolutions
*_______________________________________________________________________
*
      CALL LIROBJ('EVOLUTIO',IEVOL1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 12
      CALL LIROBJ('EVOLUTIO',IEVOL2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 12
      ENDIF
      CALL PUIS(IEVOL1,IEVOL2,IRET,1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
*
  12  CONTINUE
*_______________________________________________________________________
*
*  produit flottant listreel
*_______________________________________________________________________
*
      CALL LIRREE(XFLO,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 13
      CALL LIROBJ('LISTREEL',IRE,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 13
      ENDIF
      CALL MUFLIR(IRE,XFLO,IRET,1)
      CALL ECROBJ('LISTREEL',IRET)
      RETURN
*
  13  CONTINUE
*_______________________________________________________________________
*
*  produit chpoint evolution
*_______________________________________________________________________
*
      CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 14
      CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 14
      ENDIF
      CALL VARCHP(ICHP,IEVOL,IRET,IRETOU)
      IF (IRETOU.NE.0) CALL ECROBJ('CHPOINT',IRET)
      RETURN
*
  14  CONTINUE
*_______________________________________________________________________
*
*  produit mchaml evolution
*_______________________________________________________________________
*
      CALL LIROBJ('MCHAML',IPCHP,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 15
      CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 15
      ENDIF
*
      CALL VARCHE(IPCHP,IEVOL,IPCHMU,IRETOU)
*
      IF (IRETOU.NE.0) CALL ECROBJ('MCHAML',IPCHMU)
*
      RETURN
*
  15  CONTINUE
*_______________________________________________________________________
*
*  produit listreel listreel
*_______________________________________________________________________
*
      CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 16
      CALL LIROBJ('LISTREEL',MLREE2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 16
      ENDIF
      SEGACT MLREE1,MLREE2
      JG=MLREE2.PROG(/1)
      IF(MLREE1.PROG(/1).NE.JG) THEN
          CALL ERREUR (21)
          RETURN
      ENDIF
      SEGINI MLREEL
      DO 150 I=1,JG
          PROG(I)=MLREE1.PROG(I)*MLREE2.PROG(I)
  150 CONTINUE
      SEGDES MLREEL,MLREE1,MLREE2
      CALL ECROBJ('LISTREEL',MLREEL)
      RETURN
*
  16  CONTINUE
*_______________________________________________________________________
*
*  produit listenti entier
*_______________________________________________________________________
*
      CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 17
      CALL LIRENT(IVA,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 17
      ENDIF
      SEGACT MLENT1
      JG=MLENT1.LECT(/1)
      SEGINI MLENTI
      DO 160 I=1,JG
          LECT(I)=MLENT1.LECT(I)*IVA
  160 CONTINUE
      SEGDES MLENTI,MLENT1
      CALL ECROBJ('LISTENTI',MLENTI)
      RETURN
*
   17 CONTINUE
*_______________________________________________________________________
*
*  produit listenti flottant
*_______________________________________________________________________
*
      CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 18
      CALL LIRREE(XVA,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 18
      ENDIF
      SEGACT MLENT1
      JG=MLENT1.LECT(/1)
      SEGINI MLREEL
      DO 170 I=1,JG
          PROG(I)=MLENT1.LECT(I)*XVA
  170 CONTINUE
      SEGDES MLREEL,MLENT1
      CALL ECROBJ('LISTREEL',MLREEL)
      RETURN
*
   18 CONTINUE
*_______________________________________________________________________
*
*  produit listenti listenti
*_______________________________________________________________________
*
      CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 19
      CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 19
      ENDIF
      SEGACT MLENT1,MLENT2
      JG=MLENT2.LECT(/1)
      IF(MLENT1.LECT(/1).NE.JG) THEN
          CALL ERREUR (21)
          RETURN
      ENDIF
      SEGINI MLENTI
      DO 180 I=1,JG
          LECT(I)=MLENT1.LECT(I)*MLENT2.LECT(I)
  180 CONTINUE
      SEGDES MLENTI,MLENT1,MLENT2
      CALL ECROBJ('LISTENTI',MLENTI)
      RETURN
*
  19  CONTINUE
*_______________________________________________________________________
*
*  produit table-vecteur reel
*_______________________________________________________________________
*
      CALL LIRREE(FLO1,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 20
      CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 20
      ENDIF
      SEGINI,MTABLE=MTAB1
      DO 200 I=1,MLOTAB
          IF (MTABTV(I).EQ.'FLOTTANT') THEN
              RMTABV(I)=RMTABV(I)*FLO1
          ELSE IF (MTABTV(I).EQ.'ENTIER  ') THEN
              RMTABV(I)=MTABIV(I)*FLO1
              MTABTV(I)='FLOTTANT'
          ENDIF
 200  CONTINUE
      SEGDES MTABLE,MTAB1
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
*
  20  CONTINUE
*_______________________________________________________________________
*
*  produit d'une rigidite par un champoint
*_______________________________________________________________________
*
      CALL LIROBJ('LISTCHPO',ILCHP,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 21
      CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 21
      ENDIF
      CALL MUCPLI(ILCHP,IRIG,IRET)
      CALL ECROBJ('LISTCHPO',IRET)
      RETURN
*
 21   CONTINUE

*
*  produit table-liaisons_statiques rigidite
*_______________________________________________________________________
*
      CALL LIRTAB('LIAISONS_STATIQUES',ITBST,0,IRETOU)
      IF(IRETOU.EQ.0) CALL LIRTAB('BASE_DE_MODES',ITBST,0,IRETOU)
      IF(IRETOU.EQ.0)  GO TO 22
      call lirobj('RIGIDITE',ir1,1,iretou)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 22
      ENDIF
         call prmu(ir1,itbst)
      RETURN
*
 22   CONTINUE
      CALL QUETYP(MOTERR(1:8),0,IRETOU)
      IF(IRETOU.NE.0) THEN
          CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
          CALL QUETYP(MOTERR(9:16),0,IRETOU)
          IF (IRETOU.EQ.0)  MOTERR(9:16) = '  ????  '
          CALL ERREUR(532)
      ELSE
          CALL ERREUR(533)
      ENDIF

      RETURN
      END