Télécharger masq.eso

Retour à la liste

Numérotation des lignes :

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

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