Télécharger ega.eso

Retour à la liste

Numérotation des lignes :

  1. C EGA SOURCE GOUNAND 14/09/16 21:15:07 8152
  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. CALL QUETYP(ITTEMP,0,IRETOU)
  17. MOTERR(1:8)=ITTEMP
  18. IF(IRETOU.EQ.0) THEN
  19. CALL ERREUR( 533)
  20. RETURN
  21. ENDIF
  22. IF(ITTEMP.EQ.'TEXTE ') GO TO 300
  23. IF(ITTEMP.EQ.'LOGIQUE ') GO TO 310
  24. IF(ITTEMP.EQ.'POINT ') GO TO 320
  25. IF(ITTEMP.EQ.'LISTENTI') GO TO 330
  26. IF(ITTEMP.EQ.'ENTIER ') GO TO 340
  27. IF(ITTEMP.EQ.'MOT ') GO TO 350
  28. IF(ITTEMP.EQ.'FLOTTANT') GO TO 360
  29. * comparaison bête des 2 objets
  30. iret=.true.
  31. ittemp=' '
  32. ittem2=' '
  33. call lirobj(ittemp,iv1,1,iretou)
  34. call lirobj(ittem2,iv2,1,iretou)
  35. if (ierr.ne.0) return
  36. if (ittemp.ne.ittem2) iret=.false.
  37. if (iv1.ne.iv2) iret=.false.
  38. GO TO 100
  39. 300 CONTINUE
  40. CALL LIROBJ(ITTEMP,ITEX1,0,IRETOU)
  41. CALL LIROBJ(ITTEMP,ITEX2,0,IRETOU)
  42. IF(IRETOU.EQ.1) THEN
  43. IRET=.FALSE.
  44. MTEXTE=ITEX1
  45. MTEXT1=ITEX2
  46. SEGACT MTEXTE,MTEXT1
  47. NCA1=NCART
  48. NCA2=MTEXT1.NCART
  49. IF(NCA1.NE.NCA2) GO TO 221
  50. DO 222 I=1,NCA1
  51. IF(MTEXT(I:I).NE.MTEXT1.MTEXT(I:I)) GO TO 221
  52. 222 CONTINUE
  53. IRET=.TRUE.
  54. 221 SEGDES MTEXTE,MTEXT1
  55. ELSE
  56. ITTEMP=' '
  57. CALL LIROBJ(ITTEMP,KIKI,0,IRETOU)
  58. IF(IRETOU.EQ.0) GO TO 5000
  59. IRET=.FALSE.
  60. ENDIF
  61. GO TO 100
  62. 310 CONTINUE
  63. C TEST SUR BOOLEENS
  64. CALL LIRLOG(BOOL,1,IRETOU)
  65. CALL LIRLOG(BOOL1,0,IRETOU)
  66. IF(IRETOU.EQ.1) THEN
  67. IRET= BOOL.EQV.BOOL1
  68. ELSE
  69. ITTEMP=' '
  70. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  71. IF(IRETOU.EQ.0) GO TO 5000
  72. IRET=.FALSE.
  73. ENDIF
  74. GO TO 100
  75. 320 CONTINUE
  76. C TEST SUR POINTS
  77. CALL LIROBJ(ITTEMP,IP1,1,IRETOU)
  78. CALL LIROBJ(ITTEMP,IP2,0,IRETO2)
  79. CALL LIRREE(EPS1,0,IRETOU)
  80. IF (IRETOU .EQ. 0) EPS1 = -1.
  81. IF (IRETO2.EQ.1) THEN
  82. IRET = EGA1 (IP1,IP2,EPS1)
  83. ELSE
  84. ITTEMP=' '
  85. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  86. IF(IRETOU.EQ.0) GO TO 5000
  87. IRET=.FALSE.
  88. ENDIF
  89. GO TO 100
  90. 330 CONTINUE
  91. C TEST SUR LISTENTI
  92. CALL LIROBJ(ITTEMP,MLENTI,1,IRETOU)
  93. CALL LIROBJ(ITTEMP,MLENT1,0,IRETOU)
  94. IF(IRETOU.EQ.1) THEN
  95. SEGACT MLENTI,MLENT1
  96. IRET=.FALSE.
  97. IF(LECT(/1).NE.MLENT1.LECT(/1)) GO TO 102
  98. DO 101 I=1,LECT(/1)
  99. IF(LECT(I).NE.MLENT1.LECT(I)) GO TO 102
  100. 101 CONTINUE
  101. IRET=.TRUE.
  102. 102 CONTINUE
  103. SEGDES MLENTI,MLENT1
  104. ELSE
  105. ITTEMP=' '
  106. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  107. IF(IRETOU.EQ.0) GO TO 5000
  108. IRET=.FALSE.
  109. ENDIF
  110. GO TO 100
  111. 340 CONTINUE
  112. C TEST SUR ENTIERS
  113. CALL LIRENT(I1,1,IRETOU)
  114. CALL LIRENT(I2,0,IRETOU)
  115. IF(IRETOU.EQ.1) THEN
  116. IRET=.FALSE.
  117. IF(I1.EQ.I2) IRET=.TRUE.
  118. ELSE
  119. ITTEMP=' '
  120. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  121. IF(IRETOU.EQ.0) GO TO 5000
  122. IRET=.FALSE.
  123. ENDIF
  124. GO TO 100
  125. 360 CONTINUE
  126. C TEST SUR FLOTTANTS
  127. IRET=.FALSE.
  128. CALL LIRREE(X1,1,IRETOU)
  129. CALL LIRREE(X2,0,IRETOU)
  130. IF(IRETOU.EQ.1) THEN
  131. CALL LIRREE(EPS1,0,IRETO3)
  132. IF(IRETO3.EQ.1) THEN
  133. *
  134. * MILL 9/1/91 TEST EN VALEUR ABSOLUE
  135. *
  136. XVAL = ABS (X2 - X1)
  137. IF (XVAL.LE.EPS1) IRET=.TRUE.
  138. ELSE
  139. IF(X1.EQ.X2) IRET=.TRUE.
  140. ENDIF
  141. ELSE
  142. ITTEMP=' '
  143. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  144. IF(IRETOU.EQ.0) GO TO 5000
  145. ENDIF
  146. GO TO 100
  147. 350 CONTINUE
  148. C TEST SUR MOT
  149. CALL LIRCHA(CHAR1,1,IRET1)
  150. CALL LIRCHA(CHAR2,0,IRET2)
  151. IRET=.FALSE.
  152. IF(IRET2.NE.0) THEN
  153. IF( CHAR1.EQ.CHAR2) THEN
  154. IRET=.TRUE.
  155. ELSE
  156. LL1=LONG(CHAR1)
  157. LL2=LONG(CHAR2)
  158. IF(CHAR1(1:LL1).EQ.CHAR2(1:LL2)) IRET=.TRUE.
  159. ENDIF
  160. ELSE
  161. ITTEMP=' '
  162. CALL LIROBJ( ITTEMP,KIKI,0,IRETOU)
  163. IF(IRETOU.EQ.0) GO TO 5000
  164. ENDIF
  165. GO TO 100
  166. 100 CONTINUE
  167. CALL ECRLOG (IRET)
  168. RETURN
  169. 5000 CONTINUE
  170. CALL ERREUR(533)
  171. RETURN
  172. END
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  

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