Télécharger ega.eso

Retour à la liste

ega
C EGA       SOURCE    FANDEUR   22/06/02    21:15:04     11372          
      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   ') GO TO 300
      IF(ITTEMP.EQ.'LOGIQUE ') GO TO 310
      IF(ITTEMP.EQ.'LISTENTI') GO TO 330
      IF(ITTEMP.EQ.'ENTIER  ') GO TO 340
      IF(ITTEMP.EQ.'MOT     ') GO TO 350
      IF(ITTEMP.EQ.'FLOTTANT') GO TO 360
* comparaison bête des 2 objets
      iret=.true.
      ittemp=' '
      ittem2=' '
      call lirobj(ittemp,iv1,1,iretou)
      call lirobj(ittem2,iv2,1,iretou)
      if (ierr.ne.0) return
      if (ittemp.ne.ittem2) iret=.false.
      if (iv1.ne.iv2) iret=.false.
      GO  TO 100
  300 CONTINUE
      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) GO TO 221
        DO I=1,NCA1
          IF (MTEXT(I:I).NE.MTEXT1.MTEXT(I:I)) GO TO 221
        ENDDO
        IRET=.TRUE.
 221    SEGDES MTEXTE,MTEXT1
      ELSE
        INTEXT=0
        ITTEMP=' '
        CALL LIROBJ(ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GO TO  5000
      ENDIF
      GO TO 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) GO TO  5000
      ENDIF
      GO TO 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)) GO TO 102
        DO I=1,LECT(/1)
          IF(LECT(I).NE.MLENT1.LECT(I)) GO TO 102
        ENDDO
        IRET=.TRUE.
  102   CONTINUE
        SEGDES MLENTI,MLENT1
      ELSE
        ITTEMP=' '
        CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
        IF(IRETOU.EQ.0) GO TO  5000
      ENDIF
      GO TO 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) GO TO  5000
      ENDIF
      GO TO 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) GO TO  5000
      ENDIF
      GO TO 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 = 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) GO TO  5000
      ENDIF
      GO TO 100
  100 CONTINUE
      CALL ECRLOG (IRET)
      RETURN
 5000 CONTINUE
      CALL ERREUR(533)
      RETURN
      END
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales