Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

  1. C CHAME1 SOURCE CB215821 18/09/27 21:15:07 9936
  2. SUBROUTINE CHAME1(IPMAIL,IPMODL,IPCHPO,CHA,IPCHEL,ISUP)
  3. C____________________________________________________________________*
  4. C *
  5. C transformation de chpoint en mchaml *
  6. C *
  7. C entr{es: *
  8. C ________ *
  9. C *
  10. C ipmail pointeur sur un maillage *
  11. C ou ipmodl pointeur sur un mmodel *
  12. C ipchpo pointeur sur le chpoint *
  13. C cha chaine de caract}re contenant un sous type eventuel
  14. C isup indique le type de support demande : *
  15. C 1 le mchaml est laisse aux noeuds *
  16. C 2 au centre de gravite *
  17. C 3 aux points de gauss de la raideur *
  18. C 4 aux points de gauss de la masse *
  19. C 5 aux points de gauss des contraintes *
  20. C 6 aux point de gauss de la thermique & diffusion
  21. C & metallurgie
  22. C *
  23. C sorties: *
  24. C ________ *
  25. C *
  26. C ipchel pointeur sur le mchaml r{sultat *
  27. C *
  28. C remarque : le passage du mchaml sur un autre support que les *
  29. C noeuds n'est possible que si l'on a donne un mmodel *
  30. C *
  31. C____________________________________________________________________*
  32. C *
  33. IMPLICIT INTEGER(I-N)
  34. IMPLICIT REAL*8(A-H,O-Z)
  35.  
  36. -INC CCOPTIO
  37. -INC CCGEOME
  38.  
  39. -INC SMCHAML
  40. -INC SMCHPOI
  41. -INC SMINTE
  42. -INC SMMODEL
  43. -INC SMELEME
  44. C
  45. SEGMENT INFO
  46. INTEGER INFELL(JG)
  47. ENDSEGMENT
  48. C
  49. CHARACTER*(*) CHA
  50. CHARACTER*(NCONCH) CONM
  51. CHARACTER*1 MO1
  52. LOGICAL FLAG1
  53. LOGICAL FLAG3
  54. LOGICAL FLAG4,ltelq
  55. C
  56. C soutyp = sous-type du champ par element resultat
  57. C lsouty = longueur utile de la chaine "soutyp"
  58. C
  59. INTEGER LSOUTY
  60. CHARACTER*72 SOUTYP
  61. C
  62. C le traitement d'harmoniques de fourier n'est pas implemente
  63. C
  64. ISUP1=ISUP
  65. IPCHEL=0
  66. NPINT = 0
  67. IRRT=0
  68. CONM=' '
  69.  
  70. ither = 0
  71. idiff = 0
  72. imeta = 0
  73.  
  74. C
  75. C on cree l'objet maillage contenant tous les points du chpoint
  76. C
  77. MCHPOI=IPCHPO
  78. SEGACT,MCHPOI
  79. NSOUPO=IPCHP(/1)
  80. IPGEOM = 0
  81. C cette boucle meriterai d'etre reecrite : elle est pitoyable
  82. DO 1140 I=1,NSOUPO
  83. MSOUPO=IPCHP(I)
  84. SEGACT MSOUPO
  85. IF (IPGEOM.EQ.0) THEN
  86. IPGEOM = IGEOC
  87. ELSE
  88. IPP2 = IGEOC
  89. ltelq=.false.
  90. CALL FUSE (IPGEOM,IPP2,IRET,ltelq)
  91. C il faut détruire les intermédiaires
  92. IF ( I .GT. 2 ) THEN
  93. IPT3 = IPGEOM
  94. SEGACT IPT3
  95. ENDIF
  96. IPGEOM = IRET
  97. ENDIF
  98. 1140 CONTINUE
  99. C
  100. N3=6
  101. IF (IPMAIL.NE.0) THEN
  102. IPT1=IPMAIL
  103. SEGACT,IPT1
  104. NSOUS=IPT1.LISOUS(/1)
  105. IF (NSOUS.EQ.0) THEN
  106. NSOUS=1
  107. ENDIF
  108. ISUP1=1
  109. ELSE IF (IPMODL.NE.0) THEN
  110. MMODEL = IPMODL
  111. SEGACT,MMODEL
  112. NSOUS = KMODEL(/1)
  113. IF (ISUP1.GT.1) N3=6
  114. ENDIF
  115. C
  116. C initialisation du segment descripteur du champ par element
  117. C
  118. N1=NSOUS
  119. MO1 = CHA
  120. IF (MO1.EQ.' ') THEN
  121. L1=8
  122. SOUTYP=MTYPOI
  123. ELSE
  124. L1=LEN(CHA)
  125. SOUTYP=CHA
  126. ENDIF
  127. SEGINI,MCHELM
  128. TITCHE=SOUTYP
  129. IFOCHE=IFOUR
  130. C
  131. C boucle sur les zones geometriques elementaires
  132. C
  133. isouss=0
  134. DO 20 ISOUS=1,NSOUS
  135. ISUP1 = ISUP
  136. IPMINT=0
  137. IF (IPMAIL.NE.0) THEN
  138. IF (NSOUS.GT.1) THEN
  139. ITGEOM=IPT1.LISOUS(ISOUS)
  140. ELSE
  141. ITGEOM=IPMAIL
  142. ENDIF
  143. ELSE IF (IPMODL.NE.0) THEN
  144. IMODEL = KMODEL(ISOUS)
  145. SEGACT,IMODEL
  146. cbp : pour les elements MULT, on autorise les chamls aux noeuds
  147. if(ISUP1.ne.1.AND.nefmod.eq.22) then
  148. SEGACT imodel
  149. goto 20
  150. endif
  151. if(ISUP1.ne.1.AND.nefmod.eq.259) then
  152. SEGACT imodel
  153. goto 20
  154. endif
  155. ITGEOM = IMAMOD
  156.  
  157. if (formod(1)(1:8).eq.'LIAISON ') then
  158. C ne fait rien si le support liaison n appartient pas au CHPOINT
  159. ipt1 = imamod
  160. segact ipt1
  161. meleme =ipgeom
  162. if (meleme.eq.0) goto 20
  163. segact meleme
  164. IVAL1 = ipt1.num(1,1)
  165. do jno = 1, num(/2)
  166. if (num(1,jno).eq.IVAL1) goto 11
  167. enddo
  168. SEGACT,ipt1
  169. goto 20
  170. endif
  171.  
  172. 11 CONM = CONMOD
  173. IF(INFMOD(/1).NE.0) NPINT=INFMOD(1)
  174. C
  175. C Changment de support si besoin selon la formulation ?
  176. IF (ISUP1 .NE. 1) THEN
  177. NFOR = FORMOD(/2)
  178. C* Modele de Frottement ?
  179. CALL PLACE(FORMOD,NFOR,ifro,'FROTTEMENT')
  180. IF (ifro.NE.0) THEN
  181. ISUP1 = 1
  182. C* Modele de THERMIQUE OU DIFFUSION OU METALLURGIE ?
  183. ELSE
  184. CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  185. CALL PLACE(FORMOD,NFOR,idiff,'DIFFUSION')
  186. CALL PLACE(FORMOD,NFOR,imeta,'METALLURGIE')
  187. IF (ither.NE.0 .OR. idiff.NE.0 .OR. imeta.NE.0) THEN
  188. nmat = matmod(/2)
  189. icov = 0
  190. C* CALL PLACE(matmod,nmat,icov,'CONVECTION')
  191. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  192. IF (icov+iray.EQ.0) ISUP1 = 6
  193. ENDIF
  194. ENDIF
  195. ENDIF
  196. C
  197. C on recupere le pointeur sur le minte correspondant a isup1
  198. C
  199. IF (ISUP1.GT.1) THEN
  200. MELE=NEFMOD
  201. IF ( ISUP1 .EQ. 6) THEN
  202. C cas de la thermique OU diffusion OU METALLURGIE
  203. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  204. IF (IERR.NE.0) THEN
  205. SEGACT,MCHPOI
  206. IF (IPMAIL.NE.0) SEGACT,IPT1
  207. C IF (IPMODL.NE.0) SEGACT,MMODEL
  208. C SEGACT,IMODEL
  209. SEGSUP,MCHELM
  210. RETURN
  211. ENDIF
  212. IELE = NUMGEO(MELE)
  213. NBNN = NBNNE(IELE)
  214. ELSE
  215. C* segact imodel
  216. if(2+isup1.gt.infmod(/1)) then
  217. CALL ELQUOI (MELE,0,ISUP1,IPINF,IMODEL)
  218. IF (IERR.NE.0) THEN
  219. SEGACT,MCHPOI
  220. IF (IPMAIL.NE.0) SEGACT,IPT1
  221. C IF (IPMODL.NE.0) SEGACT,MMODEL
  222. C SEGACT,IMODEL
  223. SEGSUP,MCHELM
  224. RETURN
  225. ENDIF
  226. INFO=IPINF
  227. IPMINT=INFELL(11)
  228. C SEGSUP,INFO
  229. else
  230. ipmint=infmod(2+isup1)
  231. IELE =INFELE(14)
  232. NBNN =NBNNE(IELE)
  233. endif
  234. C write(6,*) ' chame1 ipmint iele nbnn',ipmint,iele,nbnn
  235. ENDIF
  236. C
  237. C initialisation de ipore pour milieu poreux
  238. C
  239. IPORE=0
  240. IF(MELE.GE.79.AND.MELE.LE.83) IPORE=NBNN
  241. C**** IF(MELE.GE.108.AND.MELE.LE.110) IPORE=NBNN
  242. IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  243. C**** IF(MELE.GE.185.AND.MELE.LE.187) IPORE=NBNN
  244. IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  245. C**** IF(MELE.GE.188.AND.MELE.LE.190) IPORE=NBNN
  246. C cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  247. IF(MELE.GE.263) IPORE=NBNN
  248. C
  249. ELSE
  250. IPMINT=0
  251. ENDIF
  252. C SEGACT,IMODEL
  253. ENDIF
  254. isouss=isouss+1
  255. C
  256. C projection du chpoint vers le chamelem,selon le
  257. C maillage considere
  258. C
  259. ICHAML(ISOUSs)=0
  260.  
  261. MINTE=IPMINT
  262. IF (IPMINT.NE.0) SEGACT,MINTE
  263.  
  264. C write(6,*) ' chame1 : avant appel a chame2'
  265. CALL CHAME2(itgeom,MCHPOI,MCHELM,IPCHAM,IPMINT,IPORE,
  266. & MELE)
  267. C write(6,*) ' chame1 : apres appel a chame2'
  268. IF (IPCHAM.EQ.0) THEN
  269. MOTERR(1:8 )='MAILLAGE'
  270. MOTERR(9:16)='CHPOINT'
  271. CALL ERREUR(135)
  272. SEGACT,MCHPOI
  273. IF (IPMAIL.NE.0) SEGACT,IPT1
  274. C IF (IPMODL.NE.0) SEGACT,MMODEL
  275. IF (IPMINT.NE.0) SEGACT,MINTE
  276. SEGSUP,MCHELM
  277. RETURN
  278. ENDIF
  279. ICHAML(ISOUSs)=IPCHAM
  280. IMACHE(ISOUSs)=ITGEOM
  281. CONCHE(ISOUSs)=CONM
  282. INFCHE(ISOUSs,1)=0
  283. INFCHE(ISOUSs,2)=0
  284. INFCHE(ISOUSs,3)=NIFOUR
  285. INFCHE(ISOUSs,6)=ISUP1
  286. IF (ISUP1.GT.1) THEN
  287. INFCHE(ISOUSs,4)=IPMINT
  288. INFCHE(ISOUSs,5)=0
  289. ENDIF
  290. C
  291. C cas integration dans l'epaisseur avec variable t temperature.
  292. C on transforme tinf t tsup en t défini par une variation
  293. C parabolique dans l'epaisseur. si il n'y a que t on ne fait rien.
  294. C Ce travail n'est a faire que pour les elements DKT, COQ4, COQ6 et COQ8
  295. C et uniquement si le MCHAML resultat n'est pas exprime aux noeuds !
  296. C
  297. IF (ISUP1.NE.1) THEN
  298. IF ( (MELE.EQ.28.AND.NPINT.NE.0) .OR. (MELE.EQ.49) .OR.
  299. & (MELE.EQ.56) .OR. (MELE.EQ.41) ) THEN
  300. MCHAML = IPCHAM
  301. SEGACT MCHAML
  302. FLAG1 = .FALSE.
  303. FLAG3 = .FALSE.
  304. FLAG4 = .FALSE.
  305. DO 21 ISOU1 = 1,NOMCHE(/2)
  306. IF(NOMCHE(ISOU1).EQ.'T ') FLAG1 = .TRUE.
  307. IF(NOMCHE(ISOU1).EQ.'TINF ') FLAG3 = .TRUE.
  308. IF(NOMCHE(ISOU1).EQ.'TSUP ') FLAG4 = .TRUE.
  309. 21 CONTINUE
  310. IF (FLAG1.AND.FLAG3.AND.FLAG4) THEN
  311. MELEME = IMACHE(ISOUS)
  312. CALL CHAME4(IPCHAM,IPMINT,MELEME)
  313. ENDIF
  314. SEGACT MCHAML
  315. ENDIF
  316. ENDIF
  317. IF (IPMINT.NE.0) SEGACT,MINTE
  318. C
  319. 20 CONTINUE
  320. C
  321. C fin de la boucle sur mes zones élémentaires
  322. C
  323. IF (IRRT.EQ.NSOUS) THEN
  324. C
  325. C l'objet maillage et le chpoint sont incompatibles
  326. C
  327. MOTERR(1:8)='MAILLAGE'
  328. MOTERR(9:16)='CHPOINT'
  329. CALL ERREUR(135)
  330. SEGACT,MCHPOI
  331. IF (IPMAIL.NE.0) SEGACT,IPT1
  332. C IF (IPMODL.NE.0) SEGACT,MMODEL
  333. SEGSUP,MCHELM
  334. RETURN
  335. ENDIF
  336. C
  337. C ménage des segments
  338. C
  339. IF (IPMAIL.NE.0) SEGACT,IPT1
  340. C IF (IPMODL.NE.0) SEGACT,MMODEL
  341. if( n1.ne.isouss) then
  342. n1=isouss
  343. segadj mchelm
  344. endif
  345. IPCHEL=MCHELM
  346. SEGACT,MCHELM
  347. C on détruit le maillage total du champoint si il est forme de plusieurs
  348. C morceaux
  349. IF (IPCHP(/1) .GT. 1) THEN
  350. IPT3 = IPGEOM
  351. SEGACT IPT3
  352. ENDIF
  353. C desactiver le champ par point
  354. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  355.  
  356. END
  357.  
  358.  
  359.  

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