Sources Esope | Cast3M

ega
C EGA       SOURCE    CB215821  25/04/22    21:15:04     12245          
      SUBROUTINE EGA
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCREEL
 
-INC SMLENTI
-INC SMTEXTE
 
      EXTERNAL LONG
      CHARACTER*(8) ITTEMP,ITTEM2
      CHARACTER*(LOCHAI) CHAR1,CHAR2
      LOGICAL IRET,BOOL,BOOL1
      INTEGER I1,I2
      REAL*8 EPS1,X1,X2,XVAL
C
C  TEST SUR LES TEXTES
C
      INTEXT=1
      CALL QUETYP(ITTEMP,0,IRETOU)
      MOTERR(1:8)=ITTEMP
      IF(IRETOU.EQ.0) THEN
         CALL ERREUR( 533)
         RETURN
      ENDIF
      IF(ITTEMP.EQ.'TEXTE   ') GOTO 300
      IF(ITTEMP.EQ.'LOGIQUE ') GOTO 310
      IF(ITTEMP.EQ.'LISTENTI') GOTO 330
      IF(ITTEMP.EQ.'ENTIER  ') GOTO 340
      IF(ITTEMP.EQ.'MOT     ') GOTO 350
      IF(ITTEMP.EQ.'FLOTTANT') GOTO 360
 
*     Comparaison des 2 pointeurs des objets
      iret=.true.
      ittemp=' '
      ittem2=' '
      call lirobj(ittemp,iv1,1,iretou)
      call lirobj(ittem2,iv2,1,iretou)
      IF(ierr.ne.0) return
 
C     Le test des TYPES semble inutile... (plus Comparaison de chaines un poil lent)
C     IF(ittemp.ne.ittem2) then
C       iret=.false.
C       goto 100
C     ENDIF
 
      IF(iv1 .ne. iv2) then
C       Cas des POINTEURS differents
        iret=.false.
        goto 100
 
      else
C       Cas des POINTEURS egaux : teste l'horodatage (ENTRY dans GEMAT)
        call oooho1(iv1,ih_1)
        call oooho1(iv2,ih_2)
        IF(ih_1 .ne. ih_2) then
          iret=.false.
          goto 100
        endif
      endif
      GOTO 100
 
  300 CONTINUE
C  TEST SUR TEXTE
      IRET=.FALSE.
      INTEXT=1
      CALL LIROBJ(ITTEMP,ITEX1,0,IRETOU)
      INTEXT=1
      CALL LIROBJ(ITTEMP,ITEX2,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.1) THEN
        MTEXTE=ITEX1
        MTEXT1=ITEX2
        SEGACT MTEXTE,MTEXT1
        NCA1=NCART
        NCA2=MTEXT1.NCART
        IF(NCA1.NE.NCA2) GOTO 221
        DO I=1,NCA1
          IF(MTEXT(I:I).NE.MTEXT1.MTEXT(I:I)) GOTO 221
        ENDDO
        IRET=.TRUE.
 221    SEGDES MTEXTE,MTEXT1
      ELSE
        INTEXT=0
        ITTEMP=' '
        CALL LIROBJ(ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
 310  CONTINUE
C  TEST SUR BOOLEENS
      IRET=.FALSE.
      INTEXT=0
      CALL LIRLOG(BOOL ,1,IRETOU)
      CALL LIRLOG(BOOL1,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.1) THEN
        IRET= BOOL.EQV.BOOL1
      ELSE
        ITTEMP=' '
        CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
 330  CONTINUE
C  TEST SUR  LISTENTI
      IRET=.FALSE.
      CALL LIROBJ(ITTEMP,MLENTI,1,IRETOU)
      CALL LIROBJ(ITTEMP,MLENT1,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.1) THEN
        SEGACT MLENTI,MLENT1
        IF(LECT(/1).NE.MLENT1.LECT(/1)) GOTO 102
        DO I=1,LECT(/1)
          IF(LECT(I).NE.MLENT1.LECT(I)) GOTO 102
        ENDDO
        IRET=.TRUE.
  102   CONTINUE
      ELSE
        ITTEMP=' '
        CALL LIROBJ(ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
 340  CONTINUE
C  TEST SUR ENTIERS
      IRET=.FALSE.
      CALL LIRENT(I1,1,IRETOU)
      CALL LIRENT(I2,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.1) THEN
         IRET= I1.EQ.I2
      ELSE
        ITTEMP=' '
        CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
 350  CONTINUE
C  TEST SUR MOT
      IRET=.FALSE.
      CALL LIRCHA(CHAR1,1,IRET1)
      CALL LIRCHA(CHAR2,0,IRET2)
      IF(IERR.NE.0) RETURN
      IF(IRET2.NE.0) THEN
        CALL LIRENT(LL0,0,IRET3)
        IF(IRET3.NE.0) THEN
          IF(LL0.GT.LOCHAI) THEN
             INTERR(1) = LL0
             CALL ERREUR(36)
             RETURN
          ENDIF
          IRET= CHAR1(1:LL0).EQ.CHAR2(1:LL0)
        ELSE
          IF( CHAR1.EQ.CHAR2) THEN
           IRET=.TRUE.
          ELSE
            LL1=LONG(CHAR1)
            LL2=LONG(CHAR2)
            IRET= CHAR1(1:LL1).EQ.CHAR2(1:LL2)
          ENDIF
        ENDIF
      ELSE
        ITTEMP=' '
        CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
 360  CONTINUE
C  TEST SUR FLOTTANTS
      IRET=.FALSE.
      CALL LIRREE(X1,1,IRETOU)
      CALL LIRREE(X2,0,IRETOU)
      IF(IERR.NE.0) RETURN
      IF(IRETOU.EQ.1) THEN
        CALL LIRREE(EPS1,0,IRETO3)
        IF(IRETO3.EQ.1) THEN
*
*  MILL  9/1/91  TEST EN VALEUR ABSOLUE
*
          XVAL = ABS (X2 - X1)
          IRET= XVAL.LE.EPS1
        ELSE
           IRET= A_EGALE_B(X1,X2)
        ENDIF
      ELSE
        ITTEMP=' '
        CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GOTO  5000
      ENDIF
      GOTO 100
 
C  Sortie du resultat sur la pile
  100 CONTINUE
      CALL ECRLOG (IRET)
      RETURN
 
C  Sortie en erreur
 5000 CONTINUE
      CALL ERREUR(533)
      RETURN
      END