1 : C SORAVS SOURCE JC220346 12/06/18 21:15:17 7403
2 : SUBROUTINE SORAVS
3 : ************************************************************************
4 : * NOM : soravs.eso
5 : * DESCRIPTION : Sortie d'un CHPOINT et/ou d'un MCHAML (s'appuyant au
6 : C centres de gravité des éléments) avec le maillage
7 : C support au format AVS (Unstructured Cell Data, ASCII)
8 : ************************************************************************
9 : * HISTORIQUE : 25/11/1994 : BULIK : création de la subroutine
10 : * HISTORIQUE : 22/09/1995 : BULIK : ajout des options SUIT et TEMP
11 : * HISTORIQUE : 21/12/1998 : COURTOIS : modif des sorties pour maillage
12 : * HISTORIQUE : 12/02/2010 : GOUNAND : evite l'impression de *******
13 : * HISTORIQUE : 7/06/2012 : JCARDO : ajout de l'extension .inp
14 : * + fermeture du fichier
15 : * HISTORIQUE :
16 : ************************************************************************
17 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
18 : * en cas de modification de ce sous-programme afin de faciliter
19 : * la maintenance !
20 : ************************************************************************
21 : * APPELÉ PAR : opérateur SORTir (prsort.eso)
22 : ************************************************************************
23 : * ENTRÉES :: aucune
24 : * SORTIES :: aucune (sur fichier uniquement)
25 : ************************************************************************
26 : * SYNTAXE (GIBIANE) :
27 : *
28 : * SORT 'AVS' (MAIL1) (CHPO1) (CHML1) ('SUIT') ('TEMP' FLOT1) ;
29 : *
30 : ************************************************************************
31 : IMPLICIT INTEGER(I-N)
32 : PARAMETER(NBMCLE=2)
33 : CHARACTER*4 MTSCLE(NBMCLE)
34 :
35 : -INC CCOPTIO
36 : -INC SMCOORD
37 : -INC SMELEME
38 : -INC SMCHPOI
39 : -INC SMCHAML
40 : -INC SMLMOTS
41 :
42 : EXTERNAL LONG
43 :
44 : POINTEUR MAPOIN.MELEME, MAELEM.MELEME
45 : POINTEUR IPT10.MELEME, IPT11.MELEME
46 :
47 : POINTEUR NCMCHA.MLMOTS, NCCHPO.MLMOTS
48 :
49 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50 : C
51 : SEGMENT VALMCH
52 : REAL*8 RVAMCH(NBCMCH,NELMAI)
53 : END SEGMENT
54 : C
55 : C Segment : VALeurs du MCHaml
56 : C
57 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
58 :
59 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
60 : C
61 : SEGMENT VALCHP
62 : REAL*8 RVACHP(NBCCHP,NBNMAP)
63 : END SEGMENT
64 : C
65 : C Segment : VALeurs du CHPoint
66 : C
67 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
68 :
69 : SEGMENT IEQUIV
70 : INTEGER LEQUIV(IECART)
71 : END SEGMENT
72 :
73 : CHARACTER*8 MTYP
74 : CHARACTER*4 NOM4
75 :
76 : REAL*8 VALTEM
77 :
78 : LOGICAL SORMAI, SORCHP, SORMCH, EXISEL, CNDTN
79 :
80 : LOGICAL CMPINT
81 : EXTERNAL CMPINT
82 :
83 : DATA MTSCLE/'SUIT','TEMP'/
84 :
85 : CHARACTER*256 FICAVS
86 : LOGICAL ZOPEN
87 :
88 : NCCHPO=0
89 : NCMCHA=0
90 : VALCHP=0
91 : VALMCH=0
92 : IEQUIV=0
93 :
94 : SORMAI=.FALSE.
95 : SORCHP=.FALSE.
96 : SORMCH=.FALSE.
97 :
98 : C ... Recherche des objets à sortir ...
99 :
99 : CALL LIROBJ('MAILLAGE',IVAL,0,IRETOU)
100 : IF(IRETOU.EQ.1) THEN
101 :
102 : MELEME=IVAL
103 : SORMAI=.TRUE.
104 :
105 : MAELEM=MELEME
106 : EXISEL=.TRUE.
107 :
108 : MAPOIN=MAELEM
108 : CALL CHANGE(MAPOIN,1)
109 : C ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
110 :
111 : ENDIF
112 :
112 : CALL LIROBJ('MCHAML ',IVAL,0,IRETOU)
113 : IF(IRETOU.EQ.1) THEN
114 :
115 : MCHELM=IVAL
116 : SORMCH=.TRUE.
117 :
118 : IF(.NOT.SORMAI) THEN
118 : CALL ECRCHA('MAIL')
118 : CALL ECROBJ('MCHAML ',MCHELM)
118 : CALL EXTRAI
118 : CALL LIROBJ('MAILLAGE',MAELEM,1,IRETOU)
119 : IF(IERR.NE.0) GOTO 9999
120 : EXISEL=.TRUE.
121 :
122 : MAPOIN=MAELEM
122 : CALL CHANGE(MAPOIN,1)
123 : C ... Attention ! MAPOIN est déjà actif (voir CHANGE) ...
124 : ENDIF
125 :
126 : ENDIF
127 :
127 : CALL LIROBJ('CHPOINT ',IVAL,0,IRETOU)
128 : IF(IRETOU.EQ.1) THEN
129 : MCHPOI=IVAL
130 : SORCHP=.TRUE.
131 :
132 : IF((.NOT.SORMAI).AND.(.NOT.SORMCH)) THEN
133 : MAELEM=0
134 : EXISEL=.FALSE.
135 :
135 : CALL ECRCHA('MAIL')
135 : CALL ECROBJ('CHPOINT ',MCHPOI)
135 : CALL EXTRAI
135 : CALL LIROBJ('MAILLAGE',MAPOIN,1,IRETOU)
136 : IF(IERR.NE.0) GOTO 9999
137 : SEGACT MAPOIN
138 : ENDIF
139 :
140 : ENDIF
141 :
142 : IF((.NOT.SORMAI).AND.(.NOT.SORMCH).AND.(.NOT.SORCHP)) THEN
142 : CALL ERREUR(704)
143 : RETURN
144 : ENDIF
145 :
146 : C ... Lecture des mots clés éventuels ...
147 :
148 : NBCGLO=0
149 : INOREW=0
150 :
150 : 10 CALL LIRMOT(MTSCLE,NBMCLE,IRAN,0)
151 :
152 : IF(IRAN.EQ.1) INOREW=1
153 :
154 : IF(IRAN.EQ.2) THEN
155 : NBCGLO=1
155 : CALL LIRREE(VALTEM,1,IRETOU)
156 : IF(IERR.NE.0) GOTO 9999
157 : cdebug write(*,*) 'Le temps lu = ',VALTEM
158 : ENDIF
159 :
160 : IF(IRAN.NE.0) GOTO 10
161 :
162 : C ... NELMAI = Nombre d'ÉLéments du MAIllage ...
163 : IF(EXISEL) THEN
163 : CALL ECROBJ('MAILLAGE',MAELEM)
163 : CALL NBEL
163 : CALL LIRENT(NELMAI,1,IRETOU)
164 : IF(IERR.NE.0) GOTO 9999
165 : ELSE
166 : NELMAI=0
167 : ENDIF
168 :
169 : C ... NBNMAP = NomBre de Noeuds du MAPoin ...
169 : CALL ECROBJ('MAILLAGE',MAPOIN)
169 : CALL NBNO
169 : CALL LIRENT(NBNMAP,1,IRETOU)
170 : IF(IERR.NE.0) GOTO 9999
171 :
172 : C ... Si le MAILLAGE et le MCHAML sont donnés, on vérifiera que le
173 : C MAILLAGE est un sous-ensemble du support du MCHAML ...
174 :
175 : IF(SORMAI.AND.SORMCH) THEN
176 :
177 : C ... IPT1 = support du MCHAML ...
177 : CALL ECRCHA('MAIL')
177 : CALL ECROBJ('MCHAML ',MCHELM)
177 : CALL EXTRAI
177 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
178 : IF(IERR.NE.0) GOTO 9999
179 :
179 : CALL ECROBJ('MAILLAGE',IPT1)
179 : CALL NBEL
179 : CALL LIRENT(NELSMC,1,IRETOU)
180 : IF(IERR.NE.0) GOTO 9999
181 :
182 : C ... IPT2 = intersection du MAILLAGE et du support du MCHAML ...
183 : C Si les deux sont distincts, INTERS sortira une ERREUR,
184 : C on commence donc par une différence symétrique :
185 : C si sa taille = NELMAI + NELSMC, ils sont distincts ...
186 : C ... Le problème est que lorsque les deux sont égaux, PRDIFF
187 : C se plante car il ne veut pas sortir un maillage nul,
188 : C il lui manque une option NOVERIF. On commence donc par vérifier
189 : C si les deux nombres d'éléments sont égaux - si OUI, un danger
190 : C guette, on va donc regarder ça de plus près, sinon PRDIFF etc ...
191 : C ... CNDTN est un logique qui décrit l'égalité des deux maillages ...
192 : IF(NELMAI.EQ.NELSMC) THEN
193 : SEGACT MAELEM
194 : SEGACT IPT1
195 : NBEL1=MAELEM.NUM(/2)
196 : NBEL2= IPT1.NUM(/2)
197 : IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
198 : C ... Le cas où les deux maillages sont simples ...
199 : NBNN1=MAELEM.NUM(/1)
200 : NBNN2= IPT1.NUM(/1)
201 : IF((NBNN1.EQ.NBNN2).AND.(MAELEM.ITYPEL.EQ.IPT1.ITYPEL))
202 : & THEN
203 : ILONG=NBEL1*NBNN1
204 : CNDTN=CMPINT(MAELEM.NUM(1,1),IPT1.NUM(1,1),ILONG)
205 : ELSE
206 : CNDTN=.FALSE.
207 : ENDIF
208 : ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
209 : C ... Le cas où les deux maillages sont composés ...
210 : NBS1=MAELEM.LISOUS(/1)
211 : NBS2= IPT1.LISOUS(/1)
212 : IF(NBS1.EQ.NBS2) THEN
213 : CNDTN=.TRUE.
214 : DO 1100 I=1,NBS1
215 : IPT10=MAELEM.LISOUS(I)
216 : IPT11= IPT1.LISOUS(I)
217 : SEGACT IPT10
218 : SEGACT IPT11
219 : IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
220 : & (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
221 : & (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
222 : ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
223 : CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
224 : & IPT11.NUM(1,1),ILONG)
225 : ELSE
226 : CNDTN=.FALSE.
227 : ENDIF
228 : SEGDES IPT10
229 : SEGDES IPT11
230 : 1100 CONTINUE
231 : ELSE
232 : CNDTN=.FALSE.
233 : ENDIF
234 : ELSE
235 : C ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
236 : C probable quoique pas exclu que les deux maillages soient
237 : C égaux, on met donc CoNDiTioN à FAUX ...
238 : CNDTN=.FALSE.
239 : ENDIF
240 : SEGDES MAELEM
241 : SEGDES IPT1
242 : ELSE
243 : CNDTN=.FALSE.
244 : ENDIF
245 :
246 : IF(CNDTN) THEN
247 : NELDS=0
248 : ELSE
248 : CALL ECROBJ('MAILLAGE',MAELEM)
248 : CALL ECROBJ('MAILLAGE',IPT1)
248 : CALL PRDIFF
248 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
249 : IF(IERR.NE.0) GOTO 9999
250 :
250 : CALL ECROBJ('MAILLAGE',IPT2)
250 : CALL NBEL
250 : CALL LIRENT(NELDS,1,IRETOU)
251 : IF(IERR.NE.0) GOTO 9999
252 : ENDIF
253 :
254 : IF(NELDS.EQ.NELMAI+NELSMC) THEN
255 : IPT2=0
256 : NELINT=0
257 : ELSE
257 : CALL ECROBJ('MAILLAGE',MAELEM)
257 : CALL ECROBJ('MAILLAGE',IPT1)
257 : CALL INTERS
257 : CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
258 : IF(IERR.NE.0) GOTO 9999
259 :
260 : C ... NELINT = nombre d'éléments de l'INTersection IPT2 ...
260 : CALL ECROBJ('MAILLAGE',IPT2)
260 : CALL NBEL
260 : CALL LIRENT(NELINT,1,IRETOU)
261 : IF(IERR.NE.0) GOTO 9999
262 : ENDIF
263 :
264 : C ... S'il n'y pas égalité, MAILLAGE n'est pas un sous ensemble ...
265 : IF(NELINT.NE.NELMAI) THEN
265 : CALL ERREUR(706)
266 : GOTO 10000
267 : ENDIF
268 :
269 : C ... Maintenant on réduit le MCHAML su MELEME pour être sûr de
270 : C l'ordre des éléments ...
270 : CALL REDUIC(MCHELM,MELEME,IRETOU)
271 : IF(IRETOU.EQ.0) THEN
272 : GOTO 9999
273 : ELSE
274 : MCHELM=IRETOU
275 : ENDIF
276 :
277 : C ... Maintenant MCHELM est consistant avec MAELEM et MAPOIN ...
278 : C ... Il reste deux maillages comme effet (IPT1, IPT2) ...
279 :
280 : ENDIF
281 :
282 : C ... Si le MAILLAGE (ou MCHAML) et le CHPOINT sont présents, on vérifiera que
283 : C le MAILLAGE et le support du CHPOINT ont une partie commune ...
284 :
285 : IF((SORMAI.OR.SORMCH).AND.SORCHP) THEN
286 :
287 : C ... IPT3 = support du CHPOINT ...
287 : CALL ECRCHA('MAIL')
287 : CALL ECROBJ('CHPOINT ',MCHPOI)
287 : CALL EXTRAI
287 : CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU)
288 : IF(IERR.NE.0) GOTO 9999
289 :
290 : C ... NNSCHP = Nombre de Noeuds du Support du CHPoint ...
290 : CALL ECROBJ('MAILLAGE',IPT3)
290 : CALL NBNO
290 : CALL LIRENT(NNSCHP,1,IRETOU)
291 : IF(IERR.NE.0) GOTO 9999
292 :
293 : C ... Pour les explications de cette partie voir la partie
294 : C équivalente ci-dessus, au niveau du traitement du MCHAML ...
295 : IF(NBNMAP.EQ.NNSCHP) THEN
296 : SEGACT MAPOIN
297 : SEGACT IPT3
298 : NBEL1=MAPOIN.NUM(/2)
299 : NBEL2= IPT3.NUM(/2)
300 : IF(NBEL1.EQ.NBEL2 .AND. NBEL1.GT.0) THEN
301 : C ... Le cas où les deux maillages sont simples ...
302 : NBNN1=MAPOIN.NUM(/1)
303 : NBNN2= IPT3.NUM(/1)
304 : IF((NBNN1.EQ.NBNN2).AND.(MAPOIN.ITYPEL.EQ.IPT3.ITYPEL))
305 : & THEN
306 : ILONG=NBEL1*NBNN1
307 : CNDTN=CMPINT(MAPOIN.NUM(1,1),IPT3.NUM(1,1),ILONG)
308 : ELSE
309 : CNDTN=.FALSE.
310 : ENDIF
311 : ELSE IF(NBEL1.EQ.NBEL2 .AND. NBEL1.EQ.0) THEN
312 : C ... Le cas où les deux maillages sont composés ...
313 : NBS1=MAPOIN.LISOUS(/1)
314 : NBS2= IPT3.LISOUS(/1)
315 : IF(NBS1.EQ.NBS2) THEN
316 : CNDTN=.TRUE.
317 : DO 1200 I=1,NBS1
318 : IPT10=MAPOIN.LISOUS(I)
319 : IPT11= IPT3.LISOUS(I)
320 : SEGACT IPT10
321 : SEGACT IPT11
322 : IF((IPT10.NUM(/1).EQ.IPT11.NUM(/1)) .AND.
323 : & (IPT10.NUM(/2).EQ.IPT11.NUM(/2)) .AND.
324 : & (IPT10.ITYPEL .EQ.IPT11.ITYPEL) ) THEN
325 : ILONG=IPT10.NUM(/1)*IPT10.NUM(/2)
326 : CNDTN=CNDTN.AND.CMPINT(IPT10.NUM(1,1),
327 : & IPT11.NUM(1,1),ILONG)
328 : ELSE
329 : CNDTN=.FALSE.
330 : ENDIF
331 : SEGDES IPT10
332 : SEGDES IPT11
333 : 1200 CONTINUE
334 : ELSE
335 : CNDTN=.FALSE.
336 : ENDIF
337 : ELSE
338 : C ... Dans le cas où NBEL1 n'est pas egal à NBEL2 il est peu
339 : C probable quoique pas exclu que les deux maillages soient
340 : C égaux, on met donc CoNDiTioN à FAUX ...
341 : CNDTN=.FALSE.
342 : ENDIF
343 : SEGDES MAPOIN
344 : SEGDES IPT3
345 : ELSE
346 : CNDTN=.FALSE.
347 : ENDIF
348 :
349 : IF(CNDTN) THEN
350 : NNDS=0
351 : ELSE
352 : C ... IPT4 = ici à la différence symétrique du MAPOIN et du support du CHPOINT ...
352 : CALL ECROBJ('MAILLAGE',MAPOIN)
352 : CALL ECROBJ('MAILLAGE',IPT3)
352 : CALL PRDIFF
352 : CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
353 : IF(IERR.NE.0) GOTO 9999
354 :
354 : CALL ECROBJ('MAILLAGE',IPT4)
354 : CALL NBNO
354 : CALL LIRENT(NNDS,1,IRETOU)
355 : IF(IERR.NE.0) GOTO 9999
356 : ENDIF
357 :
358 : C ... IPT4 = intersection du MAPOIN et du support du CHPOINT ...
359 : IF(NNDS.EQ.NBNMAP+NNSCHP) THEN
360 : IPT4=0
361 : NBNIN4=0
362 : ELSE
362 : CALL ECROBJ('MAILLAGE',MAPOIN)
362 : CALL ECROBJ('MAILLAGE',IPT3)
362 : CALL INTERS
362 : CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU)
363 : IF(IERR.NE.0) GOTO 9999
364 :
365 : C ... NBNIN4 = NomBre de Noeuds de l'INtersection ipt4 ...
365 : CALL ECROBJ('MAILLAGE',IPT4)
365 : CALL NBNO
365 : CALL LIRENT(NBNIN4,1,IRETOU)
366 : IF(IERR.NE.0) GOTO 9999
367 : ENDIF
368 :
369 : IF(NBNIN4.EQ.0) THEN
370 : C ... Quand NBNIN4=0 -> cas No 1 ...
371 : SORCHP=.FALSE.
371 : CALL ERREUR(-297)
371 : CALL ERREUR(-296)
372 : ELSE IF(NBNIN4.EQ.NBNMAP) THEN
373 : C ... Si NBNIN4=NBNMAP (cas 2), il faut réduire le CHPOINT sur le maillage ...
373 : CALL REDUIR(MCHPOI,MAPOIN,IRETOU)
374 : IF(IRETOU.EQ.0) THEN
375 : GOTO 9999
376 : ELSE
377 : MCHPOI=IRETOU
378 : ENDIF
379 : ELSE IF (NBNIN4.EQ.NNSCHP) THEN
380 : C ... Cas No 4 - le support du CHPOINT est entièrement contenu dans le
381 : C maillage, donc on ne fait rien ...
382 : ELSE
383 : C ... Sinon, c'est le cas 3, il faut donc "aggrandir" le CHPOINT,
384 : C en fait on va le réduire sur l'intersection IPT4, ceci pour
385 : C éliminer les composantes dont le support est en dehors du maillage ...
385 : CALL REDUIR(MCHPOI,IPT4,IRETOU)
386 : IF(IRETOU.EQ.0) THEN
387 : GOTO 9999
388 : ELSE
389 : MCHPOI=IRETOU
390 : ENDIF
391 : ENDIF
392 :
393 : ENDIF
394 :
395 : C ... Puisqu'on ne sort que certains noeuds il faut transformer les
396 : C connectivités, pour ceci on se servira du SEGMENT IEQUIV ...
397 :
398 : C ... Recherche des numéros maxi et mini des noeuds dont on a besoin ...
399 :
400 : SEGACT MAPOIN
401 : NBELEM=MAPOIN.NUM(/2)
402 : NBNN=MAPOIN.NUM(/1)
403 : IF(NBELEM.EQ.NBNMAP) THEN
404 :
405 : IF(NBNN.NE.1) GOTO 9999
406 : IPTMIN=MAPOIN.NUM(1,1)
407 : IPTMAX=MAPOIN.NUM(1,1)
408 : DO 1500 I=1,NBELEM
409 : IF(MAPOIN.NUM(1,I).LT.IPTMIN) IPTMIN=MAPOIN.NUM(1,I)
410 : IF(MAPOIN.NUM(1,I).GT.IPTMAX) IPTMAX=MAPOIN.NUM(1,I)
411 : 1500 CONTINUE
412 :
413 : ELSE IF(NBELEM.EQ.0) THEN
414 :
415 : NBSOUS=MAPOIN.LISOUS(/1)
416 : DO 1505 I=1,NBSOUS
417 : IPT5=LISOUS(I)
418 : SEGACT IPT5
419 : NBNTMP=IPT5.NUM(/1)
420 : NBETMP=IPT5.NUM(/2)
421 : IF(NBNTMP.NE.1) GOTO 9999
422 : IF(I.EQ.1) THEN
423 : IPTMIN=IPT5.NUM(1,1)
424 : IPTMAX=IPT5.NUM(1,1)
425 : ENDIF
426 : DO 1506 J=1,NBETMP
427 : IF(IPT5.NUM(1,J).LT.IPTMIN) IPTMIN=IPT5.NUM(1,J)
428 : IF(IPT5.NUM(1,J).GT.IPTMAX) IPTMAX=IPT5.NUM(1,J)
429 : 1506 CONTINUE
430 : SEGDES IPT5
431 : 1505 CONTINUE
432 :
433 : ENDIF
434 :
435 : C ... Initialisation du segment IEQUIV ...
436 :
437 : IECART=IPTMAX-IPTMIN+1
438 : SEGINI IEQUIV
439 :
440 : C ... et son remplissage ...
441 :
442 : IF(NBELEM.EQ.NBNMAP) THEN
443 :
444 : DO 1510 I=1,NBELEM
445 : LEQUIV(MAPOIN.NUM(1,I)-IPTMIN+1)=I
446 : 1510 CONTINUE
447 :
448 : ELSE IF(NBELEM.EQ.0) THEN
449 :
450 : NBSOUS=MAPOIN.LISOUS(/1)
451 : K=0
452 : DO 1515 I=1,NBSOUS
453 : IPT5=LISOUS(I)
454 : SEGACT IPT5
455 : NBNTMP=IPT5.NUM(/1)
456 : NBETMP=IPT5.NUM(/2)
457 : IF(NBNTMP.NE.1) GOTO 9999
458 : DO 1516 J=1,NBETMP
459 : K=K+1
460 : C ... Ici je suppose que chaque point n'est représenté qu'une
461 : C seule fois dans MAPOIN. En conséquence, dans la ligne en dessous
462 : C je n'ai pas mis de test si LEQUIV(IPT5.NUM(1,J)-IPTMIN+1) est
463 : C différent de zéro ...
464 : LEQUIV(IPT5.NUM(1,J)-IPTMIN+1)=K
465 : 1516 CONTINUE
466 : SEGDES IPT5
467 : 1515 CONTINUE
468 :
469 : ENDIF
470 :
471 : C ... Préparation de la première ligne du fichier AVS, on connaît déjà
472 : C les nombres de noeuds et d'éléments, il manque les nombres de composantes
473 : C du CHPOINT et du MCHAML (s'ils sont présents) ...
474 :
475 : C ... On commence par le MCHAML ...
476 : IF(SORMCH) THEN
476 : CALL EXTR17(MCHELM,NCMCHA)
477 : SEGACT NCMCHA
478 : NBCMCH=NCMCHA.MOTS(/2)
479 : ccc SEGDES NCMCHA
480 : ELSE
481 : NBCMCH=0
482 : ENDIF
483 :
484 : C ... Et ensuite c'est le tour du CHPOINT ...
485 : IF(SORCHP) THEN
485 : CALL EXTR11(MCHPOI,NCCHPO)
486 : SEGACT NCCHPO
487 : NBCCHP=NCCHPO.MOTS(/2)
488 : ccc SEGDES NCCHPO
489 : ELSE
490 : NBCCHP=0
491 : ENDIF
492 :
493 : C ... Maintenant on va remplir des segments contenant toutes les valeurs
494 : C et composantes du MCHAML et du CHPOINT en un seul morceau ...
495 :
496 : C ... On commence par le MCHAML ...
497 : C ... On va vérifier aussi qu'il y a une seule valeur par élément ...
498 : IF(SORMCH) THEN
499 : C ... On ne le met pas à zero car toutes les cases vont etre remplies ...
500 : SEGINI VALMCH
501 : SEGACT MCHELM
502 : N1=ICHAML(/1)
503 : C ... IDECNE = DECalage des Numéros d'Eléments ...
504 : IDECNE=0
505 : C ... Boucle sur les zones élémentaires, dont chacune possède son ...
506 : DO 1600 I=1,N1
507 : C ... segment MCHAML ...
508 : MCHAML=ICHAML(I)
509 : SEGACT MCHAML
510 : N2=IELVAL(/1)
511 : C ... et le maillage support ...
512 : IPT6=IMACHE(I)
512 : CALL ECROBJ('MAILLAGE',IPT6)
512 : CALL NBEL
512 : CALL LIRENT(NELSMC,1,IRETOU)
513 : IF(IERR.NE.0) GOTO 9999
514 : C ... Boucle sur les composantes du MCHAML ...
515 : DO 1610 J=1,N2
516 : IF(TYPCHE(J).NE.'REAL*8 ') THEN
517 : MOTERR(1:8)=NOMCHE(J)
517 : CALL ERREUR(679)
518 : GOTO 10000
519 : ENDIF
520 : C ... Maintenant on cherche la position du nom de la composante No J
521 : C dans NCMCHA ...
522 : WRITE(NOM4,'(A4)') NOMCHE(J)
523 : DO 1620 K=1,NBCMCH
524 : IF(NCMCHA.MOTS(K).EQ.NOM4) GOTO 1630
525 : 1620 CONTINUE
526 : 1630 CONTINUE
527 : C ... K est maintenant le numéro de la composante J dans NCMCHA ...
528 : MELVAL=IELVAL(J)
529 : SEGACT MELVAL
530 : N1PTEL=VELCHE(/1)
531 : N1EL =VELCHE(/2)
532 : IF(N1PTEL.NE.1) THEN
532 : CALL ERREUR(707)
533 : GOTO 10000
534 : ENDIF
535 : C ... Si N1EL==1 c'est un champ constant ...
536 : IF(N1EL.EQ.1) THEN
537 : DO 1680 L=1,NELSMC
538 : RVAMCH(K,L+IDECNE)=VELCHE(1,1)
539 : 1680 CONTINUE
540 : ELSE IF(N1EL.EQ.NELSMC) THEN
541 : DO 1660 L=1,NELSMC
542 : RVAMCH(K,L+IDECNE)=VELCHE(1,L)
543 : 1660 CONTINUE
544 : ELSE
545 : MOTERR(1:8)='MCHAML '
545 : CALL ERREUR(708)
546 : GOTO 10000
547 : ENDIF
548 : SEGDES MELVAL
549 : 1610 CONTINUE
550 : IDECNE=IDECNE+NELSMC
551 : SEGDES MCHAML
552 : 1600 CONTINUE
553 : SEGDES MCHELM
554 : ENDIF
555 :
556 : C ... Remplissage des valeurs du CHPOINT ...
557 : IF(SORCHP) THEN
558 :
559 : SEGINI VALCHP
560 : CDEBUG WRITE(IOIMP,*) 'NBCCHP = ',NBCCHP
561 : CDEBUG WRITE(IOIMP,*) 'NBNMAP = ',NBNMAP
562 : DO 1700 I=1,NBCCHP
563 : DO 1700 J=1,NBNMAP
564 : RVACHP(I,J)=0.D0
565 : 1700 CONTINUE
566 :
567 : SEGACT MCHPOI
568 : NSOUPO=IPCHP(/1)
569 : C ... IDECNP = DECalage des Numéros de Points ...
570 : C inutile IDECNP=0
571 : C ... Boucle sur les sous-zones du CHPOINT dont chacune est définie par ...
572 : DO 1710 I=1,NSOUPO
573 : C ... un segment MSOUPO ...
574 : CDEBUG WRITE(IOIMP,*) 'Sous-zone No ',I
575 : MSOUPO=IPCHP(I)
576 : SEGACT MSOUPO
577 : NC=NOHARM(/1)
578 : C ... son support géométrique ...
579 : IPT7=IGEOC
579 : CALL NOMOBJ('MAILLAGE','MASUPCHP',IPT7)
579 : CALL ECROBJ('MAILLAGE',IPT7)
579 : CALL NBNO
579 : CALL LIRENT(NPOSCH,1,IRETOU)
580 : IF(IERR.NE.0) GOTO 9999
581 : SEGACT IPT7
582 : CDEBUG WRITE(IOIMP,*) ' -> ',NPOSCH,' noeuds'
583 : CDEBUG WRITE(IOIMP,*) 'IPT7 : ITYPEL = ',IPT7.ITYPEL
584 : CDEBUG WRITE(IOIMP,*) 'IPT7 : NBELEM = ',IPT7.NUM(/2)
585 : C ... et ses valeurs ...
586 : MPOVAL=IPOVAL
587 : SEGACT MPOVAL
588 : N=VPOCHA(/1)
589 : IF(N.NE.NPOSCH) THEN
590 : MOTERR(1:8)='CHPOINT '
590 : CALL ERREUR(708)
591 : GOTO 10000
592 : ENDIF
593 : C ... Boucle sur les composantes du CHPOINT ...
594 : DO 1720 J=1,NC
595 : C ... dont on cherche la place dans NCCHPO ...
596 : WRITE(NOM4,'(A4)') NOCOMP(J)
597 : DO 1730 K=1,NBCCHP
598 : IF(NCCHPO.MOTS(K).EQ.NOM4) GOTO 1740
599 : 1730 CONTINUE
600 : 1740 CONTINUE
601 : C ... Maintenant K pointe le NOCOMP(J) dans NCCHPO ...
602 : CDEBUG WRITE(IOIMP,*) 'Composante No',J,' correspond à K = ',K
603 : C ... Maintenant il faut parcourir les noeuds du support du CHPOINT ...
604 : C ... Si ce support est un maillage élémentaire, ceci est simple ...
605 : IF(IPT7.NUM(/2).GT.0) THEN
606 : CDEBUG WRITE(IOIMP,*) 'Support = Maillage élémentaire'
607 : DO 1750 L=1,N
608 : C ... ça ne marchera pas dans le cas général, car l'ordre des n'est pas
609 : C forcément le meme dans le MAPOIN et dans le support du CHPOINT ...
610 : C RVACHP(K,L+IDECNP)=VPOCHA(L,J) ...
611 : C ... il faut chercher la position du noeud ...
612 : NNSCHP=IPT7.NUM(1,L)
613 : IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
614 : NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
615 : ELSE
616 : NNMAPO=0
617 : ENDIF
618 : CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
619 : IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
620 : 1750 CONTINUE
621 : C ... Sinon on va s'amuser ...
622 : ELSE
623 : CDEBUG WRITE(IOIMP,*) 'Support = Maillage composé'
624 : L=0
625 : NBSOUS=IPT7.LISOUS(/1)
626 : DO 1765 M=1,NBSOUS
627 : IPT8=IPT7.LISOUS(M)
628 : SEGACT IPT8
629 : NBELEM=IPT8.NUM(/2)
630 : CDEBUG WRITE(IOIMP,*) 'IPT8 : ITYPEL = ',IPT8.ITYPEL
631 : CDEBUG WRITE(IOIMP,*) 'IPT8 : NBELEM = ',NBELEM
632 : DO 1770 MM=1,NBELEM
633 : L=L+1
634 : NNSCHP=IPT8.NUM(1,MM)
635 : IF(NNSCHP.GE.IPTMIN.AND.NNSCHP.LE.IPTMAX) THEN
636 : NNMAPO=LEQUIV(NNSCHP-IPTMIN+1)
637 : ELSE
638 : NNMAPO=0
639 : ENDIF
640 : CDEBUG WRITE(IOIMP,*) 'Noeud ',L,' = ',NNSCHP,' -> NNMAPO = ',NNMAPO
641 : IF(NNMAPO.NE.0) RVACHP(K,NNMAPO)=VPOCHA(L,J)
642 : 1770 CONTINUE
643 : SEGDES IPT8
644 : 1765 CONTINUE
645 : ENDIF
646 : 1720 CONTINUE
647 : C inutile IDECNP=IDECNP+NPOSCH
648 : SEGDES MPOVAL
649 : SEGDES MSOUPO
650 : SEGDES IPT7
651 : 1710 CONTINUE
652 : SEGDES MCHPOI
653 :
654 : ENDIF
655 :
656 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
657 : C ... Sortie au format AVS ...
658 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
659 :
660 :
661 : * Récupération du nom du fichier et ajout de l'extension au
662 : * nom du fichier
663 : INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
664 : IF (.NOT.ZOPEN) THEN
664 : CALL ERREUR(-212)
665 : WRITE(IOIMP,*) '(via OPTI "SORT")'
666 : MOTERR(1:8)='AVS '
666 : CALL ERREUR(705)
667 : RETURN
668 : ENDIF
669 :
670 : * Quel est le nom du fichier ouvert ?
671 : INQUIRE(UNIT=IOPER,NAME=NOMFIC)
672 :
673 : * Si pas d'extention .inp, on le réouvre
673 : CALL LENCHA(NOMFIC,LC)
674 : IF (NOMFIC(LC-3:LC).NE.'.inp') THEN
675 : CLOSE(UNIT=IOPER,STATUS='DELETE')
676 : WRITE(FICAVS,FMT='(A,A4)') NOMFIC(1:LONG(NOMFIC)),'.inp'
677 : IOS=0
678 : OPEN(UNIT=IOPER,STATUS='UNKNOWN',FILE=FICAVS(1:LONG(FICAVS)),
679 : & IOSTAT=IOS,FORM='FORMATTED')
680 : ENDIF
681 :
682 : * Pas d'option 'SUIT' => on rembobine
683 : IF (INOREW.EQ.0) REWIND IOPER
684 :
685 : C ... Ligne de tete ...
686 : WRITE(IOPER,4000) NBNMAP,NELMAI,NBCCHP,NBCMCH,NBCGLO
687 :
688 : C ... Les noeuds ...
689 : DO 2000 I=1,NBNMAP
690 : SEGACT MAPOIN
691 : NUMNO=MAPOIN.NUM(1,I)
692 : IF(IDIM.EQ.2) THEN
693 : WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
694 : & XCOOR((NUMNO-1)*(IDIM+1)+2),
695 : & 0.D0
696 : ELSE
697 : WRITE(IOPER,4010) I,XCOOR((NUMNO-1)*(IDIM+1)+1),
698 : & XCOOR((NUMNO-1)*(IDIM+1)+2),
699 : & XCOOR((NUMNO-1)*(IDIM+1)+3)
700 : ENDIF
701 : SEGDES MAPOIN
702 : 2000 CONTINUE
703 :
704 : C ... Le maillage ...
705 : IDECAL=0
706 : IF(EXISEL) THEN
707 : SEGACT MAELEM
708 : NBELEM=MAELEM.NUM(/2)
709 : IF(NBELEM.GT.0) THEN
709 : CALL AVSMEL(MAELEM,IDECAL,1,IEQUIV,IPTMIN)
710 : ELSE
711 : NBSOUS=MAELEM.LISOUS(/1)
712 : DO 2100 I=1,NBSOUS
713 : LESOUS=MAELEM.LISOUS(I)
713 : CALL AVSMEL(LESOUS,IDECAL,I,IEQUIV,IPTMIN)
714 : 2100 CONTINUE
715 : ENDIF
716 : SEGDES MAELEM
717 : ENDIF
718 :
719 : C ... Le CHPOINT ...
720 : IF(SORCHP) THEN
721 : C ... On commence par les noms des composantes ...
722 : WRITE(IOPER,4030) NBCCHP,(1,K=1,NBCCHP)
723 : C+DC
724 : DO 2101 I=1,NBCCHP
725 : WRITE(IOPER,4042) (NCCHPO.MOTS(I))
726 : 2101 CONTINUE
727 : C
728 : SEGSUP NCCHPO
729 :
730 : C ... Et ensuite leurs valeurs ...
731 : DO 2200 I=1,NBNMAP
732 : WRITE(IOPER,4050) I,(RVACHP(K,I),K=1,NBCCHP)
733 : 2200 CONTINUE
734 : SEGSUP VALCHP
735 : ENDIF
736 :
737 : C ... Le MCHAML ...
738 : IF(SORMCH) THEN
739 : C ... On commence par les noms des composantes ...
740 : WRITE(IOPER,4030) NBCMCH,(1,K=1,NBCMCH)
741 : WRITE(IOPER,4043) (NCMCHA.MOTS(I),I=1,NBCMCH)
742 : SEGSUP NCMCHA
743 :
744 : C ... Et ensuite leurs valeurs ...
745 : DO 2300 I=1,NELMAI
746 : WRITE(IOPER,4050) I,(RVAMCH(K,I),K=1,NBCMCH)
747 : 2300 CONTINUE
748 : SEGSUP VALMCH
749 : ENDIF
750 :
751 : C ... Le champ global ...
752 :
753 : IF(NBCGLO.EQ.1) THEN
754 : WRITE(IOPER,4030) 1,1
755 : WRITE(IOPER,4040) 'time'
756 : WRITE(IOPER,4050) 1,VALTEM
757 : ENDIF
758 :
759 : C ... Le ménage ...
760 :
761 : SEGSUP IEQUIV
762 :
763 : * Pas d'option 'SUIT' => Fermeture du fichier
764 : IF (INOREW.EQ.0) CLOSE(UNIT=IOPER)
765 :
766 : C ... Il n'y a pas de champ global, donc ...
767 :
768 : RETURN
769 :
770 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
771 : C ... Fin de la partie où tout se passe bien ...
772 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
773 :
774 : 9999 CONTINUE
775 : MOTERR(1:8)='AVS '
775 : CALL ERREUR(705)
776 :
777 : 10000 CONTINUE
778 : IF(NCCHPO.NE.0) THEN
779 : SEGSUP NCCHPO
780 : ENDIF
781 : IF(NCMCHA.NE.0) THEN
782 : SEGSUP NCMCHA
783 : ENDIF
784 : IF(VALCHP.NE.0) THEN
785 : SEGSUP VALCHP
786 : ENDIF
787 : IF(VALMCH.NE.0) THEN
788 : SEGSUP VALMCH
789 : ENDIF
790 : IF(IEQUIV.NE.0) THEN
791 : SEGSUP IEQUIV
792 : ENDIF
793 :
794 : RETURN
795 :
796 : 4000 FORMAT(5I11)
797 : 4010 FORMAT(I11,3(1X,1P,1E14.7))
798 : 4020 FORMAT(2I11,' pt',I11)
799 : 4030 FORMAT(13I11)
800 : 4040 FORMAT(1X,A4,',')
801 : 4041 FORMAT(1X,A8,',')
802 : C Modif DC 12/2006 - Sortie AVS compatible PARAVIEW
803 : 4042 FORMAT(1X,A4,',1 ')
804 : 4043 FORMAT(1X,A4,',1 1')
805 : C+ Fin modif
806 : 4050 FORMAT(I11,12(1X,1P,E14.7))
807 : END
808 :
809 :
810 :
© Cast3M 2003 - All rights reserved.
Disclaimer