Télécharger masq.eso

Retour à la liste

Numérotation des lignes :

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

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