Télécharger excomp.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCOMP SOURCE BP208322 17/04/18 21:15:02 9396
  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. CALL LIROBJ('LISTMOTS',LISM1,0,IRT1)
  32. IF(IRT1.EQ.0) THEN
  33. MOT2='SCAL'
  34. CALL LIRCHA(MOT,1,IRETOU)
  35. IF(IERR.NE.0) RETURN
  36. ELSE
  37. CALL LIROBJ('LISTMOTS',LISM2,0,IRL2)
  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. CALL LIRMOT(NOVE,1,NOID,0)
  52. C
  53. CALL LIROBJ('CHPOINT ',IPCH1,0,IRT2)
  54. IF(IRT2.EQ.0) GOTO 100
  55. C-----------------------------------------------
  56. C CAS D'UN CHPO
  57. C
  58. C on essaie de lire le nouveau nom et la nature (facultatif)
  59. CALL LIRCHA(MOT2,0,IRETOU)
  60. MCHPOI = IPCH1
  61. SEGACT MCHPOI
  62. JATT1 = JATTRI(1)+1
  63. IF (IRETOU .GE. 1) THEN
  64. IF (MOT2 .EQ. 'NATU' ) THEN
  65. C jatt va stocker la nature
  66. CALL LIRMOT(NATU,3,JATT1,1)
  67. IF(IERR.NE.0) RETURN
  68. MOT2=' '
  69. ELSE
  70. C mot2 est le nouveau nom de la composante
  71. C on essaie de lire la nature
  72. CALL LIRCHA(MOT3,0,IRETOU)
  73. IF (IRETOU .GE. 1) THEN
  74. IF (MOT3 .EQ. 'NATU' ) THEN
  75. CALL LIRMOT(NATU,3,JATT1,1)
  76. IF(IERR.NE.0) RETURN
  77. ELSE
  78. C natu n'est pas specifie on continue...
  79. CALL REFUS
  80. ENDIF
  81. ENDIF
  82. ENDIF
  83. ENDIF
  84. C
  85. IF (LISM1.EQ.0) THEN
  86. C
  87. C MOT SIMPLE
  88. C
  89. CALL EXCOPP(IPCH1,MOT,NIF1,IPCH2,MOT2,NIF2,NOID)
  90. IF(IERR.NE.0) RETURN
  91. ELSE
  92. C
  93. C LISTE DE MOTS
  94. C
  95. MLMOTS=LISM1
  96. SEGACT MLMOTS
  97. IF (LISM2.NE.0) THEN
  98. MLMOT2=LISM2
  99. SEGACT,MLMOT2
  100. IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
  101. CALL ERREUR(217)
  102. SEGDES MLMOTS,MLMOT2
  103. RETURN
  104. ENDIF
  105. ENDIF
  106. IPCH2=0
  107. DO 51 IM=1,MOTS(/2)
  108. MOT =MOTS(IM)(1:4)
  109. IF (LISM2.NE.0) THEN
  110. MOT2=MLMOT2.MOTS(IM)(1:4)
  111. ELSE
  112. MOT2=MOTS(IM)(1:4)
  113. ENDIF
  114. CALL EXCOPP(IPCH1,MOT,NIF1,IPCH3,MOT2,NIF2,NOID)
  115. IF(IERR.NE.0) THEN
  116. SEGDES MLMOTS
  117. IF (LISM2.NE.0) SEGDES MLMOT2
  118. IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)
  119. RETURN
  120. ENDIF
  121. IF(IPCH2.EQ.0) THEN
  122. IPCH2=IPCH3
  123. ELSE
  124. CALL ADCHPO(IPCH2,IPCH3,IPCH2,1D0,1D0)
  125. IF(IERR.NE.0) THEN
  126. IF(IPCH2.NE.0) CALL DTCHPO(IPCH2)
  127. CALL DTCHPO(IPCH3)
  128. SEGDES MLMOTS
  129. IF (LISM2.NE.0) SEGDES MLMOT2
  130. RETURN
  131. ENDIF
  132. ENDIF
  133. 51 CONTINUE
  134. SEGDES MLMOTS
  135. IF (LISM2.NE.0) SEGDES MLMOT2
  136. ENDIF
  137. C
  138. C On ajuste la nature du champ
  139. MCHPOI=IPCH2
  140. SEGACT MCHPOI*MOD
  141. mochde=' chpoint cree par EXCOMP'
  142. mtypoi='SCALAIRE'
  143. JATTRI(1)=JATT1-1
  144. SEGDES MCHPOI
  145. C
  146. CALL ECROBJ('CHPOINT ',IPCH2)
  147. RETURN
  148. C ---------------------------------------------
  149. C CAS D'UN MCHAML
  150. C
  151. 100 CONTINUE
  152. C
  153. CALL LIROBJ('MCHAML',ICHE1,0,IRT3)
  154. IF(IRT3.EQ.0) GO TO 300
  155. CALL LIRCHA(MOT2,0,IRETOU)
  156. IF(IRETOU.EQ.0) MOT2=MOT
  157. C
  158. IF (LISM1.EQ.0) THEN
  159. CALL EXCOC1(ICHE1,MOT,ICHE2,MOT2,NOID)
  160. IF(IERR.NE.0) RETURN
  161. ELSE
  162. MLMOTS=LISM1
  163. SEGACT MLMOTS
  164. IF (LISM2.NE.0) THEN
  165. MLMOT2=LISM2
  166. SEGACT,MLMOT2
  167. IF (MOTS(/2).NE.MLMOT2.MOTS(/2)) THEN
  168. CALL ERREUR(217)
  169. SEGDES MLMOTS,MLMOT2
  170. RETURN
  171. ENDIF
  172. ENDIF
  173. ICHE2=0
  174. DO 201 IM=1,MOTS(/2)
  175. MOT =MOTS(IM)(1:4)
  176. IF (LISM2.NE.0) THEN
  177. MOT2=MLMOT2.MOTS(IM)(1:4)
  178. ELSE
  179. MOT2=MOTS(IM)(1:4)
  180. ENDIF
  181. * write(6,*) 'MOT MOT2 ' , MOT , MOT2 ,NOID
  182. CALL EXCOC1(ICHE1,MOT,ICHE3,MOT2,NOID)
  183. IF(IERR.NE.0) THEN
  184. SEGDES MLMOTS
  185. IF (LISM2.NE.0) SEGDES MLMOT2
  186. IF(ICHE2.NE.0) CALL DTCHAM(ICHE2)
  187. RETURN
  188. ENDIF
  189. IF(ICHE2.EQ.0) THEN
  190. ICHE2=ICHE3
  191. ELSE
  192. CALL FUSCHL(ICHE2,ICHE3,ICHE4)
  193. IF(IERR.NE.0) THEN
  194. * call zpchel (iche2,1)
  195. * call zpchel(iche3,1)
  196. CALL DTCHAM(ICHE2)
  197. CALL DTCHAM(ICHE3)
  198. SEGDES MLMOTS
  199. IF (LISM2.NE.0) SEGDES MLMOT2
  200. RETURN
  201. ENDIF
  202. ICHE2=ICHE4
  203. ENDIF
  204. 201 CONTINUE
  205. SEGDES MLMOTS
  206. IF (LISM2.NE.0) SEGDES MLMOT2
  207. ENDIF
  208. CALL ECROBJ('MCHAML',ICHE2)
  209. RETURN
  210. C
  211. C PAS D OPERANDE CORRECTE TROUVE
  212. C
  213. 300 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  214. IF(IRETOU.NE.0) THEN
  215. CALL ERREUR (39)
  216. ELSE
  217. CALL ERREUR(533)
  218. ENDIF
  219. RETURN
  220. END
  221.  
  222.  
  223.  
  224.  

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