Télécharger masq.eso

Retour à la liste

Numérotation des lignes :

  1. C MASQ SOURCE BP208322 17/08/08 21:15:04 9526
  2. SUBROUTINE MASQ
  3. ************************************************************************
  4. * *
  5. * OPERATEUR MASQUE *
  6. * *
  7. ************************************************************************
  8. *
  9. IMPLICIT INTEGER(I-N)
  10. IMPLICIT REAL*8(A-H,O-Z)
  11. *
  12. -INC CCOPTIO
  13. *
  14. PARAMETER (LMOT=8,LSOM=1,LTYP=4)
  15. CHARACTER*4 MMOT(LMOT),MSOM(LSOM),MOT1
  16. CHARACTER*8 MTYP(LTYP)
  17. CHARACTER*8 LETYP,CHA8
  18. *
  19. DATA MMOT/'SUPE','EGSU','EGAL','EGIN','INFE','DIFF','COMP','EXIS'/
  20. DATA MSOM/'SOMM'/
  21. DATA MTYP/'MCHAML','CHPOINT','LISTREEL','LISTENTI'/
  22. *
  23. *
  24. * ============================
  25. * LECTURE DES DONNEES D'ENTREE
  26. * ============================
  27. *
  28. * LECTURE OBLIGATOIRE DU MOT-CLE PRINCIPAL
  29. CALL LIRMOT(MMOT,LMOT,ICLE,1)
  30. IF (IERR.NE.0) RETURN
  31. *
  32. * LECTURE FACULTATIVE DU MOT-CLE "SOMM"
  33. ISOM=0
  34. CALL LIRMOT(MSOM,LSOM,ISOM,0)
  35. IF (IERR.NE.0) RETURN
  36. *
  37. * LECTURE DE L'OBJET PRINCIPAL
  38. CALL QUETYP(LETYP,1,IRET)
  39. IF (IERR.NE.0) RETURN
  40. CALL PLACE(MTYP,LTYP,ITYP,LETYP)
  41. IF (ITYP.EQ.0) THEN
  42. MOTERR(1:8)=LETYP
  43. CALL ERREUR(39)
  44. RETURN
  45. ENDIF
  46. CALL LIROBJ(LETYP,IOB,1,IRETOU)
  47. IF (IERR.NE.0) RETURN
  48. *
  49. * LECTURE DU CRITERE DU MASQUE
  50. IRET1=0
  51. MOT1='TOUS'
  52. * cas du test d'existence ('EXIS') : on veut un nom de composante
  53. IF(ICLE.EQ.8) THEN
  54. ISOM=0
  55. CALL LIRCHA(MOT1,0,IRETOU)
  56. IF(IERR.NE.0) RETURN
  57. IF(IRETOU.EQ.0) MOT1='TOUS'
  58. IRET1=1
  59. GOTO 1
  60. ENDIF
  61. * cas des tests de relation algebrique ('SUPE' ...) :
  62. CALL QUETYP(CHA8,1,IRETOU)
  63. IF (CHA8.EQ.'ENTIER') THEN
  64. CALL LIRENT(I1,1,IRET1)
  65. IF (IERR.NE.0) RETURN
  66. X1=I1
  67. ELSEIF (CHA8.EQ.'FLOTTANT'.AND.ITYP.NE.4) THEN
  68. CALL LIRREE(X1,1,IRET1)
  69. IF (IERR.NE.0) RETURN
  70. ELSEIF (CHA8.EQ.LETYP) THEN
  71. CALL LIROBJ(LETYP,IOB1,1,IRETOU)
  72. IF (IERR.NE.0) RETURN
  73. ELSE
  74. MOTERR(1:8)=CHA8
  75. CALL ERREUR(39)
  76. RETURN
  77. ENDIF
  78.  
  79. * LECTURE D'UN DEUXIEME CRITERE POUR LE MOT-CLE "COMPRIS"
  80. IRET2=0
  81. IF (ICLE.EQ.7) THEN
  82. CALL QUETYP(CHA8,1,IRETOU)
  83. IF (CHA8.EQ.'ENTIER') THEN
  84. CALL LIRENT(I2,1,IRET2)
  85. IF (IERR.NE.0) RETURN
  86. X2=I2
  87. ELSEIF (CHA8.EQ.'FLOTTANT'.AND.ITYP.NE.4) THEN
  88. CALL LIRREE(X2,1,IRET2)
  89. IF (IERR.NE.0) RETURN
  90. ELSEIF (CHA8.EQ.LETYP) THEN
  91. CALL LIROBJ(LETYP,IOB2,1,IRETOU)
  92. IF (IERR.NE.0) RETURN
  93. ELSE
  94. MOTERR(1:8)=CHA8
  95. CALL ERREUR(39)
  96. RETURN
  97. ENDIF
  98. ENDIF
  99.  
  100. * ==================
  101. * CREATION DU MASQUE
  102. * ==================
  103.  
  104. 1 CONTINUE
  105. GOTO(100,200,300,300) ITYP
  106. *
  107. * CAS D'UN OBJET MCHAML
  108. 100 CONTINUE
  109. IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
  110. CALL MASCHE(X1,X2,IOB,MOT1,ICLE,IRET,ISOM,IRETER)
  111. ELSEIF (IRET1.NE.0) THEN
  112. CALL MSCHE1(IOB2,0,X1,1,IOB,ICLE,IRET,ISOM,IRETER)
  113. ELSE
  114. CALL MSCHE1(IOB1,IOB2,X2,-IRET2,IOB,ICLE,IRET,ISOM,IRETER)
  115. ENDIF
  116. IF (IRETER.EQ.0.OR.IERR.NE.0) RETURN
  117. GOTO 1000
  118. *
  119. * CAS D'UN OBJET CHPOINT
  120. 200 CONTINUE
  121. IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
  122. CALL MASCHP(X1,X2,IOB,ICLE,IRET,ISOM)
  123. ELSEIF (IRET1.NE.0) THEN
  124. CALL MSCHP1(IOB2,0,X1,1,IOB,ICLE,IRET,ISOM)
  125. ELSE
  126. CALL MSCHP1(IOB1,IOB2,X2,-IRET2,IOB,ICLE,IRET,ISOM)
  127. ENDIF
  128. IF (IERR.NE.0) RETURN
  129. GOTO 1000
  130. *
  131. * CAS D'UN OBJET LISTENTI OU LISTREEL
  132. 300 CONTINUE
  133. IF (IRET1.NE.0.AND.(ICLE.NE.7.OR.IRET2.NE.0)) THEN
  134. CALL MASLIS(LETYP,IOB,ICLE,X1,I1,X2,I2,IRET,ISOM)
  135. ELSEIF (IRET1.NE.0) THEN
  136. CALL MSLIS1(LETYP,IOB,ICLE,IOB2,0,X1,I1,1,IRET,ISOM)
  137. ELSE
  138. CALL MSLIS1(LETYP,IOB,ICLE,IOB1,IOB2,X2,I2,-IRET2,IRET,ISOM)
  139. ENDIF
  140. IF (IERR.NE.0) RETURN
  141.  
  142.  
  143. * ====================
  144. * FIN DE LA SUBROUTINE
  145. * ====================
  146.  
  147. 1000 CONTINUE
  148. IF (ISOM.NE.0) THEN
  149. CALL ECRENT(IRET)
  150. ELSE
  151. CALL ECROBJ(LETYP,IRET)
  152. ENDIF
  153.  
  154.  
  155. RETURN
  156. END
  157.  
  158.  
  159.  
  160.  
  161.  

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