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