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

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