1 : C FFORME SOURCE CHAT 12/06/07 21:15:19 7389
2 : SUBROUTINE FFORME
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8 (A-H,O-Z)
5 : C
6 : C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR FFOR
7 : C (LECTURE ET VERIFICATION DES DONNEES PUIS AIGUILLAGE)
8 : C
9 : C__________________________________________________________________
10 : C APPEL :
11 : C
12 : C 3D CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 P3) ('NNOR') ;
13 : C 2D CH2 = FFOR MODL1 (ENTI1) (FLOT1) ('SYME' P1 P2 ) ('NNOR') ;
14 : C CONV CH2 = FFOR MODL1 (ENTI1) 'CVXE' ;
15 : C AXIS CH2 = FFOR MODL1 (ENTI1) ('NGAU' ENTI2) ('CVXE') ('NNOR') ;
16 : C
17 : C
18 : C 03/96 : option supplementaire pour tenir compte de l'absorption du
19 : C milieu:
20 : C 'ABSO' EXTINC ;
21 : C pour simplifier la lecture on demande que ce coef. soit negatif
22 : C
23 : C 09/02: on donne le nombre de points d'integration pour le traitement
24 : C des faces proches en AXIS (cf 'NGAU')
25 : C__________________________________________________________________
26 : C OPERANDES :
27 : C
28 : C CH2 'CHAMELEM' FACTEURS DE FORME
29 : C MODL1 'MMODEL' STRUCTURE MODELISEE (CONTOUR OU ENVELOPPE)
30 : C ENTI1 'ENTIER' DISCRETISATION ANGULAIRE EN 2D-PLAN OU
31 : C 3D-CAS GENERAL
32 : C FLOT1 'FLOTTANT' FACTEUR DE DECOUPAGE DES ELEMENTS
33 : C CVXE 'MOT CLE' MOT CLE POUR LES CAVITES CONVEXES
34 : C SYME 'MOT CLE' MOT CLE DEFINISSANT UN AXE OU UN PLAN
35 : C DE SYMETRIE
36 : C P1,P2,P3 'POINT' POINTS DEFINISSANT L'AXE OU LE PLAN DE
37 : C SYMETRIE
38 : C NGAU 'MOT CLE' EN AXISYMETRIQUE
39 : C ENTI2 'ENTIER' nombre de points d'integration
40 : C
41 : C ABSO mot-clé pour un milieu absorbant
42 : C EXTINC coefficient d'absorption
43 : C__________________________________________________________________
44 : C
45 : C
46 : -INC CCOPTIO
47 : -INC SMMODEL
48 : -INC SMCHAML
49 : C
50 : POINTEUR MYMOD.MMODEL
51 : C ___________________________________________________________
52 : C Stockage de numeros de points
53 : SEGMENT ,LISTEN
54 : INTEGER LECT(NBE)
55 : ENDSEGMENT
56 : POINTEUR IAXE.LISTEN
57 : C ___________________________________________________________
58 : C Stockage d'informations concernant le type des éléments
59 : SEGMENT ,INFOEL
60 : LOGICAL KCOQ(N1),KQUAD(N1)
61 : ENDSEGMENT
62 : C ___________________________________________________________
63 : C
64 : CHARACTER*4 MOTCLE
65 : LOGICAL MCVX,MSYM,MGAUS,MABS
66 : C
67 : C__________________________________________________________________
68 : C
69 : MCVX = .FALSE.
70 : MSYM = .FALSE.
71 : MGAUS = .FALSE.
72 : MABS = .FALSE.
73 : KNOR = 1
74 : IAXE = 0
75 : EXTINC = -1.D-5
76 :
76 : CALL LIROBJ('MMODEL',MYMOD,1,IRETOU)
77 : IF (IERR.NE.0) RETURN
78 : mchelm=0
78 : call lirobj('MCHAML', mchel1,0,iretou)
78 : call reduaf(mchel1,mymod,mchelm,1,iretr,kerre)
79 : if( iretr.ne.1) then
79 : call erreur (kerre)
80 : return
81 : endif
82 : C
83 : C -----------------------------------------------------
84 : C On va vérifier que le TYPE DES ÉLÉMENTS des maillages
85 : C sur lequel repose le modèle CONVIENT .
86 : C et le type de modèle
87 : C
88 : SEGACT MYMOD
89 : N1 = MYMOD.KMODEL(/1)
90 : iy=0
91 : 20 iy=iy+1
92 : if( iy.gt.mymod.kmodel(/1)) then
92 : call erreur (19)
93 : return
94 : endif
95 : imodel=mymod.kmodel(iy)
96 : segact imodel
97 : imail= imamod
98 : if(formod(1).ne.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT'
99 : $ . or. matmod(3).ne.'CAVITE') go to 20
100 : nmat=matmod(/2)
101 : inatu=inatuu
102 : if(imatee.ne.4) go to 20
103 : * pour la valeur de inatu voir subroutine nomate
104 : if( inatu.eq.2)then
105 : knor=0
106 : elseif(inatu.eq.3) then
107 : MSYM = .TRUE.
108 : elseif(inatu.eq.4) then
109 : MCVX = .TRUE.
110 : elseif(inatu.eq.5) then
111 : MSYM = .TRUE.
112 : MCVX = .TRUE.
113 : elseif(inatu.eq.6) then
114 : knor=0
115 : MCVX = .TRUE.
116 : elseif(inatu.eq.7) then
117 : MSYM = .TRUE.
118 : knor=0
119 : elseif(inatu.eq.8) then
120 : MSYM = .TRUE.
121 : MCVX = .TRUE.
122 : knor=1
123 : elseif(inatu.ne.1) then
124 : write(6,*) ' pb dans fforme'
125 : write(6,*) ' inatu ' , inatu
125 : call erreur(5)
126 : endif
127 : ngax=ivamod(1)
128 : int=ivamod(2)
129 : npax=20
130 : npax=max ( int,npax)
131 : SEGINI INFOEL
132 : * recherche du coefficient d'absorption
133 : *
133 : call zpchel(mchelm,1)
134 : if( mchelm.ne.0) then
135 : segact mchelm
136 : do iy=1,imache(/1)
137 : write(6,*) imamod,imache(iy),conche(iy),conmod
138 : if( imache(iy).eq.imamod.and.conche(iy).eq.conmod) then
139 : mchaml=ichaml(iy)
140 : segact mchaml
141 : do it=1,nomche(/2)
142 : if( nomche(it).eq.'CABS' ) THEN
143 : melval=ielval(it)
144 : segact melval
145 : extinc=-velche(1,1)
146 : mabs=.true.
147 : segdes melval
148 : segdes mchaml
149 : go to 8
150 : endif
151 : enddo
152 : segdes mchaml
153 : endif
154 : enddo
155 : 8 continue
156 : segdes mchelm
157 : endif
158 : write(6,*) ' extinc',extinc
159 : write(6,*) ' knor mcvx , msym , mgaus mabs'
160 : write(6,*) knor,mcvx , msym , mgaus,mabs
161 :
162 : C
163 : DO 10 ITYP=1,N1
164 : C
165 : IMODEL = MYMOD.KMODEL(ITYP)
166 : SEGACT IMODEL
167 : C
168 : C la formulation est simple a priori
169 : C
170 : IF(FORMOD(1).NE.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT') THEN
170 : CALL ERREUR(21)
171 : RETURN
172 : ENDIF
173 : write(6,*) ' nefmod ' , nefmod
174 : C
175 : C On va rega Crder quelle est la nature de l'élément
176 : IF (IDIM.EQ.3) THEN
177 :
178 : IF ((NEFMOD.EQ.4).OR.(NEFMOD.EQ.8)) THEN
179 : C TRI3 ou QUA4
180 : KQUAD(ITYP)=.FALSE.
181 : KCOQ(ITYP) =.FALSE.
182 : ELSEIF ((NEFMOD.EQ.27).OR.(NEFMOD.EQ.49)) THEN
183 : C COQ3 ou COQ4
184 : KQUAD(ITYP)=.FALSE.
185 : KCOQ(ITYP) =.TRUE.
186 : ELSEIF ((NEFMOD.EQ.6).OR.(NEFMOD.EQ.10)) THEN
187 : C TRI6 ou QUA8
188 : KQUAD(ITYP)=.TRUE.
189 : KCOQ(ITYP) =.FALSE.
190 : ELSEIF ((NEFMOD.EQ.56).OR.(NEFMOD.EQ.41)) THEN
191 : C COQ6 ou COQ8
192 : KQUAD(ITYP)=.TRUE.
193 : KCOQ(ITYP) =.TRUE.
194 : ELSE
194 : CALL ERREUR(16)
195 : RETURN
196 : ENDIF
197 : C
198 : ELSEIF (IDIM.EQ.2) THEN
199 : C
200 : IF (NEFMOD.EQ.2) THEN
201 : C SEG2
202 : KQUAD(ITYP)=.FALSE.
203 : KCOQ(ITYP) =.FALSE.
204 : ELSEIF (NEFMOD.EQ.44) THEN
205 : C COQ2
206 : KQUAD(ITYP)=.FALSE.
207 : KCOQ(ITYP) =.TRUE.
208 : ELSEIF (NEFMOD.EQ.3) THEN
209 : C SEG3
210 : KQUAD(ITYP)=.TRUE.
211 : KCOQ(ITYP) =.FALSE.
212 : ELSE
212 : CALL ERREUR(16)
213 : RETURN
214 : ENDIF
215 : C
216 : ELSE
216 : CALL ERREUR(14)
217 : RETURN
218 : ENDIF
219 :
220 : SEGDES IMODEL
221 :
222 : 10 CONTINUE
223 :
224 : SEGDES INFOEL
225 : SEGDES MYMOD
226 : C
227 : C
228 : C ----------------------------------------------------
229 : C Orientation vers les différents sous-programmes
230 : C
231 : IF (IFOMOD.NE.0) THEN
232 : C On n'est pas en mode axisymétrique
233 : C
234 : IF (MCVX.AND.(.NOT.MSYM)) THEN
235 : C on n'a recu que CVXE
236 : GOTO 100
237 : ELSEIF (MSYM) THEN
238 : C il faut lire des points pour le cas général
239 : GOTO 200
240 : ELSE
241 : C cas général
242 : GOTO 210
243 : ENDIF
244 : C
245 : ELSE
246 : C On est en mode axisymétrique
247 : GOTO 300
248 : C
249 : ENDIF
250 : C
251 : C**********************************************************
252 : C
253 : C
254 : C
255 : C********************
256 : C CAS CONVEXE
257 : C********************
258 : C
258 : 100 CALL LIRENT(INT1,0,IRETOU)
259 : IF (IRETOU.NE.0) THEN
260 : INT=INT1
261 : ELSE
262 : INT=3
263 : ENDIF
264 : write(6,*) ' int ', int
264 : CALL FACCVX(MYMOD,INFOEL,INT,ICHFAC)
265 :
266 : GOTO 900
267 : C
268 : C
269 : C********************
270 : C CAS GENERAL
271 : C********************
272 : C
273 : C----cas avec 'SYME' => lecture des points
274 : C
275 : 200 segact imodel
276 : ip1 = ivamod(3)
277 : ip2 = ivamod(4)
278 : NBE = IDIM
279 : SEGINI ,IAXE
280 : IAXE.LECT(1) = IP1
281 : IAXE.LECT(2) = IP2
282 : IF (IDIM.EQ.3) THEN
283 : ip3=ivamod(5)
284 : iaxe.lect(3)=ip3
285 : ENDIF
286 : SEGDES IAXE,imodel
287 : C
288 : C----suite du cas général
289 : C
289 : 210 CALL LIRENT(INT1,0,IRETOU)
290 : IF (IRETOU.NE.0) THEN
291 : IF(IDIM.EQ.3) THEN
292 : LRES=MIN0(INT1,100)
293 : ELSE
294 : LRES=MIN0(INT1,1000)
295 : ENDIF
296 : ELSE
297 : IF(IDIM.EQ.3) THEN
298 : LRES=50
299 : ELSE
300 : LRES=200
301 : ENDIF
302 : ENDIF
303 : write(6,*) ' lres ' , lres
304 :
305 :
306 : * IF (MABS) THEN
306 : * CALL LIRREE(FLO2,0,IRETO2)
306 : * CALL LIRREE(FLO1,0,IRETOU)
307 :
308 : * IF(FLO2.LT.(-1.D-5)) THEN
309 : * EXTINC = -FLO2
310 : * ELSE
311 : * EXTINC = -FLO1
312 : * FLO1 = FLO2
313 : * IRETOU=IRETO2
314 : * ENDIF
315 :
316 : * ELSE
316 : * CALL LIRREE(FLO1,0,IRETOU)
317 : * ENDIF
318 :
319 : IF (IRETOU.NE.0) THEN
320 : IF(IDIM.EQ.3) THEN
321 : XDEC=DMIN1(FLO1,2.D0)
322 : ELSE
323 : XDEC=DMIN1(FLO1,10.D0)
324 : ENDIF
325 : ELSE
326 : IF(IDIM.EQ.3) THEN
327 : XDEC=0.5
328 : ELSE
329 : XDEC=5.D0
330 : ENDIF
331 : ENDIF
332 : write(6,*) ' xdec ' , xdec
333 : C
334 : C
335 : IF (IDIM.EQ.3) THEN
336 : write(6,*) ' appel a facgen'
337 : write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
337 : CALL FACGEN(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
338 : ELSE
339 : write(6,*) ' appel a facge2'
340 : write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
341 : write(6,*) ( kcoq(iou),kquad(iou),iou=1,kcoq(/1))
342 :
342 : CALL FACGE2(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
343 : ENDIF
344 : IF (IAXE.NE.0) SEGSUP IAXE
345 : C
346 : GOTO 900
347 : C
348 : C********************
349 : C CAS AXISYMETRIQUE
350 : C********************
351 : C
352 :
353 : 300 CONTINUE
354 :
355 : C valeurs par defaut
356 :
357 : NGAX=10
358 : NPAX=20
359 :
359 : CALL LIRENT(INT1,0,IRETO1)
359 : CALL LIRENT(INT2,0,IRETO2)
360 :
361 : IF (IRETO2.NE.0) THEN
362 : NGAX = MIN0(INT1,10)
363 : NPAX = MIN0(INT2,1000)
364 : ELSEIF (MGAUS) THEN
365 : NPAX = MIN0(INT1,1000)
366 : ELSEIF (IRETO1.NE.0) THEN
367 : NGAX=MIN0(INT1,10)
368 : ENDIF
369 :
370 : C WRITE(6,*) ' FFOR NG NP ',NGAX,NPAX
371 :
372 : IF (MCVX) THEN
373 : KACHE = 0
374 : ELSE
375 : KACHE = 1
376 : ENDIF
377 : C
378 : IF(MABS) THEN
378 : CALL LIRREE(FLO1,0,IRETOU)
379 : IF (IRETOU.NE.0) THEN
380 : EXTINC=-FLO1
381 : ENDIF
382 : ENDIF
383 :
383 : CALL FACAXI(MYMOD,INFOEL,NPAX,NGAX,KACHE,KNOR,ICHFAC,EXTINC)
384 : C
385 : C
386 : C**********************************************************
387 : C
388 : C
389 : 900 SEGSUP ,INFOEL
390 : segact mymod
391 : mchelm=ICHFAC
392 : segact mchelm*mod
393 : do i=1,mymod.kmodel(/1)
394 : imodel=mymod.kmodel(i)
395 : segact imodel
396 : conche(i)=conmod
397 : segdes imodel
398 : enddo
399 : segdes mchelm
400 : segdes mymod
401 : C Ecriture du chamelem facteur de forme
401 : CALL ECROBJ('MCHAML',ICHFAC)
402 : RETURN
403 : END
404 :
405 :
406 :
407 :
408 :
409 :
410 :
411 :
412 :
413 :
414 :
415 :
416 :
© Cast3M 2003 - All rights reserved.
Disclaimer