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