Télécharger excomp.eso

Retour à la liste

Numérotation des lignes :

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

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