Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

  1. C CHAME1 SOURCE GG250959 17/09/20 21:15:10 9554
  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 *
  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 ?
  174. ELSE
  175. CALL PLACE(FORMOD,NFOR,ither,'THERMIQUE')
  176. IF (ither.NE.0) THEN
  177. nmat = matmod(/2)
  178. icov = 0
  179. C* CALL PLACE(matmod,nmat,icov,'CONVECTION')
  180. CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
  181. IF (icov+iray.EQ.0) ISUP1 = 6
  182. ENDIF
  183. ENDIF
  184. ENDIF
  185. C
  186. C on recupere le pointeur sur le minte correspondant a isup1
  187. C
  188. IF (ISUP1.GT.1) THEN
  189. MELE=NEFMOD
  190. IF ( ISUP1 .EQ. 6) THEN
  191. C cas de la thermique
  192. CALL TSHAPE(MELE,'GAUSS',IPMINT)
  193. IF (IERR.NE.0) THEN
  194. SEGDES,MCHPOI
  195. IF (IPMAIL.NE.0) SEGDES,IPT1
  196. IF (IPMODL.NE.0) SEGDES,MMODEL
  197. SEGDES,IMODEL
  198. SEGSUP,MCHELM
  199. RETURN
  200. ENDIF
  201. IELE = NUMGEO(MELE)
  202. NBNN = NBNNE(IELE)
  203. ELSE
  204. C* segact imodel
  205. if(2+isup1.gt.infmod(/1)) then
  206. CALL ELQUOI (MELE,0,ISUP1,IPINF,IMODEL)
  207. IF (IERR.NE.0) THEN
  208. SEGDES,MCHPOI
  209. IF (IPMAIL.NE.0) SEGDES,IPT1
  210. IF (IPMODL.NE.0) SEGDES,MMODEL
  211. SEGDES,IMODEL
  212. SEGSUP,MCHELM
  213. RETURN
  214. ENDIF
  215. INFO=IPINF
  216. IPMINT=INFELL(11)
  217. C SEGSUP,INFO
  218. else
  219. ipmint=infmod(2+isup1)
  220. IELE =INFELE(14)
  221. NBNN =NBNNE(IELE)
  222. endif
  223. C write(6,*) ' chame1 ipmint iele nbnn',ipmint,iele,nbnn
  224. ENDIF
  225. C
  226. C initialisation de ipore pour milieu poreux
  227. C
  228. IPORE=0
  229. IF(MELE.GE.79.AND.MELE.LE.83) IPORE=NBNN
  230. C**** IF(MELE.GE.108.AND.MELE.LE.110) IPORE=NBNN
  231. IF(MELE.GE.173.AND.MELE.LE.177) IPORE=NBNN
  232. C**** IF(MELE.GE.185.AND.MELE.LE.187) IPORE=NBNN
  233. IF(MELE.GE.178.AND.MELE.LE.182) IPORE=NBNN
  234. C**** IF(MELE.GE.188.AND.MELE.LE.190) IPORE=NBNN
  235. C cas XFEM il faut seulement les 4 premier noeuds (support geometrique)
  236. IF(MELE.GE.263) IPORE=NBNN
  237. C
  238. ELSE
  239. IPMINT=0
  240. ENDIF
  241. SEGDES,IMODEL
  242. ENDIF
  243. isouss=isouss+1
  244. C
  245. C projection du chpoint vers le chamelem,selon le
  246. C maillage considere
  247. C
  248. ICHAML(ISOUSs)=0
  249.  
  250. MINTE=IPMINT
  251. IF (IPMINT.NE.0) SEGACT,MINTE
  252.  
  253. C write(6,*) ' chame1 : avant appel a chame2'
  254. CALL CHAME2(itgeom,MCHPOI,MCHELM,IPCHAM,IPMINT,IPORE,
  255. & MELE)
  256. C write(6,*) ' chame1 : apres appel a chame2'
  257. IF (IPCHAM.EQ.0) THEN
  258. MOTERR(1:8)='MAILLAGE'
  259. MOTERR(9:16)='CHPOINT'
  260. CALL ERREUR(135)
  261. SEGDES,MCHPOI
  262. IF (IPMAIL.NE.0) SEGDES,IPT1
  263. IF (IPMODL.NE.0) SEGDES,MMODEL
  264. IF (IPMINT.NE.0) SEGDES,MINTE
  265. SEGSUP,MCHELM
  266. RETURN
  267. ENDIF
  268. ICHAML(ISOUSs)=IPCHAM
  269. IMACHE(ISOUSs)=ITGEOM
  270. CONCHE(ISOUSs)=CONM
  271. INFCHE(ISOUSs,1)=0
  272. INFCHE(ISOUSs,2)=0
  273. INFCHE(ISOUSs,3)=NIFOUR
  274. INFCHE(ISOUSs,6)=ISUP1
  275. IF (ISUP1.GT.1) THEN
  276. INFCHE(ISOUSs,4)=IPMINT
  277. INFCHE(ISOUSs,5)=0
  278. ENDIF
  279. C
  280. C cas integration dans l'epaisseur avec variable t temperature.
  281. C on transforme tinf t tsup en t défini par une variation
  282. C parabolique dans l'epaisseur. si il n'y a que t on ne fait rien.
  283. C Ce travail n'est a faire que pour les elements DKT, COQ4, COQ6 et COQ8
  284. C et uniquement si le MCHAML resultat n'est pas exprime aux noeuds !
  285. C
  286. IF (ISUP1.NE.1) THEN
  287. IF ( (MELE.EQ.28.AND.NPINT.NE.0) .OR. (MELE.EQ.49) .OR.
  288. & (MELE.EQ.56) .OR. (MELE.EQ.41) ) THEN
  289. MCHAML = IPCHAM
  290. SEGACT MCHAML
  291. FLAG1 = .FALSE.
  292. FLAG3 = .FALSE.
  293. FLAG4 = .FALSE.
  294. DO 21 ISOU1 = 1,NOMCHE(/2)
  295. IF(NOMCHE(ISOU1).EQ.'T ') FLAG1 = .TRUE.
  296. IF(NOMCHE(ISOU1).EQ.'TINF ') FLAG3 = .TRUE.
  297. IF(NOMCHE(ISOU1).EQ.'TSUP ') FLAG4 = .TRUE.
  298. 21 CONTINUE
  299. IF (FLAG1.AND.FLAG3.AND.FLAG4) THEN
  300. MELEME = IMACHE(ISOUS)
  301. CALL CHAME4(IPCHAM,IPMINT,MELEME)
  302. ENDIF
  303. SEGDES MCHAML
  304. ENDIF
  305. ENDIF
  306. IF (IPMINT.NE.0) SEGDES,MINTE
  307. C
  308. 20 CONTINUE
  309. C
  310. C fin de la boucle sur mes zones élémentaires
  311. C
  312. IF (IRRT.EQ.NSOUS) THEN
  313. C
  314. C l'objet maillage et le chpoint sont incompatibles
  315. C
  316. MOTERR(1:8)='MAILLAGE'
  317. MOTERR(9:16)='CHPOINT'
  318. CALL ERREUR(135)
  319. SEGDES,MCHPOI
  320. IF (IPMAIL.NE.0) SEGDES,IPT1
  321. IF (IPMODL.NE.0) SEGDES,MMODEL
  322. SEGSUP,MCHELM
  323. RETURN
  324. ENDIF
  325. C
  326. C ménage des segments
  327. C
  328. IF (IPMAIL.NE.0) SEGDES,IPT1
  329. IF (IPMODL.NE.0) SEGDES,MMODEL
  330. if( n1.ne.isouss) then
  331. n1=isouss
  332. segadj mchelm
  333. endif
  334. IPCHEL=MCHELM
  335. SEGDES,MCHELM
  336. C on détruit le maillage total du champoint si il est forme de plusieurs
  337. C morceaux
  338. IF (IPCHP(/1) .GT. 1) THEN
  339. IPT3 = IPGEOM
  340. SEGDES IPT3
  341. ENDIF
  342. C desactiver le champ par point
  343. DO 300 ISOUS=1,IPCHP(/1)
  344. MSOUPO=IPCHP(ISOUS)
  345. MPOVAL=IPOVAL
  346. SEGDES,MPOVAL
  347. MELEME=IGEOC
  348. SEGDES,MELEME
  349. SEGDES,MSOUPO
  350. 300 CONTINUE
  351.  
  352. SEGDES,MCHPOI
  353. RETURN
  354. END
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  

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