Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

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

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