C OPERAD    SOURCE    PASCAL    22/11/21    21:15:04     11502          
      SUBROUTINE OPERAD
C_______________________________________________________________________
C
C     ADDITIONNE 2 NOMBRES  (ENTIER OU FLOTTANT)
C                2 CHPS/ELMTS
C                2 CHPS/POINT
C                2 EVOLUTIONS
C                2 LISTES REELLES
C                2 LISTES ENTIERES
C                2 TABLES SOUS-TYPE 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)
C

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

      PARAMETER (NCLEVO = 2)
C
      LOGICAL ir1
      CHARACTER*8 CHA1,CHA2,CTYP,COMP
      CHARACTER*4 CLEVO(NCLEVO)
      REAL*8  FLOT1
      REAL*8  FLOTTO
      REAL*8 X1,X2
      INTEGER ENTI1
      INTEGER ENTITO

      INTEGER ICH1
      INTEGER IOPERA
      INTEGER IARGU
      INTEGER I1
      REAL*8 FLO
      INTEGER ICHR
      INTEGER IR2
      INTEGER IRET
      INTEGER IRETOU
      INTEGER IREFLO

      DATA CLEVO/'ABSC','ORDO'/

      ICH1 = 0
      IOPERA = 0
      IARGU = 0
      I1 = 0
      FLO = 0.D0
      ICHR = 0
      IRET = 0
       

      CHA1   = '        '
      CHA2   = '        '
      CTYP   = '        '
C_______________________________________________________________________
C
C   RECHERCHE DU TYPE DU PREMIER ARGUMENT
C_______________________________________________________________________
      CALL QUETYP(CTYP,0,IRETOU)
      IRETOU = 0

C_______________________________________________________________________
C
C     CHERCHE A LIRE DEUX MCHAML OU MCHAML ET FLOTTANT
C_______________________________________________________________________
      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= 3 pour l'operation ADDITION
        IOPERA= 3
C       IARGU = 2  pour MCHAML + FLOTTANT
        IARGU = 2
        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

      ELSE
        CALL ACTOBJ('MCHAML  ',ICH2,1)
        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 LIRE 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
          GO TO 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     CHERCHE A LIRE UN CHPOINT ET UN FLOTTANT
C_______________________________________________________________________
  103 CALL LIROBJ('CHPOINT ',ICH1,0,IRETOU)
      IF (IRETOU.EQ.0) GOTO 104
      CALL ACTOBJ('CHPOINT ',ICH1,1)
      CALL LIRREE(FLO,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
           CALL REFUS
           GO TO 104
      ENDIF
C     IOPERA= 3 pour l'operation ADDITION
C     IARGU = 2 pour FLOTTANT
      IOPERA= 3
      IARGU = 2
      I1    = 0
      CALL OPCHP1(ICH1,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 EVOLUTIO
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
           GO TO 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',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 106
      MLREEL=ICH
      SEGACT,MLREEL
      CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
           CALL REFUS
           GO TO 106
      ENDIF
      MLREEL=ICHR
      SEGACT,MLREEL
C     Addition entre LISTREEL et LISTREEL terme a terme
C     IOPERA= 3 pour l'operation ADDITION
C     IARGU = 0 pour ne pas utiliser I1 et FLO
      IOPERA= 3
      IARGU = 0
      I1    = 0
      FLO   = REAL(0.D0)
      CALL OPLRE1(ICH,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
           GO TO 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 LISTE ENTIER
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
        GO TO 1062
      ELSE
C     Conversion du LISTENTI en LISTREEL
        SEGACT MLENTI
        JG=LECT(/1)
        SEGINI MLREEL
        DO IG=1,JG
          FLOT1   = REAL(LECT(IG))
          PROG(IG)= FLOT1
        ENDDO
      ENDIF

      CALL ADLISR(IPO1,MLREEL,IRET,1)
      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',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 1063
      MLREEL=ICH
      SEGACT,MLREEL
      CALL LIRREE(FLO,0,IRETOU)
      IF(IRETOU.EQ.0) THEN
        CALL REFUS
        GO TO 1063
      ENDIF
C     Addition entre l'ENTIER/FLOTTANT et tous les indices du LISTREEL
C     IOPERA= 3 pour l'operation ADDITION
C     IARGU = 2 pour FLOTTANT
      IOPERA= 3
      IARGU = 2
      I1    = 0
      CALL OPLRE1(ICH,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

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

      IF( (IRET1.EQ.0) .AND. (IR2.EQ.0)) THEN
        CALL REFUS
        GO TO 107
      ELSE
C     Addition entre l''ENTIER/FLOTTANT et tous les indices du LISTENTIER
        SEGACT MLENT1
        JG=MLENT1.LECT(/1)
        IF (IRET1 .NE. 0) THEN
C         Cas de la Addition avec un ENTIER
          SEGINI MLENT2
          DO IG=1,JG
            IENT1   = I1 + MLENT1.LECT(IG)
            MLENT2.LECT(IG)= IENT1
          ENDDO
          CALL ECROBJ('LISTENTI',MLENT2)
        ELSEIF (IR2 .NE. 0) THEN
C         Cas de l''Addition avec un FLOTTANT
          SEGINI MLREE2
          DO IG=1,JG
            FLOT1   = X1 + REAL(MLENT1.LECT(IG))
            MLREE2.PROG(IG)= FLOT1
          ENDDO
          SEGACT,MLREE2*NOMOD
          CALL ECROBJ('LISTREEL',MLREE2)
        ENDIF
      ENDIF
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIRE   2 NOMBRES ENTIERS
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
           GO TO 108
      ENDIF
      CALL ECRENT(I1+I2)
      RETURN
C_______________________________________________________________________
C
C     CHERCHE A LIRE   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
           GO TO 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) GO TO 110
      CALL QUENOM(MOTERR(1:8))
      CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
           CALL REFUS
           GO TO 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
C  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  C'EST PASSE OU CA A CASSE ON SORT
        IF (IERR.NE.0) RETURN
        GOTO 71
  72    CONTINUE
C  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)
  71  CONTINUE
      SEGDES MTABLE,MTAB1,MTAB2
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
C_______________________________________________________________________
C
C   EST CE UNE TABLE ESCLAVE DE MCHAML
C_______________________________________________________________________
  110 CONTINUE
      CALL LIRTAB('ESCLAVE',MTABle,0,IRETOU)
      if (iretou.eq.0) goto 111
      segact mtable
      ml=mlotab
C  l'indice 1 est le sous type
      ind=mtabii(3)
      ctyp=' '
      call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,enti1,flot1,' ',ir1,id1)
      iretou=id1
      CALL ACTOBJ(CTYP,ID1,1)
      if (CTYP.eq.'MCHAML') then
       do i=4,ml
        ind=mtabii(i)
        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,id3,rr1,' ',ir1,id2)
        if (ierr.ne.0) return
        call ADCHEL(ID1,ID2,IRETOU,1)
        id1=iretou
       enddo
      elseif (CTYP.eq.'CHPOINT ') then
       do i=4,ml
        ind=mtabii(i)
        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,id3,rr1,' ',ir1,id2)
        if (ierr.ne.0) return
        call ADCHPO(ID1,ID2,IRETOU,1D0,1D0)
        id1=iretou
       enddo
      elseif (CTYP.eq.'LISTREEL') then
        IOPERA= 3
        IARGU = 0
        iretou=id1
        I1    = 0
        FLO   = REAL(0.D0)
        iret=0
        do i=4,ml
        ind=mtabii(i)
        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,id3,rr1,' ',ir1,id2)
        if (ierr.ne.0) return
        MLREEL=ID2
        SEGACT,MLREEL
        CALL OPLRE1(ID2,IOPERA,IARGU,I1,FLO,IRETOU,IRET)
        enddo
      elseif (CTYP.eq.'LISTENTI') then
       do i=4,ml
        ind=mtabii(i)
        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,id3,rr1,' ',ir1,id2)
        if (ierr.ne.0) return
        MLENTI=ID2
        SEGACT,MLENTI
        CALL ADLISE(ID1,ID2,IRETOU,1)
        id1=iretou
       enddo
      elseif (CTYP.eq.'EVOLUTIO') then
       do i=4,ml
        ind=mtabii(i)
        call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >          CTYP,id3,rr1,' ',ir1,id2)
        if (ierr.ne.0) return
        CALL ACTOBJ('EVOLUTIO',ID2,1)
        CALL ADEVOL(ID1,ID2,IRETOU,1)
        id1=iretou
       enddo
      elseif (CTYP.eq.'ENTIER') then
        ENTITO=MTABLE.MTABIV(3)
       do i=4,ml
        ENTITO=ENTITO+MTABLE.MTABIV(I)
       enddo
      CALL ECRENT(ENTITO)
      return
      elseif (CTYP.eq.'FLOTTANT') then
        FLOTTO=RMTABV(3)
        do i=4,ml
        FLOTTO=FLOTTO+MTABLE.RMTABV(I)
        enddo
        CALL ECRREE(FLOTTO)
        return
      else
       moterr(1:8)='MCHAML  '
       call erreur(-173)
       call erreur(648)
       return
      endif
      segdes mtable
 100  continue
      if (ierr.ne.0) return
      CALL ACTOBJ(ctyp,iretou,1)
      call ecrobj(ctyp,iretou)
      return
C_______________________________________________________________________
C
C     CHERCHE A LIROBJ 1 EVOLUTIO ET 1 ENTIER / FLOTTANT
C_______________________________________________________________________
 111  CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
      IF(IRETOU.EQ.0) GOTO 112
      CALL ACTOBJ('EVOLUTIO',ICH,1)
      CALL LIRENT(I1,0,IREENT)
      IF(IREENT.EQ.0) THEN      
        CALL LIRREE(FLO,0,IREFLO)
        IF(IREFLO.EQ.0) THEN      
          CALL REFUS
          GOTO 112
        ELSE
C         IARGU = 2 pour FLOTTANT
          IARGU = 2
        ENDIF
      ELSE
C       IARGU = 1 pour ENTIER
        IARGU = 1
      ENDIF
C     Lecture facultative des mots-cles ABSC/ORDO
      ICLE = 0
      CALL LIRMOT(CLEVO,NCLEVO,ICLE,0)
      IF (ICLE.EQ.0) ICLE = 2
C     Addition entre l'ENTIER/FLOTTANT et tous les indices du EVOLUTIO
C     IOPERA= 3 pour l'operation ADDITION
      IOPERA= 3
      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 ET 1 MOT
C_______________________________________________________________________
 112  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
        CALL LIRREE(FLO,0,IREFLO)
        IF(IREFLO.EQ.0) THEN
          CALL REFUS
          GOTO 120
        ELSE
C         IARGU = 2 pour FLOTTANT
          IARGU = 2
        ENDIF
      ELSE
C       IARGU = 1 pour ENTIER
        IARGU = 1
      ENDIF
C     Lecture du nom de la composante
      CALL LIRCHA(COMP,1,IRETOU)
      IF (IERR.NE.0) RETURN
C     Addition entre l'ENTIER/FLOTTANT et les valeurs du NUAGE
C     IOPERA= 3 pour l'operation ADDITION
      IOPERA= 3
      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

      END