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

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