1 : C EGA SOURCE CHAT 05/01/12 23:28:36 5004 2 : SUBROUTINE EGA 3 : IMPLICIT INTEGER(I-N) 4 : -INC CCOPTIO 5 : -INC SMLENTI 6 : -INC SMTEXTE 7 : EXTERNAL LONG 8 : CHARACTER*(8) ITTEMP,ITTEM2 9 : CHARACTER*72 CHAR1,CHAR2 10 : LOGICAL IRET,EGA1,BOOL,BOOL1 11 : INTEGER I1,I2 12 : REAL*8 EPS1,X1,X2,XVAL 13 : C 14 : C TEST SUR LES TEXTES 15 : C 16 : INTEXT=1 16 : CALL QUETYP(ITTEMP,0,IRETOU) 17 : MOTERR(1:8)=ITTEMP 18 : IF(IRETOU.EQ.0) THEN 18 : CALL ERREUR( 533) 19 : RETURN 20 : ENDIF 21 : IF(ITTEMP.EQ.'TEXTE ') GO TO 300 22 : IF(ITTEMP.EQ.'LOGIQUE ') GO TO 310 23 : IF(ITTEMP.EQ.'POINT ') GO TO 320 24 : IF(ITTEMP.EQ.'LISTENTI') GO TO 330 25 : IF(ITTEMP.EQ.'ENTIER ') GO TO 340 26 : IF(ITTEMP.EQ.'MOT ') GO TO 350 27 : IF(ITTEMP.EQ.'FLOTTANT') GO TO 360 28 : * comparaison bête des 2 objets 29 : iret=.true. 30 : ittemp=' ' 31 : ittem2=' ' 31 : call lirobj(ittemp,iv1,1,iretou) 31 : call lirobj(ittem2,iv2,1,iretou) 32 : if (ierr.ne.0) return 33 : if (ittemp.ne.ittem2) iret=.false. 34 : if (iv1.ne.iv2) iret=.false. 35 : GO TO 100 36 : 300 CONTINUE 37 : INTEXT=1 37 : CALL LIROBJ(ITTEMP,ITEX1,0,IRETOU) 38 : INTEXT=1 38 : CALL LIROBJ(ITTEMP,ITEX2,0,IRETOU) 39 : IF(IRETOU.EQ.1) THEN 40 : IRET=.FALSE. 41 : MTEXTE=ITEX1 42 : MTEXT1=ITEX2 43 : SEGACT MTEXTE,MTEXT1 44 : NCA1=NCART 45 : NCA2=MTEXT1.NCART 46 : IF(NCA1.NE.NCA2) GO TO 221 47 : DO 222 I=1,NCA1 48 : IF(MTEXT(I:I).NE.MTEXT1.MTEXT(I:I)) GO TO 221 49 : 222 CONTINUE 50 : IRET=.TRUE. 51 : 221 SEGDES MTEXTE,MTEXT1 52 : ELSE 53 : INTEXT=0 54 : ITTEMP=' ' 54 : CALL LIROBJ(ITTEMP,KIKI,0,IRETOU) 55 : IF(IRETOU.EQ.0) GO TO 5000 56 : IRET=.FALSE. 57 : ENDIF 58 : GO TO 100 59 : 310 CONTINUE 60 : INTEXT=0 61 : C TEST SUR BOOLEENS 61 : CALL LIRLOG(BOOL,1,IRETOU) 61 : CALL LIRLOG(BOOL1,0,IRETOU) 62 : IF(IRETOU.EQ.1) THEN 63 : IRET= BOOL.EQV.BOOL1 64 : ELSE 65 : ITTEMP=' ' 65 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 66 : IF(IRETOU.EQ.0) GO TO 5000 67 : IRET=.FALSE. 68 : ENDIF 69 : GO TO 100 70 : 320 CONTINUE 71 : C TEST SUR POINTS 71 : CALL LIROBJ(ITTEMP,IP1,1,IRETOU) 71 : CALL LIROBJ(ITTEMP,IP2,0,IRETO2) 71 : CALL LIRREE(EPS1,0,IRETOU) 72 : IF (IRETOU .EQ. 0) EPS1 = -1. 73 : IF (IRETO2.EQ.1) THEN 74 : IRET = EGA1 (IP1,IP2,EPS1) 75 : ELSE 76 : ITTEMP=' ' 76 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 77 : IF(IRETOU.EQ.0) GO TO 5000 78 : IRET=.FALSE. 79 : ENDIF 80 : GO TO 100 81 : 330 CONTINUE 82 : C TEST SUR LISTENTI 82 : CALL LIROBJ(ITTEMP,MLENTI,1,IRETOU) 82 : CALL LIROBJ(ITTEMP,MLENT1,0,IRETOU) 83 : IF(IRETOU.EQ.1) THEN 84 : SEGACT MLENTI,MLENT1 85 : IRET=.FALSE. 86 : IF(LECT(/1).NE.MLENT1.LECT(/1)) GO TO 102 87 : DO 101 I=1,LECT(/1) 88 : IF(LECT(I).NE.MLENT1.LECT(I)) GO TO 102 89 : 101 CONTINUE 90 : IRET=.TRUE. 91 : 102 CONTINUE 92 : SEGDES MLENTI,MLENT1 93 : ELSE 94 : ITTEMP=' ' 94 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 95 : IF(IRETOU.EQ.0) GO TO 5000 96 : IRET=.FALSE. 97 : ENDIF 98 : GO TO 100 99 : 340 CONTINUE 100 : C TEST SUR ENTIERS 100 : CALL LIRENT(I1,1,IRETOU) 100 : CALL LIRENT(I2,0,IRETOU) 101 : IF(IRETOU.EQ.1) THEN 102 : IRET=.FALSE. 103 : IF(I1.EQ.I2) IRET=.TRUE. 104 : ELSE 105 : ITTEMP=' ' 105 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 106 : IF(IRETOU.EQ.0) GO TO 5000 107 : IRET=.FALSE. 108 : ENDIF 109 : GO TO 100 110 : 360 CONTINUE 111 : C TEST SUR FLOTTANTS 112 : IRET=.FALSE. 112 : CALL LIRREE(X1,1,IRETOU) 112 : CALL LIRREE(X2,0,IRETOU) 113 : IF(IRETOU.EQ.1) THEN 113 : CALL LIRREE(EPS1,0,IRETO3) 114 : IF(IRETO3.EQ.1) THEN 115 : * 116 : * MILL 9/1/91 TEST EN VALEUR ABSOLUE 117 : * 118 : XVAL = ABS (X2 - X1) 119 : IF (XVAL.LE.EPS1) IRET=.TRUE. 120 : ELSE 121 : IF(X1.EQ.X2) IRET=.TRUE. 122 : ENDIF 123 : ELSE 124 : ITTEMP=' ' 124 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 125 : IF(IRETOU.EQ.0) GO TO 5000 126 : ENDIF 127 : GO TO 100 128 : 350 CONTINUE 129 : C TEST SUR MOT 129 : CALL LIRCHA(CHAR1,1,IRET1) 129 : CALL LIRCHA(CHAR2,0,IRET2) 130 : IRET=.FALSE. 131 : IF(IRET2.NE.0) THEN 132 : IF( CHAR1.EQ.CHAR2) THEN 133 : IRET=.TRUE. 134 : ELSE 135 : LL1=LONG(CHAR1) 136 : LL2=LONG(CHAR2) 137 : IF(CHAR1(1:LL1).EQ.CHAR2(1:LL2)) IRET=.TRUE. 138 : ENDIF 139 : ELSE 140 : ITTEMP=' ' 140 : CALL LIROBJ( ITTEMP,KIKI,0,IRETOU) 141 : IF(IRETOU.EQ.0) GO TO 5000 142 : ENDIF 143 : GO TO 100 144 : 100 CONTINUE 144 : CALL ECRLOG (IRET) 145 : RETURN 146 : 5000 CONTINUE 146 : CALL ERREUR(533) 147 : RETURN 148 : END 149 : 150 : 151 : 152 :
© Cast3M 2003 - All rights reserved.
Disclaimer