1 : C VIDE SOURCE JC220346 13/03/22 21:15:01 7739
2 : ************************************************************************
3 : * NOM : VIDE
4 : * DESCRIPTION : Crée des objets vides de types/sous-types donnés
5 : ************************************************************************
6 : * HISTORIQUE : 13/03/2012 : JCARDO : création de l'opérateur
7 : * HISTORIQUE : 17/04/2012 : JCARDO : ajout de SMDEFOR et SMVECTE
8 : * HISTORIQUE : 12/10/2012 : JCARDO : ajout de SMCHARG
9 : ************************************************************************
10 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
11 : * en cas de modification de ce sous-programme afin de faciliter
12 : * la maintenance !
13 : ************************************************************************
14 : * APPELÉ PAR : pilot.eso
15 : ************************************************************************
16 : * ENTRÉES :: aucune
17 : * SORTIES :: aucune
18 : ************************************************************************
19 : * SYNTAXE (GIBIANE) :
20 : *
21 : * OBJ1,...,OBJn = VIDE [GROUPE1,...,GROUPEn]
22 : *
23 : * ou TAB1 = VIDE ('TABULER' ( |LENTI1| ) ) [GROUPE1,...,GROUPEn]
24 : * |LREEL1|
25 : * |LMOTS1|
26 : *
27 : *
28 : * avec GROUPEi de la forme : MOTAi(/MOTBi)(*ENTIi)
29 : *
30 : ************************************************************************
31 : SUBROUTINE VIDE
32 :
33 : IMPLICIT INTEGER(I-N)
34 : IMPLICIT REAL*8(A-H,O-Z)
35 :
36 : -INC CCGEOME
37 : -INC CCOPTIO
38 :
39 : -INC SMELEME
40 : -INC SMCHPOI
41 : -INC SMCHAML
42 : -INC SMMODEL
43 : -INC SMRIGID
44 : -INC SMEVOLL
45 : -INC SMLENTI
46 : -INC SMLREEL
47 : -INC SMLMOTS
48 : -INC SMLCHPO
49 : -INC SMTABLE
50 : -INC SMDEFOR
51 : -INC SMVECTE
52 : -INC SMCHARG
53 :
54 : CHARACTER*20 MARG
55 : CHARACTER*8 CHAI,TYIN,TYOB
56 : CHARACTER*4 CHAA
57 :
58 : CHARACTER*4 MSPE(2)
59 : DATA MSPE/'* ','/ '/
60 :
61 : PARAMETER (LMTYP=14)
62 : CHARACTER*8 MTYP(LMTYP)
63 : DATA MTYP/'MAILLAGE',
64 : . 'CHPOINT ',
65 : . 'MCHAML ',
66 : . 'MMODEL ',
67 : . 'RIGIDITE',
68 : . 'EVOLUTIO',
69 : . 'LISTENTI',
70 : . 'LISTREEL',
71 : . 'LISTMOTS',
72 : . 'LISTCHPO',
73 : . 'TABLE ',
74 : . 'DEFORME ',
75 : . 'VECTEUR ',
76 : . 'CHARGEME'/
77 :
78 : CHARACTER*4 MNAT(2)
79 : DATA MNAT/'DIFF','DISC'/
80 :
81 :
82 : * On crée le segment IPSORT pour que l'ordre des objets en sortie
83 : * corresponde bien à celui des arguments en entrée (ordre inverse)
84 : * => MOINS UTILE POUR L'OPTION 'TABULER' (MAIS QUAND MÊME UTILISÉ)
85 : SEGMENT IPSORT
86 : INTEGER IPOOBJ(NOBJ)
87 : CHARACTER*8 MTYPOB(NOBJ)
88 : ENDSEGMENT
89 :
90 : * NOBJ = nombre d'objets vides créés au total par cette subroutine
91 : NOBJ=0
92 : SEGINI IPSORT
93 :
94 :
95 :
96 : * **************************************************************
97 : * DÉTERMINATION DU MODE D'ÉCRITURE EN SORTIE
98 : * **************************************************************
99 : *
100 : * Deux possibilités pour sortir les résultats :
101 : *
102 : * - Option 'TABU' => les objets sont placés dans une table dont
103 : * les indices peuvent être choisis soit par
104 : * l'utilisateur, soit automatiquement
105 : *
106 : * ITAB | IRET | TYIN
107 : * ---------+----------------+---------------
108 : * 1 | 0 | ENTIER
109 : * 2 | -> LISTENTI | ENTIER
110 : * 3 | -> LISTREEL | FLOTTANT
111 : * 4 | -> LISTMOTS | MOT
112 : *
113 : * - Par défaut => on sort les objets séparément
114 : *
114 : CALL LIRCHA(CHAA,1,LCHTA)
115 :
116 : * =============
117 : * OPTION 'TABU'
118 : * =============
119 : IF (CHAA.EQ.'TABU') THEN
120 : ITAB=1
121 : TYIN='ENTIER '
122 :
123 : * L'utilisateur a-t-il transmis une liste d'indices ?
124 : CHAI=' '
124 : CALL LIRABJ(CHAI,IRET,0,IRETOU)
125 : IF (IRETOU.EQ.1) THEN
126 :
127 : * => OUI : objet LISTENTI, LISTREEL ou LISTMOTS
128 : IF (CHAI.EQ.'LISTENTI') THEN
129 : ITAB=2
130 : TYIN='ENTIER '
131 : MLENT1=IRET
132 : SEGACT MLENT1
133 : ELSEIF (CHAI.EQ.'LISTREEL') THEN
134 : ITAB=3
135 : TYIN='FLOTTANT'
136 : MLREE1=IRET
137 : SEGACT MLREE1
138 : ELSEIF (CHAI.EQ.'LISTMOTS') THEN
139 : ITAB=4
140 : TYIN='MOT '
141 : MLMOT1=IRET
142 : SEGACT MLMOT1
143 :
144 : * => NON : autres objets
145 : ELSEIF (CHAI.EQ.'MOT') THEN
145 : CALL REFUS
146 : ELSE
147 : C ERREUR CRITIQUE 39 (On ne veut pas d'objet de type %m1:8)
148 : MOTERR(1:8)=CHAI
148 : CALL ERREUR(39)
149 : WRITE(IOIMP,*) '(l''option TABU requiert ',
150 : & 'éventuellement un objet de type ',
151 : & 'LISTENTI, LISTREEL ou LISTMOTS)'
152 : ENDIF
153 :
154 : ENDIF
155 :
156 : * =================
157 : * OPTION PAR DÉFAUT
158 : * =================
159 : ELSE
160 : ITAB=0
161 :
162 : * Le MOT qu'on a lu n'était pas censé être lu maintenant...
162 : CALL REFUS
163 : ENDIF
164 :
165 :
166 :
167 :
168 :
169 :
170 : * **************************************************************
171 : * LECTURE DU TYPE D'OBJET VIDE À CRÉER
172 : * **************************************************************
173 : *
174 : * On cherche des triplets de la forme ITYP[/MARG][*NLIR]
175 : * (l'ordre des options * et / est indifférent)
176 : *
177 : * - ITYP correspond au type d'objet à créer (position dans MTYP)
178 : * - MARG contient parfois le sous-type (par défaut = ' ')
179 : * - NLIR indique le nombre d'objets à créer (par défaut = 1)
180 : *
181 :
182 : NLIR=0
183 : ICOD=1
184 : * (ICOD permet d'obliger l'utilisateur à entrer au moins un MOT)
185 :
186 :
187 : 1 IF (NLIR.EQ.0) THEN
188 :
189 : * Lecture du type d'objet à créer. Si aucun => fin subroutine
189 : CALL LIRCHA(CHAI,ICOD,LCHAI)
190 : IF (LCHAI.EQ.0) GOTO 999
191 :
192 : * On vérifie que ce type d'objet est prévu dans MTYP
192 : CALL OPTLI(ITYP,MTYP,CHAI,LMTYP)
193 : IF (ITYP.EQ.0) THEN
194 : C ERREUR CRITIQUE 9 (Objet inconnu %m1:8)
195 : MOTERR(1:8)=CHAI
195 : CALL ERREUR(9)
196 : WRITE(IOIMP,*) '(on ne sait pas créer ce type',
197 : & ' d''objet vide)'
198 : RETURN
199 : ENDIF
200 :
201 : * On a trouvé un MOT correct.
202 : NLIR=1
203 :
204 : * On cherche les éventuels caractères * ou /
205 : IARG=0
206 : MARG=' '
207 : ISPA=0
208 : DO 2 J=1,2
208 : CALL LIRMOT(MSPE,2,ISPE,0)
209 : IF (ISPE.EQ.0) GOTO 2
210 : * (Rmq: LIRMOT appelle REFUS si aucun mot ne correspond)
211 :
212 : IF (ISPA.EQ.ISPE) THEN
213 : C ERREUR CRITIQUE 880 (Syntaxe incorrecte, voir notice)
213 : CALL ERREUR(880)
214 : CHAI=MSPE(ISPE)
215 : WRITE(IOIMP,*) '(le caractère spécial ',CHAI(1:1),
216 : & ' apparait 2 fois)'
217 : RETURN
218 : ENDIF
219 :
220 : * Caractère * trouvé => mise à jour de NLIR
220 : IF (ISPE.EQ.1) CALL LIRENT(NLIR,1,IRET)
221 :
222 : * Caractère / trouvé => mise à jour de MARG
223 : IF (ISPE.EQ.2) THEN
224 : IARG=1
224 : CALL LIRCHA(MARG,1,LMARG)
225 : ENDIF
226 :
227 : ISPA=ISPE
228 : 2 CONTINUE
229 : ENDIF
230 :
231 :
232 :
233 :
234 :
235 : * **************************************************************
236 : * INITIALISATION D'UN SEGMENT VIDE POUR LE TYPE D'OBJET DÉSIRÉ
237 : * **************************************************************
238 :
239 : GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130,140),ITYP
240 :
241 :
242 : * ===============================
243 : * Objet MAILLAGE
244 : * ===============================
245 : * => MARG correspond au type d'élément (variable ITYPEL)
246 :
247 : 10 ITEL=ILCOUR
248 : IF (IARG.EQ.1) THEN
248 : CALL CHRMOT(NOMS,100,MARG(1:4),ITEL)
249 : IF (ITEL.EQ.0) THEN
250 : C ERREUR CRITIQUE 16 (Type d'élément incorrect)
250 : CALL ERREUR(16)
251 : WRITE(IOIMP,*) '(le nom ',MARG(1:4),
252 : & ' ne correspond à aucun élément connu)'
253 : RETURN
254 : ENDIF
255 : ENDIF
256 :
257 : NBELEM=0
258 : NBSOUS=0
259 : NBREF=0
260 : NBNN=NBNNE(ITEL)
261 : IF (NOMS(ITEL).EQ.'POLY') THEN
262 : NBNN = 14
263 : ELSE IF (NOMS(ITEL).EQ.'MULT') THEN
264 : NBNN = 9999
265 : ENDIF
266 :
267 : SEGINI MELEME
268 : ITYPEL=ITEL
269 :
270 : IOBJ=MELEME
271 : SEGDES MELEME
272 : GOTO 900
273 :
274 :
275 : * ===============================
276 : * Objet CHPOINT
277 : * ===============================
278 : * => MARG donne la nature du champ par points (variable JATTRI(1))
279 :
280 : 20 NAT=1
281 : NSOUPO=0
282 :
283 : SEGINI MCHPOI
284 : IFOPOI=IFOMOD
285 : IJAT1=0
286 : IF (IARG.EQ.1) THEN
286 : CALL CHRMOT(MNAT,2,MARG(1:4),IJAT1)
287 : IF (IJAT1.EQ.0) THEN
288 : C ERREUR CRITIQUE 881 (Syntaxe incorrecte : on attend %m1:30)
289 : MOTERR(1:30)='soit DISCRET, soit DIFFUS '
289 : CALL ERREUR(881)
290 : WRITE(IOIMP,*) '(le mot ',MARG(1:LMARG),' ne désigne pas',
291 : & ' une nature valide)'
292 : RETURN
293 : ENDIF
294 : ENDIF
295 : JATTRI(1)=IJAT1
296 :
297 : IOBJ=MCHPOI
298 : SEGDES MCHPOI
299 : GOTO 900
300 :
301 :
302 : * ===============================
303 : * Objet MCHAML
304 : * ===============================
305 : * => MARG n'est pas utilisé
306 :
307 : 30 N1=0
308 : N3=0
309 : L1=8
310 :
311 : SEGINI MCHELM
312 : IFOCHE=IFOMOD
313 : TITCHE=' '
314 :
315 : IOBJ=MCHELM
316 : SEGDES MCHELM
317 : GOTO 900
318 :
319 :
320 : * ===============================
321 : * Objet MMODEL
322 : * ===============================
323 : * => MARG n'est pas utilisé
324 :
325 : 40 N1=0
326 :
327 : SEGINI MMODEL
328 :
329 : IOBJ=MMODEL
330 : SEGDES MMODEL
331 : GOTO 900
332 :
333 :
334 : * ===============================
335 : * Objet RIGIDITE
336 : * ===============================
337 : * => MARG indique le type de matrice (variable MTYMAT)
338 :
339 : 50 NRIGEL=0
340 :
341 : SEGINI MRIGID
342 : MTYMAT=MARG(1:8)
343 :
344 : IOBJ=MRIGID
345 : SEGDES MRIGID
346 : GOTO 900
347 :
348 :
349 : * ===============================
350 : * Objet EVOLUTIO
351 : * ===============================
352 : * => MARG n'est pas utilisé
353 :
354 : 60 N=0
355 :
356 : SEGINI MEVOLL
357 :
358 : IOBJ=MEVOLL
359 : SEGDES MEVOLL
360 : GOTO 900
361 :
362 :
363 : * ===============================
364 : * Objet LISTENTI
365 : * ===============================
366 : * => MARG n'est pas utilisé
367 :
368 : 70 JG=0
369 :
370 : SEGINI MLENTI
371 :
372 : IOBJ=MLENTI
373 : SEGDES MLENTI
374 : GOTO 900
375 :
376 :
377 : * ===============================
378 : * Objet LISTREEL
379 : * ===============================
380 : * => MARG n'est pas utilisé
381 :
382 : 80 JG=0
383 :
384 : SEGINI MLREEL
385 :
386 : IOBJ=MLREEL
387 : SEGDES MLREEL
388 : GOTO 900
389 :
390 :
391 : * ===============================
392 : * Objet LISTMOTS
393 : * ===============================
394 : * => MARG n'est pas utilisé
395 :
396 : 90 JGN=4
397 : JGM=0
398 :
399 : SEGINI MLMOTS
400 :
401 : IOBJ=MLMOTS
402 : SEGDES MLMOTS
403 : GOTO 900
404 :
405 :
406 : * ===============================
407 : * Objet LISTCHPO
408 : * ===============================
409 : * => MARG n'est pas utilisé
410 :
411 : 100 N1=0
412 :
413 : SEGINI MLCHPO
414 :
415 : IOBJ=MLCHPO
416 : SEGDES MLCHPO
417 : GOTO 900
418 :
419 :
420 : * ===============================
421 : * Objet TABLE
422 : * ===============================
423 : * => MARG donne le sous-type de la table (indice 'SOUSTYPE')
424 :
425 : 110 M=0
426 :
427 : SEGINI MTABLE
428 : IF (IARG.EQ.1) THEN
428 : CALL ECCTAB(MTABLE,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,0,
429 : & 'MOT',0,0.D0,MARG(1:8) ,.TRUE.,0)
430 : ENDIF
431 :
432 : IOBJ=MTABLE
433 : SEGDES MTABLE
434 : GOTO 900
435 :
436 :
437 : * ===============================
438 : * Objet DEFORME
439 : * ===============================
440 : * => MARG n'est pas utilisé
441 :
442 : 120 NDEF=0
443 :
444 : SEGINI MDEFOR
445 :
446 : IOBJ=MDEFOR
447 : SEGDES MDEFOR
448 : GOTO 900
449 :
450 :
451 : * ===============================
452 : * Objet VECTEUR
453 : * ===============================
454 : * => MARG n'est pas utilisé
455 :
456 : 130 NVEC=0
457 : ID=0
458 :
459 : SEGINI MVECTE
460 :
461 : IOBJ=MVECTE
462 : SEGDES MVECTE
463 : GOTO 900
464 :
465 :
466 : * ===============================
467 : * Objet CHARGEME
468 : * ===============================
469 : * => MARG n'est pas utilisé
470 :
471 : 140 N=0
472 :
473 : SEGINI MCHARG
474 :
475 : IOBJ=MCHARG
476 : SEGDES MCHARG
477 : GOTO 900
478 :
479 :
480 :
481 :
482 : * **************************************************************
483 : * FIN DE LA CRÉATION D'UN OBJET
484 : * **************************************************************
485 :
486 : 900 CONTINUE
487 :
488 : * S'il y avait plusieurs objets de même type à créer, en voilà un de moins
489 : NLIR=NLIR-1
490 :
491 : * On mémorise son pointeur et son type dans le segment IPSORT
492 : NOBJ=NOBJ+1
493 : SEGADJ IPSORT
494 : IPOOBJ(NOBJ)=IOBJ
495 : MTYPOB(NOBJ)=MTYP(ITYP)
496 :
497 : * On remonte là-haut pour voir s'il y a d'autres objets à créer
498 : * (cette fois, ce ne sera plus obligatoire)
499 : ICOD=0
500 : GOTO 1
501 :
502 :
503 :
504 :
505 :
506 : * **************************************************************
507 : * FIN DE LA SUBROUTINE
508 : * **************************************************************
509 : *
510 : * On écrit sur la sortie les objets stockés dans IPSORT :
511 : * - Option 'TABU' => les objets sont placés dans une table
512 : * - Par défaut => on sort les objets séparément
513 : *
514 :
515 : 999 CONTINUE
516 :
517 : * =============================================
518 : * SORTIE SOUS FORME DE PLUSIEURS OBJETS SÉPARÉS
519 : * =============================================
520 : IF (ITAB.EQ.0) THEN
521 : DO IA=1,NOBJ
522 : IB=NOBJ-IA+1
523 : * (il faut inverser l'ordre pour ECROBJ)
523 : CALL ECROBJ(MTYPOB(IB),IPOOBJ(IB))
524 : ENDDO
525 :
526 :
527 : * =====================================
528 : * SORTIE SOUS FORME D'UNE TABLE INDICÉE
529 : * =====================================
530 : * Si l'objet LISTENTI/LISTREEL/LISTMOTS définissant les indices à
531 : * utiliser est trop court, les indices manquants seront des entiers
532 : * correspondant à l'ordre de création de l'objet
533 : ELSE
534 : M=NOBJ
535 : SEGINI MTAB1
536 :
537 : CHAI=' '
538 : IVAL=0
539 : XVAL=0.D0
540 :
541 : LONGLI=NOBJ
542 : IF (ITAB.EQ.2) LONGLI=MLENT1.LECT(/1)
543 : IF (ITAB.EQ.3) LONGLI=MLREE1.PROG(/1)
544 : IF (ITAB.EQ.4) LONGLI=MLMOT1.MOTS(/2)
545 :
546 : DO IA=1,NOBJ
547 : IF (IA.GT.LONGLI) THEN
548 : * L'objet LIST**** est trop petit, on change de mode
549 : * d'indexation
550 : ITAB=1
551 : TYIN='ENTIER '
552 : ENDIF
553 :
554 : IF (ITAB.EQ.1) IVAL=IA
555 : IF (ITAB.EQ.2) IVAL=MLENT1.LECT(IA)
556 : IF (ITAB.EQ.3) XVAL=MLREE1.PROG(IA)
557 : IF (ITAB.EQ.4) CHAI(1:4)=MLMOT1.MOTS(IA)
558 :
559 : IPOO=IPOOBJ(IA)
560 : TYOB=MTYPOB(IA)
560 : CALL ECCTAB(MTAB1,TYIN,IVAL,XVAL,CHAI,.TRUE.,0,
561 : & TYOB,0 ,0.D0,' ' ,.TRUE.,IPOO)
562 : ENDDO
563 :
563 : CALL ECROBJ('TABLE',MTAB1)
564 : SEGDES MTAB1
565 : ENDIF
566 :
567 : SEGSUP IPSORT
568 :
569 :
570 :
571 : RETURN
572 :
573 : END
574 :
575 :
576 :
577 :
578 :
579 :
© Cast3M 2003 - All rights reserved.
Disclaimer