C OPERSO    SOURCE    PASCAL    22/11/21    21:15:05     11502          
      SUBROUTINE OPERSO
C_______________________________________________________________________
C
C     SOUSTRAIT  2 NOMBRES  (ENTIER OU FLOTTANT)
C                2 CHPS/ELMTS
C                2 CHPS/POINT
C                2 EVOLUTIONS
C                2 LISTES ENTIERES
C                2 LISTES REELLES
C                2 TABLE SOUSTYPE VECTEUR
C
C     PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 29 10 90
C
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC SMLENTI
-INC SMLREEL

      PARAMETER (NCLEVO = 2)
C
      CHARACTER*4 CLEVO(NCLEVO)
      CHARACTER*8 CHA1,CHA2,CTYP,COMP
      REAL*8 FLOT1

      DATA CLEVO/'ABSC','ORDO'/

       INTEGER ICH1
       INTEGER IOPERA
       INTEGER IARGU
       INTEGER I1
       REAL*8 FLO
       INTEGER ICHR
       INTEGER IRET
       ICH1 = 0
       IOPERA = 0
       IARGU = 0
       I1 = 0
       FLO = 0.D0
       ICHR = 0
       IRET = 0

      CHA1   = '        '
      CHA2   = '        '
*
*   RECHERCHE DU TYPE DU PREMIER ARGUMENT
*
      CALL QUETYP(CTYP,0,IRETOU)
      IRETOU=0
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DES CHAMPS PAR ELEMENT (MCHAML)
C_______________________________________________________________________
C      IF (CTYP .NE. 'MCHAML') GOTO 102
      CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 102
      CALL ACTOBJ('MCHAML  ',ICH1,1)
      
      CALL LIROBJ('MCHAML  ',ICH2,0,IRETOU)      
      IF (IRETOU.EQ.0) THEN
        CALL LIRREE(FLO,0,IRETOU)
        IF(IRETOU.EQ.0) THEN
            CALL REFUS
            GOTO 102
        ENDIF
C       IOPERA= 4 pour l'operation ADDITION
        IOPERA= 4
        IF (CTYP .EQ. 'MCHAML  ') THEN
C         IARGU = 2  pour MCHAML - FLOTTANT
          IARGU = 2
        ELSE
C         IARGU = 21 pour FLOTTANT - MCHAML
          IARGU = 21
        ENDIF
        I1    = 0
        ICHR = 0
        IRET = 0
        CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
        IF(IRET.NE.0) THEN
          CALL ACTOBJ('MCHAML  ',ICHR,1)
          CALL ECROBJ('MCHAML  ',ICHR)
        ELSE
          CALL ERREUR(26)
        ENDIF
        RETURN

      ELSE
        CALL ADCHEL(ICH1,ICH2,IPCHAD,-1)
        IF (IPCHAD.EQ.0) RETURN
        CALL ACTOBJ('MCHAML  ',IPCHAD,1)
        CALL ECROBJ('MCHAML  ',IPCHAD)
        ENDIF
      RETURN

C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DES CHPOINT
C_______________________________________________________________________
  102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 103
      CALL ACTOBJ('CHPOINT ',IPO1,1)
      CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 103
      ENDIF
      CALL ACTOBJ('CHPOINT ',IPO2,1)
      CALL ADCHPO(IPO1,IPO2,IRET,1D0,-1D0)
      IF(IRET.EQ.0) RETURN
      CALL ACTOBJ('CHPOINT ',IRET,1)
      CALL ECROBJ('CHPOINT ',IRET)
      RETURN
C_______________________________________________________________________
C
C  SOUSTRACTION CHPOINT-FLOTTANT OU FLOTTANT-CHPOINT
C_______________________________________________________________________
  103 CALL LIROBJ('CHPOINT ',ICH,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 104
      CALL ACTOBJ('CHPOINT ',ICH,1)
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 104
      ENDIF
C     IOPERA= 4 pour l'operation SOUSTRACTION
      IOPERA= 4
      IF (CTYP .EQ. 'CHPOINT ') THEN
C       IARGU = 2  pour CHPOINT - FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT - CHPOINT
        IARGU = 21
      ENDIF
      I1    = 0
      CALL OPCHP1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('CHPOINT ',ICHR,1)
        CALL ECROBJ('CHPOINT ',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DES EVOLUTIONS
C_______________________________________________________________________
  104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 105
      CALL ACTOBJ('EVOLUTIO',IPO1,1)
      CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 105
      ENDIF
      CALL ACTOBJ('EVOLUTIO',IPO2,1)
      CALL ADEVOL(IPO1,IPO2,IRET,-1)
      IF(IRET.EQ.0) RETURN
      CALL ACTOBJ('EVOLUTIO',IRET,1)
      CALL ECROBJ('EVOLUTIO',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DES LISTREEL
C_______________________________________________________________________
  105 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 106
      MLREEL=ICH1
      SEGACT,MLREEL
      CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 106
      ENDIF
      MLREEL=ICHR
      SEGACT,MLREEL
C     IOPERA= 4 pour l'operation SOUSTRACTION
C     IARGU = 0
      IOPERA= 4
      IARGU = 0
      I1    = 0
      FLO   = REAL(0.D0)
      CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        MLREEL=ICHR
        SEGACT,MLREEL*NOMOD
        CALL ECROBJ('LISTREEL',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ DES LISTENTI
C_______________________________________________________________________
  106 CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1061
      MLENTI=IPO1
      SEGACT,MLENTI
      CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 1061
      ENDIF
      MLENTI=IPO2
      SEGACT,MLENTI
      CALL ADLISE(IPO1,IPO2,IRET,-1)
      IF(IRET.EQ.0) RETURN
      MLENTI=IRET
      SEGACT,MLENTI*NOMOD
      CALL ECROBJ('LISTENTI',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 LISTREEL ET 1 LISTENTI
C_______________________________________________________________________C
 1061 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1062
      MLREEL=IPO1
      SEGACT,MLREEL
      CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
           CALL REFUS
           GOTO 1062
      ENDIF
C     Conversion du LISTENTI en LISTREEL
      SEGACT,MLENTI
      JG=LECT(/1)
      SEGINI,MLREEL
      DO IG=1,JG
        PROG(IG)= REAL(LECT(IG))
      ENDDO

      IF( CTYP .EQ. 'LISTENTI') THEN
        CALL ADLISR(MLREEL,IPO1,IRET,-1)
      ELSE
        CALL ADLISR(IPO1,MLREEL,IRET,-1)
      ENDIF
      IF(IRET.EQ.0) RETURN
      MLREEL=IRET
      SEGACT,MLREEL*NOMOD
      CALL ECROBJ('LISTREEL',IRET)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 LISTREEL ET 1 ENTIER / FLOTTANT
C_______________________________________________________________________
 1062 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1063
      MLREEL=ICH1
      SEGACT,MLREEL
      CALL LIRREE(FLO,0,IR2)
      IF(IR2 .EQ. 0) THEN
        CALL REFUS
        GOTO 1063
      ENDIF
C     IOPERA= 4 pour l'operation SOUSTRACTION
      IOPERA= 4
      IF (CTYP .EQ. 'LISTREEL') THEN
C       IARGU = 2  pour LISTREEL - FLOTTANT
        IARGU = 2
      ELSE
C       IARGU = 21 pour FLOTTANT - LISTREEL
        IARGU = 21
      ENDIF
      I1    = 0
      CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        MLREEL=ICHR
        SEGACT,MLREEL*NOMOD
        CALL ECROBJ('LISTREEL',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 LISTENTI ET 1 ENTIER / FLOTTANT
C_______________________________________________________________________
 1063 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 107
      MLENTI=MLENT1
      SEGACT,MLENTI

      CALL LIRENT(I1,0,IR1)
      CALL LIRREE(X1,0,IR2)

      IF( (IR1.EQ.0) .AND. (IR2.EQ.0)) THEN
        CALL REFUS
        GOTO 107
      ENDIF
C     Soustraction entre l'ENTIER/FLOTTANT et tous les indices du LISTENTIER
      JG=MLENT1.LECT(/1)
      IF (IR1 .NE. 0) THEN
C       Cas de la soustraction avec un ENTIER
        SEGINI,MLENT2
        DO IG=1,JG
          IF( CTYP .EQ. 'ENTIER  ') THEN
            IENT1   = I1 - MLENT1.LECT(IG)
            MLENT2.LECT(IG)= IENT1
          ELSE
            IENT1   = MLENT1.LECT(IG) - I1
            MLENT2.LECT(IG)= IENT1
          ENDIF
        ENDDO
        SEGACT,MLENT2*NOMOD
        CALL ECROBJ('LISTENTI',MLENT2)

      ELSEIF (IR2 .NE. 0) THEN
C       Cas de la soustraction avec un FLOTTANT
        SEGINI,MLREE2
        DO IG=1,JG
          IF( CTYP .EQ. 'FLOTTANT') THEN
            FLOT1   = X1 - REAL(MLENT1.LECT(IG))
            MLREE2.PROG(IG)= FLOT1
          ELSE
            FLOT1   = REAL(MLENT1.LECT(IG)) - X1
            MLREE2.PROG(IG)= FLOT1
          ENDIF
        ENDDO
        SEGACT,MLREE2*NOMOD
        CALL ECROBJ('LISTREEL',MLREE2)
      ENDIF 
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 2 NOMBRES ENTIER
C_______________________________________________________________________
  107 CALL LIRENT(I1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 108
      CALL LIRENT(I2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 108
      ENDIF
      CALL ECRENT(I1-I2)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 2 NOMBRES FLOTTANTS
C_______________________________________________________________________
  108 CALL LIRREE(X1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 109
      CALL LIRREE(X2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 109
      ENDIF
      CALL ECRREE(X1-X2)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR
C_______________________________________________________________________
 109  CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 110
      CALL QUENOM(MOTERR(1:8))
      CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
          CALL REFUS
          GOTO 110
      ENDIF
      CALL QUENOM(MOTERR(9:16))
      SEGINI,MTABLE=MTAB1
      SEGACT MTAB2
      DO 71 J=1,MTAB2.MLOTAB
       CHA1=MTAB2.MTABTI(J)
       X1=MTAB2.RMTABI(J)
       IVA1=MTAB2.MTABII(J)
       DO 72 I=1,MLOTAB
        IF (CHA1.NE.MTABTI(I)) GOTO 72
        IF (CHA1.EQ.'FLOTTANT') THEN
          IF (X1.NE.RMTABI(I)) GOTO 72
        ELSE
          IF (IVA1.NE.MTABII(I)) GOTO 72
        ENDIF
*  ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE
        CHA2=MTAB2.MTABTV(J)
        IF (CHA2.EQ.'FLOTTANT') THEN
         IF (MTABTV(I).EQ.'FLOTTANT') THEN
            RMTABV(I)=RMTABV(I)-MTAB2.RMTABV(J)
         ELSEIF (MTABTV(I).EQ.'ENTIER  ') THEN
            MTABTV(I)='FLOTTANT'
            RMTABV(I)=MTABIV(I)-MTAB2.RMTABV(J)
         ELSE
            CALL ERREUR(135)
         ENDIF
        ELSEIF (CHA2.EQ.'ENTIER  ') THEN
         IF (MTABTV(I).EQ.'ENTIER  ') THEN
            MTABIV(I)=MTABIV(I)-MTAB2.MTABIV(J)
         ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN
            RMTABV(I)=RMTABV(I)-MTAB2.MTABIV(J)
         ELSE
            CALL ERREUR(135)
         ENDIF
        ELSE
           IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J))
     #          CALL ERREUR(135)
        ENDIF
*  C'EST PASSE OU CA A CASSE ON SORT
        IF (IERR.NE.0) RETURN
        GOTO 71
  72    CONTINUE
*  ON RAJOUTE LE MTAB2(J) A MTABL
        MLOTAB=MLOTAB+1
        M=MTABII(/1)
        IF (M.LT.MLOTAB) THEN
         M=M+100
         SEGADJ MTABLE
        ENDIF
        MTABII(MLOTAB)=MTAB2.MTABII(J)
        MTABTI(MLOTAB)=MTAB2.MTABTI(J)
        RMTABI(MLOTAB)=MTAB2.RMTABI(J)
        MTABIV(MLOTAB)=MTAB2.MTABIV(J)
        MTABTV(MLOTAB)=MTAB2.MTABTV(J)
        RMTABV(MLOTAB)=-MTAB2.RMTABV(J)
*  SI ENTIER ON OPPOSE
        IF (MTABTV(MLOTAB).EQ.'ENTIER  ') MTABIV(MLOTAB)=-MTABIV(MLOTAB)
  71  CONTINUE
      SEGDES MTABLE,MTAB1,MTAB2
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 EVOLUTIO ET 1 ENTIER / FLOTTANT
C_______________________________________________________________________
 110  CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 111
      CALL ACTOBJ('EVOLUTIO',ICH,1)
      CALL LIRENT(I1,0,IREENT)
      IF(IREENT.EQ.0) THEN
        I1=0
        CALL LIRREE(FLO,0,IREFLO)
        IF(IREFLO.EQ.0) THEN      
          CALL REFUS
          GOTO 111
        ELSE
          IF (CTYP .EQ. 'EVOLUTIO') THEN
C           IARGU = 2  pour EVOLUTIO - FLOTTANT
            IARGU = 2
          ELSE
C           IARGU = 21 pour FLOTTANT - EVOLUTIO
            IARGU = 21
          ENDIF
        ENDIF
      ELSE
        FLO=REAL(0.D0)
        IF (CTYP .EQ. 'EVOLUTIO') THEN
C         IARGU = 1  pour EVOLUTIO - ENTIER
          IARGU = 1
        ELSE
C         IARGU = 11 pour ENTIER   - EVOLUTIO
          IARGU = 11
        ENDIF
      ENDIF
C     Soustraction entre l'ENTIER/FLOTTANT et tous les indices du EVOLUTIO
C     IOPERA= 4 pour l'operation SOUSTRACTION
      IOPERA= 4
      ICLE = 0
      CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
      IF (ICLE.EQ.0) ICLE = 2
      CALL OPEVO1(ICH,IOPERA,IARGU,ICLE,I1,FLO,ICHR,IRET)
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('EVOLUTIO',ICHR,1)
        CALL ECROBJ('EVOLUTIO',ICHR)
      ELSE
        CALL ERREUR(26)
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 NUAGE ET 1 ENTIER / FLOTTANT
C_______________________________________________________________________
 111  CALL LIROBJ('NUAGE   ',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 120
      CALL ACTOBJ('NUAGE   ',ICH,1)
      CALL LIRENT(I1,0,IREENT)
      IF (IREENT.EQ.0) THEN
        I1=0
        CALL LIRREE(FLO,0,IREFLO)
        IF (IREFLO.EQ.0) THEN
          CALL REFUS
          GOTO 120
        ELSE
          IF (CTYP .EQ. 'NUAGE   ') THEN
C           IARGU = 2  pour NUAGE - FLOTTANT
            IARGU = 2
          ELSE
C           IARGU = 21 pour FLOTTANT - NUAGE
            IARGU = 21
          ENDIF
        ENDIF
      ELSE
        FLO=REAL(0.D0)
        IF (CTYP .EQ. 'NUAGE   ') THEN
C         IARGU = 1  pour NUAGE - ENTIER
          IARGU = 1
        ELSE
C         IARGU = 11 pour ENTIER   - NUAGE
          IARGU = 11
        ENDIF
      ENDIF
C     Lecture du nom de la composante
      CALL LIRCHA(COMP,1,IRETOU)
      IF (IERR.NE.0) RETURN
C     Soustraction entre l'ENTIER/FLOTTANT et les valeurs du NUAGE
C     IOPERA= 4 pour l'operation SOUSTRACTION
      IOPERA= 4
      CALL OPNUA1(ICH,IOPERA,IARGU,COMP,I1,FLO,ICHR,IRET)
      IF (IERR.NE.0) RETURN
      IF(IRET.NE.0) THEN
        CALL ACTOBJ('NUAGE   ',ICHR,1)
        CALL ECROBJ('NUAGE   ',ICHR)
      ELSE
C       ERREUR 5 car erreurs gerees dans OPNUA1
        CALL ERREUR(5)
      ENDIF
      RETURN

C_______________________________________________________________________
C
C   ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
C_______________________________________________________________________
  120 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