Télécharger kcham1.eso

Retour à la liste

Numérotation des lignes :

  1. C KCHAM1 SOURCE BP208322 16/11/18 21:18:01 9177
  2. SUBROUTINE KCHAM1(IPMODL,IPCHPO,IPCHEL)
  3. C____________________________________________________________________*
  4. C *
  5. C transformation de chpoint en mchaml *
  6. C *
  7. C entr{es: *
  8. C ________ *
  9. C *
  10. C ipmodl pointeur sur un mmodel *
  11. C ipchpo pointeur sur le chpoint *
  12. C *
  13. C sorties: *
  14. C ________ *
  15. C *
  16. C ipchel pointeur sur le mchaml resultat *
  17. C____________________________________________________________________*
  18. C *
  19. IMPLICIT REAL*8 (A-H,O-Z)
  20. C
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC CCGEOME
  25. -INC SMCHAML
  26. -INC SMCHPOI
  27. -INC SMMODEL
  28. -INC SMELEME
  29. -INC SMLENTI
  30. C
  31. C
  32. SEGMENT INFO
  33. INTEGER INFELL(JG)
  34. ENDSEGMENT
  35. C
  36. C PARAMETER (NSPG = 9)
  37. PARAMETER (NSPG = 5)
  38. CHARACTER*8 LSPG(NSPG)
  39. CHARACTER*(NCONCH) CONM
  40. CHARACTER*8 SOUTYP,TYPSPG
  41. C
  42. C l'ordre des SPG correspond à l'ordre du KPOIND
  43. C LSPG(1)='NOEUD' -> SOMMET
  44. C LSPG(2)='GRAVITE' -> CENTRE
  45. C LSPG(3)='RIGIDITE'
  46. C LSPG(4)='MASSE'
  47. C LSPG(5)='STRESSES'
  48. C LSPG(6)='THERMIQU'
  49. C LSPG(7)='FACE' -> FACE
  50. C LSPG(8)='P1CENTRE' -> CENTREP1
  51. C LSPG(9)='MSOMMET' -> MSOMMET
  52. LSPG(1)='SOMMET'
  53. LSPG(2)='CENTRE'
  54. LSPG(3)='FACE'
  55. LSPG(4)='CENTREP1'
  56. LSPG(5)='MSOMMET'
  57. C
  58. C le traitement d'harmoniques de fourier n'est pas implemente
  59. C
  60. C IPMINT=0
  61. IPCHEL=0
  62. C NPINT = 0
  63. C IRRT=0
  64. CONM=' '
  65. TYPSPG=' '
  66. C
  67. C activation de l'objet modele
  68. C
  69. MMODEL = IPMODL
  70. CALL LEKMOD(MMODEL,IDOMA,INEFMD)
  71. IF(IERR.NE.0)GOTO 9999
  72. SEGACT,MMODEL
  73. C IDOMA correspond au pointeur de la table domaine
  74. C
  75. C activation du chpoint
  76. C
  77. MCHPOI=IPCHPO
  78. SEGACT,MCHPOI
  79. NSOUPO=IPCHP(/1)
  80. C
  81. C Determination du type de support geometrique
  82. C
  83. DO 20 I=1,NSOUPO
  84. MSOUPO=IPCHP(I)
  85. SEGACT MSOUPO
  86. MLMCHP=IGEOC
  87. SEGDES MSOUPO
  88. CALL KRIPAD(MLMCHP,MLENTI)
  89. C
  90. C TYPSPG = SOMMET, FACE, CENTRE, CENTREP0, CENTREP1 ou MSOMMET
  91. C
  92. DO 10 L=1,NSPG
  93. TYPSPG=LSPG(L)
  94. CALL LEKTAB(IDOMA,TYPSPG,MLMSPG)
  95. CALL KRIPAD(MLMSPG,MLENT1)
  96. IF(IERR.NE.0)GOTO 9999
  97. CALL VERPAD(MLENTI,MLMSPG,IRET1)
  98. CALL VERPAD(MLENT1,MLMCHP,IRET2)
  99. IF(IRET1.EQ.0.AND.IRET2.EQ.0) GOTO 21
  100. 10 CONTINUE
  101. 20 CONTINUE
  102.  
  103. WRITE(6,*)'SPG du champoint non trouve : '
  104. WRITE(6,*)'CHPO peut-etre incompatible avec le modele?'
  105. GOTO 666
  106.  
  107. 21 CONTINUE
  108.  
  109. IPT3=MLMSPG
  110. INFSPG=L
  111. IF(L.GE.3) INFSPG=4+L
  112. IF(INFSPG.EQ.2) SEGACT,IPT3
  113. C
  114. C recherche eventuelle des sous-domaine du maillage
  115. C associe a l'objet modele Navier-Stokes
  116. C
  117. IMACR1=0
  118. DO 11 I=1,MAX(1,KMODEL(/1))
  119. IMODEL=KMODEL(I)
  120. SEGACT,IMODEL
  121. NELE=NEFMOD
  122. IF(NELE.GE.216.AND.NELE.LE.222) IMACR1=IMACR1+1
  123. 11 CONTINUE
  124.  
  125.  
  126.  
  127. CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
  128. IF(INEFMD.EQ.2.AND.INFSPG.NE.2) THEN
  129. CALL LEKTAB(IDOMA,'MACRO1',MPERE)
  130. ENDIF
  131. IF(IMACR1.EQ.KMODEL(/1)) CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
  132. C LINE ou LINB avec CENTREP1
  133. IF(INEFMD.EQ.1.OR.INEFMD.EQ.4) THEN
  134. IF(INFSPG.EQ.8) THEN
  135. C Option %m1:8 incompatible avec les données
  136. MOTERR( 1: 8) = TYPSPG
  137. CALL ERREUR(803)
  138. GOTO 666
  139. ENDIF
  140. ENDIF
  141. C Face
  142. IF(INFSPG.EQ.7) THEN
  143. C Option %m1:8 incompatible avec les données
  144. MOTERR( 1: 8) = TYPSPG
  145. CALL ERREUR(803)
  146. GOTO 666
  147. ENDIF
  148. IF(INFSPG.EQ.8) THEN
  149. CALL LEKTAB(IDOMA,'ELTP1NC',IPT4)
  150. SEGACT,IPT4
  151. ENDIF
  152.  
  153. MELEME=MPERE
  154. SEGACT MELEME
  155. N1=MAX(1,LISOUS(/1))
  156.  
  157. C
  158. C initialisation du segment descripteur du champ par element
  159. C
  160. N3=6
  161. L1=LEN(MTYPOI)
  162. SOUTYP=MTYPOI
  163. SEGINI,MCHELM
  164. TITCHE=SOUTYP
  165. IFOCHE=IFOUR
  166. C
  167. C remplissage des MCHAML
  168. C
  169. ILM1=0
  170. DO 30 I=1,N1
  171. IF(N1.NE.1) THEN
  172. IPT1=LISOUS(I)
  173. SEGACT IPT1
  174. ELSE
  175. IPT1=MELEME
  176. ENDIF
  177. IMACHE(I)=IPT1
  178. CONCHE(I)=CONM
  179. INFCHE(I,6)=INFSPG
  180.  
  181. IMODEL=KMODEL(I)
  182. SEGACT,IMODEL
  183. NELE=NEFMOD
  184. N2PTEL=0
  185. N2EL=0
  186. C TYPE SPG DU CHPO : SOMMET
  187. IF(INFSPG.EQ.1) THEN
  188. IMINT=0
  189. N1PTEL=IPT1.NUM(/1)
  190. N1EL=IPT1.NUM(/2)
  191. C TYPE SPG DU CHPO : CENTRE
  192. ELSEIF(INFSPG.EQ.2) THEN
  193. if(infmod(/1).lt.4) then
  194. CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
  195. INFO=IPTR
  196. IMINT=INFELL(11)
  197. segsup info
  198. else
  199. IMINT=infmod(INFSPG+2)
  200. endif
  201. N1PTEL=1
  202. N1EL=IPT1.NUM(/2)
  203. C IF(INFO.GT.0) SEGSUP INFO
  204. C TYPE SPG DU CHPO : CENTREP1
  205. ELSEIF(INFSPG.EQ.8) THEN
  206. CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
  207. INFO=IPTR
  208. IMINT=INFELL(11)
  209. N1PTEL=INFELL(8)
  210. N1EL=IPT1.NUM(/2)
  211. SEGSUP INFO
  212. C TYPE SPG DU CHPO : MSOMMET
  213. ELSEIF(INFSPG.EQ.9) THEN
  214. CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
  215. INFO=IPTR
  216. IMINT=INFELL(11)
  217. N1PTEL=INFELL(8)
  218. N1EL=IPT1.NUM(/2)
  219. SEGSUP INFO
  220. ENDIF
  221.  
  222. INFCHE(I,4)=IMINT
  223.  
  224. DO 40 J=1,NSOUPO
  225. MSOUPO=IPCHP(J)
  226. SEGACT MSOUPO
  227. N2=NOCOMP(/2)
  228. IPT2=IGEOC
  229. SEGACT,IPT2
  230. CALL KRIPAD(IPT2,MLENT2)
  231. SEGACT,MLENT2
  232. MPOVAL=IPOVAL
  233. SEGACT,MPOVAL
  234. SEGINI,MCHAML
  235. ICHAML(I)=MCHAML
  236.  
  237. DO 50 K=1,N2
  238. NOMCHE(K)=NOCOMP(K)
  239. TYPCHE(K)='REAL*8'
  240. SEGINI,MELVAL
  241. IELVAL(K)=MELVAL
  242. DO 70 K70=1,N1EL
  243. DO 80 K80=1,N1PTEL
  244. IF(INFSPG.EQ.1) THEN
  245. II2=IPT1.NUM(K80,K70)
  246. ELSEIF(INFSPG.EQ.2) THEN
  247. II2=IPT3.NUM(K80,(ILM1+K70))
  248. ELSEIF(INFSPG.EQ.8) THEN
  249. II2=IPT4.NUM(K80,(ILM1+K70))
  250. ELSEIF(INFSPG.EQ.9) THEN
  251. IF(INEFMD.EQ.1) II1=K80
  252. IF(INEFMD.EQ.2) II1=(2*K80)-1
  253. IF(INEFMD.EQ.3) II1=(2*K80)-1
  254. IF(INEFMD.EQ.4) II1=K80
  255. II2=IPT1.NUM(II1,K70)
  256. ENDIF
  257. VELCHE(K80,K70)=VPOCHA(MLENT2.LECT(II2),K)
  258. 80 CONTINUE
  259. 70 CONTINUE
  260. SEGDES,MELVAL
  261. 50 CONTINUE
  262. SEGDES,IPT2
  263. SEGDES,MLENT2
  264. SEGDES,MSOUPO
  265. SEGDES,MPOVAL
  266. SEGDES,MCHAML
  267. 40 CONTINUE
  268. ILM1=ILM1+IPT1.NUM(/2)
  269. IF(N1.NE.1) SEGDES,IPT1
  270. SEGDES,IMODEL
  271. 30 CONTINUE
  272.  
  273. IPCHEL=MCHELM
  274. SEGDES,MCHELM
  275.  
  276. SEGDES,MELEME
  277. 666 CONTINUE
  278. IF(INFSPG.EQ.2) SEGDES,IPT3
  279. IF(INFSPG.EQ.8) SEGDES,IPT4
  280. SEGDES,MCHPOI
  281. SEGDES,MMODEL
  282.  
  283. C
  284. 9999 CONTINUE
  285. RETURN
  286. END
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  

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