C OPERDI    SOURCE    GOUNAND   12/07/25    21:15:00     7443           
      SUBROUTINE OPERDI
*_______________________________________________________________________
*
*     DIVISE    UN LISTREEL PAR UN FLOTTANT (OU UN ENTIER)
*     DIVISE    UN CHAMPS PAR ELEMT PAR UN FLOTTANT (OU 1 ENTIER)
*     DIVISE    UN OBJET RIGIDITE PAR UN FLOTTANT (OU UN ENTIER)
*     DIVISE    UN CHAMP PAR POINT   PAR UN AUTRE CHAMP PAR POINT
*     DIVISE    UN CHAMPS PAR POINT PAR UN FLOTTANT (OU 1 ENTIER)
*     DIVISE    2 NOMBRES (FLOTTANT OU ENTIER)
*     DIVISE    UN POINT PAR UN NOMBRE
*     DIVISE    UN OBJET EVOLUTIO (ORDONNEES) PAR UN FLOTTANT
*                                               (OU UN ENTIER)
*     DIVISE    UN OBJET EVOLUTIO PAR UN OBJET EVOLUTIO
*     DIVISE    UNE TABLE SOUSTYPE VECTEUR PAR UN REEL
*
*   PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 12/90
*
*_______________________________________________________________________
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC CCREEL
-INC CCOPTIO
-INC SMCOORD
-INC SMTABLE
-INC SMLREEL
-INC SMLCHPO
*
*     CHERCHE A LIROBJ DEUX CHAMPS PAR ELEMENT (MCHAML)
*
  100 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 101
      CALL LIROBJ('MCHAML',IPCHE2,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 101
      ENDIF
      IPLREE = 0
      IPLMOT = 0
      CALL MUCHSC(0,IPCHE1,IPCHE2,IPCHMU,IPLMOT,IPLMOT,IPLMOT,IPLREE,-1)
      IF (IPCHMU.EQ.0) RETURN
      CALL ECROBJ('MCHAML',IPCHMU)
      RETURN
*
*     CHERCHE A LIROBJ UN CHAMP PAR ELEMENT (MCHAML) ET UN FLOTTANT
*
  101 CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 102
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 102
      ENDIF
      IF(FLO.EQ.0.D0) GO TO 5000
      FLD=FLO
      CALL MUCHEL(IPCHE1,FLD,IPCHMU,-1)
      IF (IPCHMU.EQ.0) RETURN
      CALL ECROBJ('MCHAML',IPCHMU)
      RETURN
*
*     CHERCHE A LIRE DEUX CHAMPS PAR POINT
*
  102 CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 103
      CALL LIROBJ('CHPOINT ',ICHP2,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 103
      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
*
*     CHPOINT / FLOTTANT
*
  103 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 104
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 104
      ENDIF
      IF(FLO.EQ.0.D0) GO TO 5000
      FLD=FLO
      CALL MUCHPO(IPO1,FLD,IRET,-1)
      IF(IRET.EQ.0) RETURN
      CALL ECROBJ('CHPOINT ',IRET)
      RETURN
*
*     CHERCHE A LIROBJ UN OBJET DE TYPE RIGIDITE ET UN FLOTTANT
*
  104 CALL LIROBJ('RIGIDITE',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 1041
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 1041
      ENDIF
      IF (FLO.EQ.0.D0) GOTO 5000
      CALL MUFLRI(IPO1,FLO,IRET,-1)
      CALL ECROBJ('RIGIDITE',IRET)
      RETURN
*
*     CHERCHE A LIROBJ UN OBJET DE TYPE MATRIK ET UN FLOTTANT
*
 1041 CALL LIROBJ('MATRIK  ',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 105
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 105
      ENDIF
      IF (ABS(FLO).LT.XPETIT) GOTO 5000
      CALL PRDMF(1.D0/FLO,IPO1,IRET)
      IF (IRET.NE.0) CALL ECROBJ('MATRIK  ',IRET)
      RETURN
*
*     CHERCHE A LIROBJ UN OBJET DE TYPE EVOLUTIO ET UN FLOTTANT
*
  105 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 106
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 106
      ENDIF
      IF (FLO.EQ.0.D0) GOTO 5000
      CALL MUFLEV(IPO1,FLO,IRET,-1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
*
*     EVOLUTIO / EVOLUTIO
*
  106 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 107
      CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 107
      ENDIF
      CALL PUIS(IPO1,IPO2,IRET,-1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
*
*     CHERCHE A LIROBJ UN LISTREEL ET UN LISTREEL
*
  107 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 108
      CALL LIROBJ('LISTREEL',MLREE2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 108
      ENDIF
      MLREE1 = IPO1
      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
        X2 = MLREE2.PROG(I)
*Gounand: on ne voit pas pourquoi on ferait un traitement
*         différent pour les LISTREEL
*        IF(ABS(X2).LT.1.D-30) X2=1.D-30
        IF(X2.EQ.0.D0) GOTO 5000
        PROG(I)=MLREE1.PROG(I)/X2
 150  CONTINUE
      SEGDES MLREEL,MLREE1,MLREE2
      CALL ECROBJ('LISTREEL',MLREEL)
      RETURN
*
*     LISTREEL / FLOTTANT OU ENTIER
*
  108 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 109
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 109
      ENDIF
      IF(FLO.EQ.0.D0) GO TO 5000
      CALL MUFLIR(IPO1,FLO,IRET,-1)
      IF(IRET.EQ.0) RETURN
      CALL ECROBJ('LISTREEL',IRET)
      RETURN
*
*     CHERCHE A LIROBJ 2 ENTIERS
*
  109 CALL LIRENT(I1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 110
      CALL LIRENT(I2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 110
      ENDIF
      IF (I2.EQ.0) GOTO 5000
      CALL ECRENT(I1/I2)
      RETURN
C
C   CHERCHE A LIRE DEUX FLOTTANTS

  110 CALL LIRREE(X1,0,IRETOU)
      IF ( IRETOU.EQ.0) GO TO 111
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 111
      ENDIF
      IF(X2.EQ.0.D0) GOTO 5000
      CALL ECRREE(X1/X2)
      RETURN
*
*     CHERCHE A LIROBJ UN POINT ET UN FLOTTANT
*
 111  CALL LIROBJ('POINT   ',IP1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 112
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 112
      ENDIF
      IF(X2.EQ.0.D0) GOTO 5000
      SEGACT MCOORD*MOD
      ID=IDIM+1
      IREF=ID*(IP1-1)
      DO 11 I=1,ID
      XCOOR(**)=XCOOR(IREF+I)/X2
  11  CONTINUE
      IR=XCOOR(/1)/ID
      CALL ECROBJ('POINT   ',IR)
      RETURN
*
*  CHERCHE A LIRE UNE TABLE SOUSTYPE VECTEUR ET UN FLOTTANT
*
  112 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 113
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 113
      ENDIF
      IF(X2.EQ.0.D0) GOTO 5000
      SEGINI,MTABLE=MTAB1
      DO 701 I=1,MLOTAB
      IF (MTABTV(I).EQ.'FLOTTANT') THEN
         RMTABV(I)=RMTABV(I)/X2
      ELSEIF (MTABTV(I).EQ.'ENTIER  ') THEN
         RMTABV(I)=MTABIV(I)/X2
         MTABTV(I)='FLOTTANT'
      ENDIF
 701  CONTINUE
      SEGDES MTABLE,MTAB1
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
C
 113  CALL LIROBJ('LISTCHPO',LIPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 114
      CALL LIROBJ('LISTREEL',LREE1,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
          CALL REFUS
          GO TO 114
      ENDIF
      mlreel = lree1
      mlchp1 = lipo1
      segact mlchp1,mlreel
      jg = prog(/1)
      n1 = mlchp1.ichpoi(/1)
      if (jg.ne.n1) call erreur(3)
      if (ierr.ne.0) return
      segini mlchpo
      do ic = 1,n1
         flo = prog(ic)
         ipo1 = mlchp1.ichpoi(ic)
        IF(FLO.EQ.0.D0) GO TO 5000
        FLD=FLO
        CALL MUCHPO(IPO1,FLD,IRET,-1)
        IF(IRET.EQ.0) RETURN
         ichpoi(ic) = iret
      enddo
      segdes mlchpo,mlchp1,mlreel
      CALL ECROBJ('LISTCHPO',mlchpo)
      RETURN
C
C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
C
 114  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
 5000 CONTINUE
      CALL ERREUR(835)
      RETURN
      END