Télécharger excomp.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCOMP SOURCE CB215821 20/03/02 21:15:12 10540
  2. SUBROUTINE EXCOMP
  3. C=======================================================================
  4. C
  5. C OPERATEUR EXTRACTION D UNE COMPOSANTE D UN CHPOINT
  6. C D UN MCHAML
  7. C DE QUELQUES COMPOSANTES D UN MCHAML
  8. C
  9. C CH2 = EXCO | MOT1 (MOT2) | (n1) (n2) ('NOID') CH1 ...
  10. C | LISM1 (LISM2) |
  11. C
  12. C ... ('NATURE' |'INDETER'| ) ;
  13. C |'DIFFUS' |
  14. C |'DISCRET'|
  15. C
  16. C=======================================================================
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8(A-H,O-Z)
  19. -INC CCOPTIO
  20. -INC SMLMOTS
  21. -INC SMCHPOI
  22. -INC SMCHAML
  23. CHARACTER*4 NOVE(1),NATU(3),MOT,MOT2,MOT3
  24. DATA NOVE/'NOID'/
  25. DATA NATU/'INDE','DIFF','DISC'/
  26. C
  27. C LISTE DE MOT OU MOT SIMPLE
  28. C
  29. MOT=' '
  30. LISM1=0
  31. LISM2=0
  32. C Syntaxe 2 : on tente de lire un LISTMOTS
  33. CALL LIROBJ('LISTMOTS',LISM1,0,IRT1)
  34. C Syntaxe 1 : si abscence de LISTMOTS, on lit un simple MOT
  35. IF(IRT1.EQ.0) THEN
  36. MOT2='SCAL'
  37. CALL LIRCHA(MOT,1,IRETOU)
  38. IF(IERR.NE.0) RETURN
  39. ENDIF
  40. C
  41. Cbp : Lecture eventuelle de l'harmonique de Fourier en entre /sortie
  42. CALL LIRENT(NIF1,0,IRET1)
  43. IF(IRET1.NE.0) THEN
  44. CALL LIRENT(NIF2,0,IRET2)
  45. IF(IRET2.EQ.0) NIF2=NIFOUR
  46. ELSE
  47. NIF1=NIFOUR
  48. NIF2=NIFOUR
  49. ENDIF
  50. IF(IERR.NE.0) RETURN
  51. C
  52. C Lecture de l'option 'NOID'
  53. CALL LIRMOT(NOVE,1,NOID,0)
  54. C
  55. C Pour la syntaxe 2, on tente la lecture d'un second LISTMLOTS
  56. IF(IRT1.NE.0) THEN
  57. CALL LIROBJ('LISTMOTS',LISM2,0,IRL2)
  58. ENDIF
  59. C
  60. C
  61. C-----------------------------------------------
  62. C CAS D'UN OBJET CHPOINT
  63. C-----------------------------------------------
  64. CALL LIROBJ('CHPOINT ',IPCH1,0,IRT2)
  65. IF(IRT2.EQ.0) GOTO 100
  66. CALL ACTOBJ('CHPOINT ',IPCH1,1)
  67. C On essaie de lire le nouveau nom et la nature (facultatif)
  68. CALL LIRCHA(MOT2,0,IRETOU)
  69. MCHPOI = IPCH1
  70. SEGACT MCHPOI
  71. JATT1 = JATTRI(1)+1
  72. IF (IRETOU .GE. 1) THEN
  73. IF (MOT2 .EQ. 'NATU' ) THEN
  74. C jatt va stocker la nature
  75. CALL LIRMOT(NATU,3,JATT1,1)
  76. IF(IERR.NE.0) RETURN
  77. MOT2='SCAL'
  78. ELSE
  79. C MOT2 est le nouveau nom de la composante
  80. C on essaie a nouveau de lire la nature
  81. CALL LIRCHA(MOT3,0,IRETOU)
  82. IF (IRETOU .GE. 1) THEN
  83. IF (MOT3 .EQ. 'NATU' ) THEN
  84. CALL LIRMOT(NATU,3,JATT1,1)
  85. IF(IERR.NE.0) RETURN
  86. ELSE
  87. C 'NATU' n'est pas specifie on continue...
  88. CALL REFUS
  89. ENDIF
  90. ENDIF
  91. ENDIF
  92. ENDIF
  93. C Syntaxe 1 (avec des MOTs simples)
  94. IF (LISM1.EQ.0) THEN
  95. CALL EXCOPP(IPCH1,MOT,NIF1,IPCH2,MOT2,NIF2,NOID)
  96. IF(IERR.NE.0) RETURN
  97. C Syntaxe 2 (avec des LISTMOTS)
  98. ELSE
  99. MLMOTS=LISM1
  100. SEGACT MLMOTS
  101. C Erreur si les deux LISTMOTS ne sont pas de meme dimension
  102. IF (LISM2.NE.0) THEN
  103. MLMOT2=LISM2
  104. SEGACT,MLMOT2
  105. IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
  106. CALL ERREUR(217)
  107. RETURN
  108. ENDIF
  109. ENDIF
  110. IPCH2=0
  111. C Erreur si le premier LISTMOTS est vide
  112. IF (MOTS(/2).EQ.0) THEN
  113. NAT =1
  114. NSOUPO=0
  115. SEGINI,MCHPOI
  116. IPCH2=MCHPOI
  117.  
  118. C On place un soucis avec le numero de l'erreur qu'on pourrait emettre
  119. MOTERR(1:8)='LISTMOTS'
  120. INTERR(1)=MLMOTS
  121. CALL SOUCIS(356)
  122.  
  123. ELSE
  124. C On fait le job en bouclant sur les mots
  125. DO IM=1,MOTS(/2)
  126. MOT =MOTS(IM)(1:4)
  127. IF (LISM2.NE.0) THEN
  128. MOT2=MLMOT2.MOTS(IM)(1:4)
  129. ELSE
  130. MOT2=MOTS(IM)(1:4)
  131. ENDIF
  132. CALL EXCOPP(IPCH1,MOT,NIF1,IPCH3,MOT2,NIF2,NOID)
  133. IF(IERR.NE.0) RETURN
  134.  
  135. IF(IPCH2.EQ.0) THEN
  136. IPCH2=IPCH3
  137. ELSE
  138. CALL ADCHPO(IPCH2,IPCH3,IPCH2,1D0,1D0)
  139. IF(IERR.NE.0) RETURN
  140. ENDIF
  141. ENDDO
  142. ENDIF
  143. ENDIF
  144. C On ajuste la nature du champ
  145. MCHPOI=IPCH2
  146. C SEGACT MCHPOI*MOD
  147. mochde=' chpoint cree par EXCOMP'
  148. mtypoi='SCALAIRE'
  149. JATTRI(1)=JATT1-1
  150.  
  151. C On ecrit le CHPOINT resultat dans la pile
  152. CALL ACTOBJ('CHPOINT ',IPCH2,1)
  153. CALL ECROBJ('CHPOINT ',IPCH2)
  154. RETURN
  155.  
  156.  
  157. C ---------------------------------------------
  158. C CAS D'UN OBJET MCHAML
  159. C ---------------------------------------------
  160. 100 CONTINUE
  161. CALL LIROBJ('MCHAML ',ICHE1,0,IRT3)
  162. IF(IRT3.EQ.0) GO TO 300
  163. CALL ACTOBJ('MCHAML ',ICHE1,1)
  164. CALL LIRCHA(MOT2,0,IRETOU)
  165. IF(IRETOU.EQ.0) MOT2=MOT
  166. C Syntaxe 1 (avec des MOTs simples)
  167. IF (LISM1.EQ.0) THEN
  168. CALL EXCOC1(ICHE1,MOT,ICHE2,MOT2,NOID)
  169. IF(IERR.NE.0) RETURN
  170. C Syntaxe 2 (avec des LISTMOTS)
  171. ELSE
  172. MLMOTS=LISM1
  173. SEGACT MLMOTS
  174.  
  175. C Erreur si les deux LISTMOTS ne sont pas de meme dimension
  176. IF (LISM2.NE.0) THEN
  177. MLMOT2=LISM2
  178. SEGACT,MLMOT2
  179. IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
  180. CALL ERREUR(217)
  181. RETURN
  182. ENDIF
  183.  
  184. ELSE
  185. MLMOT2 = MLMOTS
  186. ENDIF
  187.  
  188. C Si le premier LISTMOTS est vide
  189. IF (MOTS(/2).EQ.0) THEN
  190. N1=0
  191. N3=0
  192. L1=8
  193.  
  194. SEGINI,MCHELM
  195. ICHE2 =MCHELM
  196. IFOCHE=IFOMOD
  197. TITCHE=' '
  198.  
  199. C On place un soucis avec le numero de l'erreur qu'on pourrait emettre
  200. MOTERR(1:8)='LISTMOTS'
  201. INTERR(1)=MLMOTS
  202. CALL SOUCIS(356)
  203.  
  204. ELSE
  205. CALL EXCOC2(ICHE1,MLMOTS,ICHE2,MLMOT2,NOID)
  206. ENDIF
  207. ENDIF
  208.  
  209. C On ecrit le MCHAML resultat dans la pile
  210. CALL ACTOBJ('MCHAML ',ICHE2,1)
  211. CALL ECROBJ('MCHAML ',ICHE2)
  212. RETURN
  213. C
  214. C PAS D OPERANDE CORRECTE TROUVE
  215. C
  216. 300 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  217. IF(IRETOU.NE.0) THEN
  218. CALL ERREUR (39)
  219. ELSE
  220. CALL ERREUR(533)
  221. ENDIF
  222. END
  223.  
  224.  

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