Télécharger excomp.eso

Retour à la liste

Numérotation des lignes :

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

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