1 : C FFORM1 SOURCE CHAT 12/06/07 21:15:19 7389
2 : SUBROUTINE FFORM1(mymod,mchelm,ichfac)
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 :
77 : C
78 : C -----------------------------------------------------
79 : C On va vérifier que le TYPE DES ÉLÉMENTS des maillages
80 : C sur lequel repose le modèle CONVIENT .
81 : C et le type de modèle
82 : C
83 : SEGACT MYMOD
84 : N1 = MYMOD.KMODEL(/1)
85 : iy=0
86 : 20 iy=iy+1
87 : if( iy.gt.mymod.kmodel(/1)) then
87 : call erreur (19)
88 : return
89 : endif
90 : imodel=mymod.kmodel(iy)
91 : segact imodel
92 : imail= imamod
93 : if(formod(1).ne.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT'
94 : $ . or. matmod(3).ne.'CAVITE') go to 20
95 : nmat=matmod(/2)
96 : inatu=inatuu
97 : if(imatee.ne.4) go to 20
98 : * pour la valeur de inatu voir subroutine nomate
99 : if( inatu.eq.2)then
100 : knor=0
101 : elseif(inatu.eq.3) then
102 : MSYM = .TRUE.
103 : elseif(inatu.eq.4) then
104 : MCVX = .TRUE.
105 : elseif(inatu.eq.5) then
106 : MSYM = .TRUE.
107 : MCVX = .TRUE.
108 : elseif(inatu.eq.6) then
109 : knor=0
110 : MCVX = .TRUE.
111 : elseif(inatu.eq.7) then
112 : MSYM = .TRUE.
113 : knor=0
114 : elseif(inatu.eq.8) then
115 : MSYM = .TRUE.
116 : MCVX = .TRUE.
117 : knor=1
118 : elseif(inatu.ne.1) then
119 : write(6,*) ' pb dans fforme'
120 : write(6,*) ' inatu ' , inatu
120 : call erreur(5)
121 : endif
122 : ngax=ivamod(1)
123 : int=ivamod(2)
124 : npax=20
125 : npax=max ( int,npax)
126 : SEGINI INFOEL
127 : * recherche du coefficient d'absorption
128 : *
129 : if( mchelm.ne.0) then
130 : segact mchelm
131 : do iy=1,imache(/1)
132 : * write(6,*) imamod,imache(iy),conche(iy),conmod
133 : if( imache(iy).eq.imamod.and.conche(iy).eq.conmod) then
134 : mchaml=ichaml(iy)
135 : segact mchaml
136 : do it=1,nomche(/2)
137 : if( nomche(it).eq.'CABS' ) THEN
138 : melval=ielval(it)
139 : segact melval
140 : extinc=-velche(1,1)
141 : mabs=.true.
142 : segdes melval
143 : segdes mchaml
144 : go to 8
145 : endif
146 : enddo
147 : segdes mchaml
148 : endif
149 : enddo
150 : 8 continue
151 : segdes mchelm
152 : endif
153 : * write(6,*) ' extinc',extinc
154 : * write(6,*) ' knor mcvx , msym , mgaus mabs'
155 : * write(6,*) knor,mcvx , msym , mgaus,mabs
156 :
157 : C
158 : DO 10 ITYP=1,N1
159 : C
160 : IMODEL = MYMOD.KMODEL(ITYP)
161 : SEGACT IMODEL
162 : C
163 : C la formulation est simple a priori
164 : C
165 : IF(FORMOD(1).NE.'THERMIQUE'.or.matmod(2).ne.'RAYONNEMENT') THEN
165 : CALL ERREUR(21)
166 : RETURN
167 : ENDIF
168 : * write(6,*) ' nefmod ' , nefmod
169 : C
170 : C On va rega Crder quelle est la nature de l'élément
171 : IF (IDIM.EQ.3) THEN
172 :
173 : IF ((NEFMOD.EQ.4).OR.(NEFMOD.EQ.8)) THEN
174 : C TRI3 ou QUA4
175 : KQUAD(ITYP)=.FALSE.
176 : KCOQ(ITYP) =.FALSE.
177 : ELSEIF ((NEFMOD.EQ.27).OR.(NEFMOD.EQ.49)) THEN
178 : C COQ3 ou COQ4
179 : KQUAD(ITYP)=.FALSE.
180 : KCOQ(ITYP) =.TRUE.
181 : ELSEIF ((NEFMOD.EQ.6).OR.(NEFMOD.EQ.10)) THEN
182 : C TRI6 ou QUA8
183 : KQUAD(ITYP)=.TRUE.
184 : KCOQ(ITYP) =.FALSE.
185 : ELSEIF ((NEFMOD.EQ.56).OR.(NEFMOD.EQ.41)) THEN
186 : C COQ6 ou COQ8
187 : KQUAD(ITYP)=.TRUE.
188 : KCOQ(ITYP) =.TRUE.
189 : ELSE
189 : CALL ERREUR(16)
190 : RETURN
191 : ENDIF
192 : C
193 : ELSEIF (IDIM.EQ.2) THEN
194 : C
195 : IF (NEFMOD.EQ.2) THEN
196 : C SEG2
197 : KQUAD(ITYP)=.FALSE.
198 : KCOQ(ITYP) =.FALSE.
199 : ELSEIF (NEFMOD.EQ.44) THEN
200 : C COQ2
201 : KQUAD(ITYP)=.FALSE.
202 : KCOQ(ITYP) =.TRUE.
203 : ELSEIF (NEFMOD.EQ.3) THEN
204 : C SEG3
205 : KQUAD(ITYP)=.TRUE.
206 : KCOQ(ITYP) =.FALSE.
207 : ELSE
207 : CALL ERREUR(16)
208 : RETURN
209 : ENDIF
210 : C
211 : ELSE
211 : CALL ERREUR(14)
212 : RETURN
213 : ENDIF
214 :
215 : SEGDES IMODEL
216 :
217 : 10 CONTINUE
218 :
219 : SEGDES INFOEL
220 : SEGDES MYMOD
221 : C
222 : C
223 : C ----------------------------------------------------
224 : C Orientation vers les différents sous-programmes
225 : C
226 : IF (IFOMOD.NE.0) THEN
227 : C On n'est pas en mode axisymétrique
228 : C
229 : IF (MCVX.AND.(.NOT.MSYM)) THEN
230 : C on n'a recu que CVXE
231 : GOTO 100
232 : ELSEIF (MSYM) THEN
233 : C il faut lire des points pour le cas général
234 : GOTO 200
235 : ELSE
236 : C cas général
237 : GOTO 210
238 : ENDIF
239 : C
240 : ELSE
241 : C On est en mode axisymétrique
242 : GOTO 300
243 : C
244 : ENDIF
245 : C
246 : C**********************************************************
247 : C
248 : C
249 : C
250 : C********************
251 : C CAS CONVEXE
252 : C********************
253 : C
253 : 100 CALL LIRENT(INT1,0,IRETOU)
254 : IF (IRETOU.NE.0) THEN
255 : INT=INT1
256 : ELSE
257 : INT=3
258 : ENDIF
259 : * write(6,*) ' int ', int
259 : CALL FACCVX(MYMOD,INFOEL,INT,ICHFAC)
260 :
261 : GOTO 900
262 : C
263 : C
264 : C********************
265 : C CAS GENERAL
266 : C********************
267 : C
268 : C----cas avec 'SYME' => lecture des points
269 : C
270 : 200 segact imodel
271 : ip1 = ivamod(3)
272 : ip2 = ivamod(4)
273 : NBE = IDIM
274 : SEGINI ,IAXE
275 : IAXE.LECT(1) = IP1
276 : IAXE.LECT(2) = IP2
277 : IF (IDIM.EQ.3) THEN
278 : ip3=ivamod(5)
279 : iaxe.lect(3)=ip3
280 : ENDIF
281 : SEGDES IAXE,imodel
282 : C
283 : C----suite du cas général
284 : C
284 : 210 CALL LIRENT(INT1,0,IRETOU)
285 : IF (IRETOU.NE.0) THEN
286 : IF(IDIM.EQ.3) THEN
287 : LRES=MIN0(INT1,100)
288 : ELSE
289 : LRES=MIN0(INT1,1000)
290 : ENDIF
291 : ELSE
292 : IF(IDIM.EQ.3) THEN
293 : LRES=50
294 : ELSE
295 : LRES=200
296 : ENDIF
297 : ENDIF
298 : * write(6,*) ' lres ' , lres
299 :
300 :
301 : * IF (MABS) THEN
301 : * CALL LIRREE(FLO2,0,IRETO2)
301 : * CALL LIRREE(FLO1,0,IRETOU)
302 :
303 : * IF(FLO2.LT.(-1.D-5)) THEN
304 : * EXTINC = -FLO2
305 : * ELSE
306 : * EXTINC = -FLO1
307 : * FLO1 = FLO2
308 : * IRETOU=IRETO2
309 : * ENDIF
310 :
311 : * ELSE
311 : * CALL LIRREE(FLO1,0,IRETOU)
312 : * ENDIF
313 :
314 : IF (IRETOU.NE.0) THEN
315 : IF(IDIM.EQ.3) THEN
316 : XDEC=DMIN1(FLO1,2.D0)
317 : ELSE
318 : XDEC=DMIN1(FLO1,10.D0)
319 : ENDIF
320 : ELSE
321 : IF(IDIM.EQ.3) THEN
322 : XDEC=0.5
323 : ELSE
324 : XDEC=5.D0
325 : ENDIF
326 : ENDIF
327 : * write(6,*) ' xdec ' , xdec
328 : C
329 : C
330 : IF (IDIM.EQ.3) THEN
331 : * write(6,*) ' appel a facgen'
332 : * write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
332 : CALL FACGEN(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
333 : ELSE
334 : * write(6,*) ' appel a facge2'
335 : * write(6,*) LRES,XDEC,IAXE,KNOR,EXTINC
336 : * write(6,*) ( kcoq(iou),kquad(iou),iou=1,kcoq(/1))
337 :
337 : CALL FACGE2(MYMOD,INFOEL,LRES,XDEC,IAXE,KNOR,ICHFAC,EXTINC)
338 : ENDIF
339 : IF (IAXE.NE.0) SEGSUP IAXE
340 : C
341 : GOTO 900
342 : C
343 : C********************
344 : C CAS AXISYMETRIQUE
345 : C********************
346 : C
347 :
348 : 300 CONTINUE
349 :
350 : C valeurs par defaut
351 :
352 : NGAX=10
353 : NPAX=20
354 :
354 : CALL LIRENT(INT1,0,IRETO1)
354 : CALL LIRENT(INT2,0,IRETO2)
355 :
356 : IF (IRETO2.NE.0) THEN
357 : NGAX = MIN0(INT1,10)
358 : NPAX = MIN0(INT2,1000)
359 : ELSEIF (MGAUS) THEN
360 : NPAX = MIN0(INT1,1000)
361 : ELSEIF (IRETO1.NE.0) THEN
362 : NGAX=MIN0(INT1,10)
363 : ENDIF
364 :
365 : C WRITE(6,*) ' FFOR NG NP ',NGAX,NPAX
366 :
367 : IF (MCVX) THEN
368 : KACHE = 0
369 : ELSE
370 : KACHE = 1
371 : ENDIF
372 : C
373 : IF(MABS) THEN
373 : CALL LIRREE(FLO1,0,IRETOU)
374 : IF (IRETOU.NE.0) THEN
375 : EXTINC=-FLO1
376 : ENDIF
377 : ENDIF
378 :
378 : CALL FACAXI(MYMOD,INFOEL,NPAX,NGAX,KACHE,KNOR,ICHFAC,EXTINC)
379 : C
380 : C
381 : C**********************************************************
382 : C
383 : C
384 : 900 SEGSUP ,INFOEL
385 : segact mymod
386 : mchelm=ICHFAC
387 : segact mchelm*mod
388 : do i=1,mymod.kmodel(/1)
389 : imodel=mymod.kmodel(i)
390 : segact imodel
391 : conche(i)=conmod
392 : segdes imodel
393 : enddo
394 : segdes mchelm
395 : segdes mymod
396 : C Ecriture du chamelem facteur de forme
396 : * CALL ECROBJ('MCHAML',ICHFAC)
397 : RETURN
398 : END
399 :
400 :
401 :
402 :
403 :
404 :
405 :
406 :
407 :
408 :
409 :
410 :
411 :
© Cast3M 2003 - All rights reserved.
Disclaimer