Télécharger chame1.eso

Retour à la liste

Numérotation des lignes :

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

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