1 : C GRAF1 SOURCE AM 13/12/16 21:15:45 7825
2 : SUBROUTINE GRAF1(IPMODL,IPCHE2,IPCHE1,IPCHL1,IRET)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : *____________________________________________________________________*
6 : * *
7 : * Sous-programme de l'op{rateur GRADIENT DE FLEXION *
8 : * *
9 : * Entr{es: *
10 : * *
11 : * IPMODL Pointeur sur un objet MMODEL *
12 : * IPCHE2 Pointeur sur un MCHAML de DEPLACEMENT *
13 : * IPCHE1 Pointeur sur un MCHAML de CARACTERISTIQUES *
14 : * *
15 : * Sortie: *
16 : * *
17 : * IPCHL1 Pointeur sur un MCHAML de gradients *
18 : * IRET 1 si succes , 0 sinon *
19 : * *
20 : * Auteurs, date de cr{ation: *
21 : * *
22 : * SUO X.Z Le 19/21/1986 *
23 : * Passage aux nouveux chamelems par P.DOWLATYARI le 28/03/91 *
24 : * *
25 : *____________________________________________________________________*
26 : *
27 : -INC CCOPTIO
28 : -INC CCHAMP
29 : -INC SMCHAML
30 : -INC SMMODEL
31 : -INC SMELEME
32 : -INC SMINTE
33 : -INC SMCOORD
34 : *
35 : SEGMENT,MWRK1
36 : REAL*8 XDDL(LRE),XE(3,NBBB),GRADF(NGRAF)
37 : REAL*8 DDHOOK(NSTRS,NSTRS),DDHOMU(NSTRS,NSTRS)
38 : ENDSEGMENT
39 : *
40 : SEGMENT,MWRK2
41 : REAL*8 SHPWRK(6,NBNO),BGF(NGRAF,LRE)
42 : ENDSEGMENT
43 : *
44 : SEGMENT,MWRK3
45 : REAL*8 WORK(LW)
46 : ENDSEGMENT
47 : *
48 : SEGMENT,MWRK4
49 : REAL*8 BPSS(3,3),XEL(3,NBBB),XDDLOC(LRE)
50 : ENDSEGMENT
51 : *
52 : SEGMENT NOTYPE
53 : CHARACTER*16 TYPE(NBTYPE)
54 : ENDSEGMENT
55 : *
56 : SEGMENT MVELCH
57 : REAL*8 VALMAT(NV1)
58 : ENDSEGMENT
59 : *
60 : SEGMENT MPTVAL
61 : INTEGER IPOS(NS) ,NSOF(NS)
62 : INTEGER IVAL(NCOSOU)
63 : CHARACTER*16 TYVAL(NCOSOU)
64 : ENDSEGMENT
65 : *
66 : CHARACTER*8 CMATE
67 : PARAMETER ( NINF=3 )
68 : INTEGER INFOS(NINF)
69 : CHARACTER*(NCONCH) CONM
70 : LOGICAL lsupgf,lsupdp
71 : *
72 : IRET=1
73 : MWRK1=0
74 : MWRK2=0
75 : MWRK3=0
76 : MWRK4=0
77 : MVELCH=0
78 : NMAT = 0
79 : IMESS= 0
80 : NHRM = NIFOUR
81 : *
82 : * ACTIVATION DU CHAPEAU DE MODELE
83 : *
84 : MMODEL = IPMODL
85 : SEGACT MMODEL
86 : NSOUS = KMODEL(/1)
87 : *
88 : * Initialisation du CHAMELEM de GRADIENTS DE FLEXION
89 : *
90 : L1 = 19
91 : N1 = NSOUS
92 : N3 = 6
93 : SEGINI,MCHELM
94 : IPCHL1=MCHELM
95 : TITCHE = 'GRADIENT DE FLEXION'
96 : IFOCHE=IFOUR
97 : *
98 : * Boucle sur les zones {l{mentaires du MODELE
99 : *
100 : DO 500 ISOUS=1,NSOUS
101 : *
102 : * QUELQUES INITIALISATIONS
103 : *
104 : NGRAF= 0
105 : MOGRAF=0
106 : MODEPL=0
107 : MOMATR=0
108 : MOCARA=0
109 : NDEP=0
110 : NCAR = 0
111 : IPMINT=0
112 : IRTD1=1
113 : NSTRS=0
114 : IVAGRF=0
115 : IVADEP=0
116 : IVAMAT=0
117 : IVACAR=0
118 : NMATR=0
119 : NMATF=0
120 : *
121 : IMODEL=KMODEL(ISOUS)
122 : SEGACT IMODEL
123 : MELE=NEFMOD
124 : IPMAIL=IMAMOD
125 : CONM=CONMOD
126 : NFOR=FORMOD(/2)
127 : NMAT=MATMOD(/2)
127 : CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
128 : IF (CMATE.EQ.' ')THEN
128 : CALL ERREUR(251)
129 : SEGDES IMODEL,MMODEL
130 : SEGSUP MCHELM
131 : IRET=0
132 : RETURN
133 : ENDIF
134 : *
135 : * ACTIVATION DU MAILLAGE
136 : *
137 : MELEME=IPMAIL
138 : SEGACT,MELEME
139 : NBNN =NUM(/1)
140 : NBELEM=NUM(/2)
141 : NBNO=NBNN
142 : *
143 : * INFORMATIONS SUR L'ELEMENT FINI
144 : *
144 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
145 : * IF (IERR.NE.0) THEN
146 : * SEGDES IMODEL,MMODEL
147 : * SEGSUP MCHELM
148 : * IRET=0
149 : * RETURN
150 : * ENDIF
151 : * INFO=IPINF
152 : MFR=INFELE(13)
153 : * MINTE=INFELE(11)
154 : minte=infmod(7)
155 : MINTE1= INFMOD(8)
156 : NSTRS =INFELE(16)
157 : LW = INFELE( 7)
158 : LRE = INFELE( 9)
159 : LHOOK =INFELE(10)
160 : *
161 : * ACTIVATION DU SEGMENT D'INTEGRATION
162 : *
163 : SEGACT,MINTE
164 : NBPGAU=POIGAU(/1)
165 : C
166 : C CREATION DU TABLEAU INFOS
167 : C
167 : CALL IDENT(IPMAIL,CONM,IPCHE2,IPCHE1,INFOS,IRTD)
168 : IF (IRTD.EQ.0) GOTO 9990
169 : *
170 : * NOMS DE COMPOSANTES OBLIGATOIRES A TROUVER DANS LES CHAMELEMS
171 : *
172 : if(lnomid(11).ne.0) then
173 : nomid=lnomid(11)
174 : segact nomid
175 : mograf=nomid
176 : ngraf=lesobl(/2)
177 : nfac=lesfac(/2)
178 : lsupgf=.false.
179 : else
180 : lsupgf=.true.
180 : CALL IDGRAF(MFR,IFOUR,MOGRAF,NGRAF,NFAC)
181 : endif
182 : *
183 : * NOMS DE COMPOSANTES DU DEPLACEMENT
184 : *
185 : if(lnomid(1).ne.0) then
186 : nomid=lnomid(1)
187 : segact nomid
188 : modepl=nomid
189 : ndep=lesobl(/2)
190 : nfac=lesfac(/2)
191 : lsupdp=.false.
192 : else
193 : lsupdp=.true.
193 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEP,NFAC)
194 : endif
195 : *
196 : * VERIFICATION DE PRESENCE DES COMPOSANTES
197 : *
198 : NBTYPE=1
199 : SEGINI NOTYPE
200 : MOTYPE=NOTYPE
201 : TYPE(1)='REAL*8'
201 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MODEPL,
202 : 1 MOTYPE,1,INFOS,3,IVADEP)
203 : SEGSUP NOTYPE
204 : IF (IERR.NE.0) THEN
205 : NGRAF=0
206 : GO TO 9990
207 : ENDIF
208 : *
209 : * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE
210 : * TRAVAIL UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST (MELE=93)
211 : *
212 : * CAS DES POUTRES ET TUYAUX : RECHERCHE DU VECTEUR LOCAL
213 : *
214 : NBROBL=0
215 : NBRFAC=0
216 : MOMATR=0
217 : MOCARA=0
218 : NCAR=0
219 : NMATR=0
220 : NMATF=0
221 : IVECT=0
222 : *
223 : *
224 : IF(MELE.EQ.93.AND.FORMOD(1).EQ.'MECANIQUE'
225 : 1 .AND.CMATE.EQ.'ISOTROPE') THEN
226 : NBROBL=2
227 : NBRFAC=0
228 : SEGINI NOMID
229 : MOMATR=NOMID
230 : LESOBL(1)='YOUN'
231 : LESOBL(2)='NU '
232 : NMATR=NBROBL
233 : NMATF=NBRFAC
234 : *
235 : IF (IPCHE1.NE.0) THEN
236 : NBTYPE=1
237 : SEGINI NOTYPE
238 : MOTYPE=NOTYPE
239 : TYPE(1)='REAL*8'
239 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,
240 : 1 1,INFOS,3,IVAMAT)
241 : SEGSUP NOTYPE
242 : ELSE
243 : MOTERR(1:8)='CARACTER'
244 : MOTERR(9:12)=NOMTP(MELE)
245 : MOTERR(13:20)='GRAF'
245 : CALL ERREUR(145)
246 : NMATR=0
247 : NMATF=0
248 : NGRAF=0
249 : NOMID=MOMATR
250 : SEGSUP NOMID
251 : MOMATR=0
252 : GOTO 9990
253 : ENDIF
254 : IF (IERR.NE.0) GOTO 9990
255 : *
256 : NMATT=NMATR+NMATF
257 : *
258 : MPTVAL=IVAMAT
259 : NBGMAT = 0
260 : NELMAT = 0
261 : DO 1108 IM=1,NMATT
262 : IF(IVAL(IM).NE.0)THEN
263 : MELVAL=IVAL(IM)
264 : NBGMAT=MAX(NBGMAT,VELCHE(/1))
265 : NELMAT=MAX(NELMAT,VELCHE(/2))
266 : ENDIF
267 : 1108 CONTINUE
268 : C
269 : NBROBL=1
270 : NBRFAC=1
271 : SEGINI NOMID
272 : MOCARA=NOMID
273 : LESOBL(1)='EPAI'
274 : LESFAC(1)='EXCE'
275 : NCAR=1
276 : NBTYPE=1
277 : SEGINI NOTYPE
278 : MOTYPE=NOTYPE
279 : TYPE(1)='REAL*8'
279 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,
280 : 1 MOTYPE,1,INFOS,3,IVACAR)
281 : SEGSUP NOTYPE
282 : IF (IERR.NE.0) GOTO 9990
283 : ENDIF
284 : C
285 : IF(IVACAR.NE.0)THEN
286 : MPTVAL=IVACAR
287 : IPMELV=IVAL(1)
287 : CALL QUELCH(IPMELV,ICONS)
288 : IF(ICONS.NE.0)THEN
288 : CALL ERREUR(566)
289 : GOTO 9990
290 : ENDIF
291 : *
292 : * CAS DES POUTRES ET TUYAUX
293 : *
294 : ELSE IF(MFR.EQ.7) THEN
295 : IF (CMATE.EQ.'SECTION') THEN
296 : NBROBL=0
297 : NBRFAC=1
298 : SEGINI NOMID
299 : MOCARA=NOMID
300 : LESFAC(1)='VECT'
301 : IVECT=1
302 : *
303 : NBTYPE=1
304 : SEGINI NOTYPE
305 : TYPE(1)='POINTEURPOINT '
306 : ELSE
307 : IF(IFOUR.EQ.2) THEN
308 : NBROBL=4
309 : NBRFAC=3
310 : SEGINI NOMID
311 : MOCARA=NOMID
312 : LESOBL(1)='TORS'
313 : LESOBL(2)='INRY'
314 : LESOBL(3)='INRZ'
315 : LESOBL(4)='SECT'
316 : LESFAC(1)='SECY'
317 : LESFAC(2)='SECZ'
318 : LESFAC(3)='VECT'
319 : IVECT=1
320 : *
321 : NBTYPE=7
322 : SEGINI NOTYPE
323 : TYPE(1)='REAL*8'
324 : TYPE(2)='REAL*8'
325 : TYPE(3)='REAL*8'
326 : TYPE(4)='REAL*8'
327 : TYPE(5)='REAL*8'
328 : TYPE(6)='REAL*8'
329 : TYPE(7)='POINTEURPOINT '
330 : ELSEIF(IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.63) THEN
331 : NBRFAC=1
332 : NBROBL=2
333 : SEGINI NOMID
334 : MOCARA=NOMID
335 : LESOBL(1)= 'SECT'
336 : LESOBL(2)= 'INRZ'
337 : LESFAC(1)= 'SECY'
338 : *
339 : NBTYPE=1
340 : SEGINI NOTYPE
341 : TYPE(1)='REAL*8'
342 : ENDIF
343 : ENDIF
344 : C
345 : C CARACTERISTIQUE POUR LES TUYAUX
346 : C
347 : ELSE IF (MFR.EQ.13) THEN
348 : NBROBL=2
349 : NBRFAC=3
350 : SEGINI NOMID
351 : MOCARA=NOMID
352 : LESOBL(1)='EPAI'
353 : LESOBL(2)='RAYO'
354 : LESFAC(1)='RACO'
355 : LESFAC(2)='CISA'
356 : LESFAC(3)='VECT'
357 : IVECT=1
358 : C
359 : NBTYPE=5
360 : SEGINI NOTYPE
361 : TYPE(1)='REAL*8'
362 : TYPE(2)='REAL*8'
363 : TYPE(3)='REAL*8'
364 : TYPE(4)='REAL*8'
365 : TYPE(5)='POINTEURPOINT '
366 : C
367 : ENDIF
368 : NCARA=NBROBL
369 : NCARF=NBRFAC
370 : NCAR=NBROBL+NBRFAC
371 :
372 : C Verification de la presence des caracteristiques dans IPCHE1
373 :
374 : IF (NCAR.NE.0) THEN
375 : IF (IPCHE1.NE.0) THEN
376 : MOTYPE=NOTYPE
376 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,
377 : . INFOS,3,IVACAR)
378 : SEGSUP,NOTYPE
379 : IF(IERR.NE.0) GOTO 9990
380 : IF (IVACAR.NE.0) THEN
381 : MPTVAL=IVACAR
382 : IPMELV=IVAL(1)
382 : CALL QUELCH(IPMELV,ICONS)
383 : IF (ICONS.NE.0) THEN
383 : CALL ERREUR(566)
384 : GOTO 9990
385 : ENDIF
386 : ENDIF
387 : *
388 : * CAS DES POUTRES : TRAITEMENT DES VECTEURS
389 : IF (IVECT.EQ.1) THEN
390 : MPTVAL=IVACAR
391 : IF (IVAL(NCAR).EQ.0) THEN
392 : C
393 : C MOT CLE VECT EN CAS DE CONVERSION
394 : C
395 : segsup mptval
396 : IVECT=2
397 : NOMID=MOCARA
398 : C* SEGACT NOMID
399 : NBRFAC=NBRFAC+2
400 : SEGADJ NOMID
401 : LESFAC(NBRFAC-2)='VX '
402 : LESFAC(NBRFAC-1)='VY '
403 : LESFAC(NBRFAC) ='VZ '
404 : C
405 : NCARF=NBRFAC
406 : NCAR=NCARA+NCARF
407 : C
407 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYCH,
408 : $ 1,INFOS,3,IVACAR)
409 : IF (IERR.NE.0) GOTO 9990
410 : ENDIF
411 : ENDIF
412 :
413 :
414 : ELSE
415 : SEGSUP,NOTYPE
416 : MOTERR(1:8)='CARACTER'
417 : MOTERR(9:12)=NOMTP(MELE)
418 : MOTERR(13:20)='GRAF'
418 : CALL ERREUR(145)
419 : GOTO 9990
420 : ENDIF
421 : ENDIF
422 : *
423 : C =====
424 : C Cas d'un joint unidimensionnel JOI1
425 : C Chargement des vecteurs stitués dans les caractéristiques matériau
426 : C =====
427 : IF(MFR.EQ.75) THEN
428 : IF(IDIM.EQ.3) THEN
429 : NBROBL=6
430 : NBRFAC=0
431 : SEGINI NOMID
432 : MOMATR=NOMID
433 : LESOBL(1)='V1X'
434 : LESOBL(2)='V1Y'
435 : LESOBL(3)='V1Z'
436 : LESOBL(4)='V2X'
437 : LESOBL(5)='V2Y'
438 : LESOBL(6)='V2Z'
439 : NMATR=NBROBL
440 : NMATF=NBRFAC
441 : ELSE IF(IDIM.EQ.2) THEN
442 : NBROBL=2
443 : NBRFAC=0
444 : SEGINI NOMID
445 : MOMATR=NOMID
446 : LESOBL(1)='V1X'
447 : LESOBL(2)='V1Y'
448 : NMATR=NBROBL
449 : NMATF=NBRFAC
450 : ENDIF
451 : NBTYPE=1
452 : SEGINI NOTYPE
453 : TYPE(1)='REAL*8'
454 : MOTYPE=NOTYPE
455 : *
455 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
456 : SEGSUP NOTYPE
457 : IF (IERR.NE.0) GOTO 9990
458 : *
459 : NMATT=NMATR+NMATF
460 : * C
461 : IF(ISUP1.EQ.1)THEN
461 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE)
462 : IF(IERR.NE.0)THEN
463 : ISUP1=0
464 : GOTO 9990
465 : ENDIF
466 : ENDIF
467 : MPTVAL=IVAMAT
468 : NBGMAT = 0
469 : NELMAT = 0
470 : DO 11265 IM=1,NMATT
471 : IF(IVAL(IM).NE.0)THEN
472 : MELVAL=IVAL(IM)
473 : IF (CMATE.EQ.'SECTION') THEN
474 : NBGMAT=MAX(NBGMAT,IELCHE(/1))
475 : NELMAT=MAX(NELMAT,IELCHE(/2))
476 : ELSE
477 : NBGMAT=MAX(NBGMAT,VELCHE(/1))
478 : NELMAT=MAX(NELMAT,VELCHE(/2))
479 : ENDIF
480 : ENDIF
481 : 11265 CONTINUE
482 : nmattd=nmatt
483 : ivamtd= ivamat
484 : segdes nomid
485 : ENDIF
486 : *
487 : * CREATION DU MCHAML DE GRADIENT DE FLEXION
488 : *
489 : N2=NGRAF
490 : SEGINI,MCHAML
491 : ICHAML(ISOUS)=MCHAML
492 : IMACHE(ISOUS)=MELEME
493 : CONCHE(ISOUS)=CONMOD
494 : *
495 : INFCHE(ISOUS,1)=0
496 : INFCHE(ISOUS,2)=0
497 : INFCHE(ISOUS,3)=NHRM
498 : INFCHE(ISOUS,4)=MINTE
499 : INFCHE(ISOUS,5)=0
500 : INFCHE(ISOUS,6)=5
501 : *
502 : * RECHERCHE DES DIMENSIONS LES PLUS GRANDES
503 : *
504 : N1EL=0
505 : N1PTEL=0
506 : MPTVAL=IVADEP
507 : DO 178 IO=1,NDEP
508 : MELVAL=IVAL(IO)
509 : N1PTEL=MAX(N1PTEL,VELCHE(/1))
510 : N1EL =MAX(N1EL ,VELCHE(/2))
511 : 178 CONTINUE
512 : *
513 : IF(IVACAR.NE.0)THEN
514 : MPTVAL=IVACAR
515 : DO 179 IO=1,NCAR
516 : IF(IVAL(IO).NE.0) THEN
517 : MELVAL=IVAL(IO)
518 : N1PTEL=MAX(N1PTEL,VELCHE(/1))
519 : N1EL =MAX(N1EL ,VELCHE(/2))
520 : ENDIF
521 : 179 CONTINUE
522 : ENDIF
523 : *
524 : IF (N1PTEL.EQ.1.OR.NBPGAU.EQ.1) THEN
525 : N1PTEL=1
526 : ELSE
527 : N1PTEL=NBPGAU
528 : ENDIF
529 : N1EL =MIN(N1EL ,NBELEM)
530 : *
531 : * CREATION DES MELVAL DU GRADIENT DE FLEXION
532 : *
533 : NS=1
534 : NCOSOU=NGRAF
535 : SEGINI MPTVAL
536 : IVAGRF=MPTVAL
537 : NOMID=MOGRAF
538 : SEGACT NOMID
539 : DO 77 IGR=1,NGRAF
540 : TYPCHE(IGR)='REAL*8'
541 : NOMCHE(IGR)=LESOBL(IGR)
542 : N2PTEL=0
543 : N2EL=0
544 : SEGINI MELVAL
545 : IELVAL(IGR)=MELVAL
546 : IVAL(IGR)=MELVAL
547 : 77 CONTINUE
548 : SEGDES NOMID
549 : *
550 : C=======================================================================
551 : C NUMERO DES ETIQUETTES :
552 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
553 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
554 : C 5 CONTINUE
555 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
556 : C 44 CONTINUE
557 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
558 : C=======================================================================
559 : GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
560 : 1 99,99,99,99,99,99,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
561 : 2 99,29,99,44,99,99,99,99,49,99,99,99,99,99,99,99,99,99,99,99,
562 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
563 : 4 99,99,99,29,99,99,99,99,99,99,99,99,93,99,99,99,99),MELE
564 : C
565 : IF (MELE.EQ.265) GOTO 265
566 : 99 CONTINUE
567 : MOTERR(1:4)=NOMTP(MELE)
568 : MOTERR(9:12)='GRAF'
569 : IMESS = 86
570 : GOTO 9990
571 : *
572 : C ______________________
573 : C | ELEMENTS COQ3 |
574 : C |______________________|
575 : 27 CONTINUE
576 : NBBB=NBNN
577 : SEGINI MWRK1,MWRK3
578 : C
579 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
580 : C
581 : DO 3027 IB=1,NBELEM
582 : C
583 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
584 : C
584 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
585 : C
586 : C ON CHERCHE LES DEPLACEMENTS
587 : C
588 : IE=0
589 : MPTVAL=IVADEP
590 : DO 4027 IGAU=1,NBNN
591 : DO 4027 ICOMP=1,NDEP
592 : IE=IE+1
593 : MELVAL=IVAL(ICOMP)
594 : IF (MELVAL.NE.0) THEN
595 : IGMN=MIN(IGAU,VELCHE(/1))
596 : IBMN=MIN(IB ,VELCHE(/2))
597 : XDDL(IE)=VELCHE(IGMN,IBMN)
598 : ELSE
599 : XDDL(IE)=0.D0
600 : ENDIF
601 : 4027 CONTINUE
602 :
603 : C
603 : CALL COQ3GF(XE,XDDL,GRADF,WORK)
604 : C
605 : C REMPLISAGE DU SEGMENT CONTENANT LES GRADIENT EN FLEXION
606 : C
607 : MPTVAL=IVAGRF
608 : DO 6027 IC=1,NGRAF
609 :
610 : MELVAL=IVAL(IC)
611 : IBMN=MIN(IB ,VELCHE(/2))
612 : IF (IC.EQ.3.OR.IC.GE.6) THEN
613 : VELCHE(1,IBMN)=0.D0
614 : ELSE
615 : VELCHE(1,IBMN)=GRADF(IC)
616 : ENDIF
617 : 6027 CONTINUE
618 : C
619 : 3027 CONTINUE
620 : GOTO 510
621 : C ______________________
622 : C | ELEMENT DKT |
623 : C |_____________________|
624 : 28 CONTINUE
625 : NBNO=NBNN
626 : NBBB=NBNN
627 : SEGINI MWRK1,MWRK2,MWRK4
628 : DO 3028 IB=1,NBELEM
629 : C
630 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
631 : C
631 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
632 : C
633 : C ON CHERCHE LES DEPLACEMENTS
634 : C
635 : IE=0
636 : MPTVAL=IVADEP
637 : DO 4028 IGAU=1,NBNN
638 : DO 4028 ICOMP=1,NDEP
639 : IE=IE+1
640 : MELVAL=IVAL(ICOMP)
641 : IF (MELVAL.NE.0) THEN
642 : IGMN=MIN(IGAU,VELCHE(/1))
643 : IBMN=MIN(IB ,VELCHE(/2))
644 : XDDL(IE)=VELCHE(IGMN,IBMN)
645 : ELSE
646 : XDDL(IE)=0.D0
647 : ENDIF
648 : 4028 CONTINUE
649 :
649 : CALL VPAST(XE,BPSS)
650 : C BPSS STOCKE LA MATRICE DE PASSAGE
650 : CALL VCORLC (XE,XEL,BPSS)
650 : CALL MATVEC(XDDL,XDDLOC,BPSS,6)
651 : C
652 : C BOUCLE SUR LES POINTS DE GAUSS
653 : C
654 : DO 5028 IGAU=1,NBPGAU
654 : CALL BGFDKT(IGAU,MELE,LRE,IFOUR,XEL,BGF)
654 : CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
655 : C
656 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
657 : C
658 : MPTVAL=IVAGRF
659 : DO 9028 IC=1,NGRAF
660 : MELVAL=IVAL(IC)
661 : IGMN=MIN(IGAU,VELCHE(/1))
662 : IBMN=MIN(IB ,VELCHE(/2))
663 : IF (IC.EQ.3.OR.IC.GE.6) THEN
664 : VELCHE(IGMN,IBMN)=0.D0
665 : ELSE
666 : VELCHE(IGMN,IBMN)=GRADF(IC)
667 : ENDIF
668 : 9028 CONTINUE
669 : 5028 CONTINUE
670 : 3028 CONTINUE
671 : GOTO 510
672 : C ______________________
673 : C | ELEMENT DST |
674 : C |_____________________|
675 : 93 CONTINUE
676 : NBNO=NBNN
677 : NBBB=NBNN
678 : NV1=NMATT
679 : SEGINI MWRK1,MWRK2,MWRK3,MWRK4,MVELCH
680 : DO 3093 IB=1,NBELEM
681 : C
682 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
683 : C
683 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
684 : C
685 : C ON CHERCHE LES DEPLACEMENTS
686 : C
687 : IE=0
688 : MPTVAL=IVADEP
689 : DO 4093 IGAU=1,NBNN
690 : DO 4093 ICOMP=1,NDEP
691 : IE=IE+1
692 : MELVAL=IVAL(ICOMP)
693 : IF (MELVAL.NE.0) THEN
694 : IGMN=MIN(IGAU,VELCHE(/1))
695 : IBMN=MIN(IB ,VELCHE(/2))
696 : XDDL(IE)=VELCHE(IGMN,IBMN)
697 : ELSE
698 : XDDL(IE)=0.D0
699 : ENDIF
700 : 4093 CONTINUE
701 : C
701 : CALL VPAST(XE,BPSS)
702 : C BPSS STOCKE LA MATRICE DE PASSAGE
702 : CALL VCORLC (XE,XEL,BPSS)
702 : CALL MATVEC(XDDL,XDDLOC,BPSS,6)
703 : C
704 : C ON CHERCHE LES EPAISEURS ET ON LES MOYENNE,
705 : C LES EXCENTREMENTS ET ON LES MOYENNE.
706 : C
707 : EPAIST=0.D0
708 : EXCEN=0.D0
709 : MPTVAL=IVACAR
710 : DO 8093 IGAU=1,NBPGAU
711 : MELVAL=IVAL(1)
712 : IF (MELVAL.NE.0) THEN
713 : IGMN=MIN(IGAU,VELCHE(/1))
714 : IBMN=MIN(IB,VELCHE(/2))
715 : EPAIST=EPAIST+VELCHE(IGMN,IBMN)
716 : ELSE
717 : EPAIST=0.D0
718 : ENDIF
719 : *
720 : MELVAL=IVAL(2)
721 : IF (MELVAL.NE.0) THEN
722 : IGMN=MIN(IGAU,VELCHE(/1))
723 : IBMN=MIN(IB,VELCHE(/2))
724 : EXCEN=EXCEN+VELCHE(IGMN,IBMN)
725 : ELSE
726 : EXCEN=0.D0
727 : ENDIF
728 : 8093 CONTINUE
729 : EPAIST=EPAIST/NBPGAU
730 : EXCEN=EXCEN/NBPGAU
731 : C
732 : C BOUCLE SUR LES POINTS DE GAUSS
733 : C
734 : DO 5093 IGAU=1,NBPGAU
735 : MPTVAL=IVAMAT
736 : DO 9193 IM=1,NMATT
737 : IF (IVAL(IM).NE.0) THEN
738 : MELVAL=IVAL(IM)
739 : IBMN=MIN(IB ,VELCHE(/2))
740 : IGMN=MIN(IGAU,VELCHE(/1))
741 : VALMAT(IM)=VELCHE(IGMN,IBMN)
742 : ELSE
743 : VALMAT(IM)=0.D0
744 : ENDIF
745 : 9193 CONTINUE
746 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
746 : 1 CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD1)
746 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
746 : CALL ZERO(BGF,NGRAF,LRE)
747 : C
748 : C CALCUL DES FONCTIONS HS4,HS5 ET HS6
749 : C
749 : CALL HS456(XEL,NSTRS,DDHOMU,WORK(1),WORK(10),WORK(19))
750 : C
751 : C TERMES DE LA MATRICE DE BGF RELATIFS
752 : C AUX DEFORMATONS DE FLEXION
753 : C
753 : CALL BGFDST(IGAU,XEL,NGRAF,QSIGAU,ETAGAU,
754 : 1 WORK(1),WORK(10),WORK(19),BGF)
754 : CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
755 : C
756 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
757 : C
758 : MPTVAL=IVAGRF
759 : DO 9093 IC=1,NGRAF
760 : MELVAL=IVAL(IC)
761 : IGMN=MIN(IGAU,VELCHE(/1))
762 : IBMN=MIN(IB ,VELCHE(/2))
763 : IF (IC.EQ.3.OR.IC.GE.6) THEN
764 : VELCHE(IGMN,IBMN)=0.D0
765 : ELSE
766 : VELCHE(IGMN,IBMN)=GRADF(IC)
767 : ENDIF
768 : 9093 CONTINUE
769 : 5093 CONTINUE
770 : 3093 CONTINUE
771 : GOTO 510
772 : C _____________________________________
773 : C | COQUES A 4 NOEUDS COQ4 |
774 : C |___________________________________|
775 : 49 CONTINUE
776 : NBNO=NBNN
777 : NBBB=NBNN
778 : SEGINI MWRK1,MWRK2,MWRK4
779 : DO 3049 IB=1,NBELEM
780 : C
781 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
782 : C
782 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
783 : C
783 : CALL CQ4LOC(XE,XEL,BPSS,IERT,IUN)
784 : C IERT=1 NODI TROPPO VICINI
785 : C IERT=2 NODI ELEMENTO NON COMPLANARI
786 : IF(IERT.NE.0)THEN
787 : IF(IERT.EQ.1)IMESS=323
788 : IF(IERT.EQ.2)IMESS=322
789 : GO TO 9990
790 : ENDIF
791 : C
792 : C ON CHERCHE LES DEPLACEMENTS
793 : C
794 : IE=0
795 : MPTVAL=IVADEP
796 : DO 2049 IGAU=1,NBNN
797 : DO 2049 ICOMP=1,NDEP
798 : IE=IE+1
799 : MELVAL=IVAL(ICOMP)
800 : IF (MELVAL.NE.0) THEN
801 : IGMN=MIN(IGAU,VELCHE(/1))
802 : IBMN=MIN(IB ,VELCHE(/2))
803 : XDDL(IE)=VELCHE(IGMN,IBMN)
804 : ELSE
805 : XDDL(IE)=0.D0
806 : ENDIF
807 : 2049 CONTINUE
808 :
809 : C
809 : CALL MATVEC(XDDL,XDDLOC,BPSS,8)
810 : C
811 : C BOUCLE SUR LES POINTS DE GAUSS
812 : C
813 : DO 4049 IGAU=1,NBPGAU
814 : C
815 : C APPEL A BGFCQ4
816 : C
816 : CALL BGFCQ4(IGAU,XEL,SHPTOT,SHPWRK,BGF,DJAC,IERT)
817 : C IERT=1 JACOBIANO <= 0
818 : IF(IERT.EQ.1)THEN
819 : IMESS=321
820 : GO TO 9990
821 : ENDIF
822 : C
822 : CALL BGRDEP(BGF,NGRAF,XDDLOC,LRE,GRADF)
823 : C
824 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRAFLEXI
825 : C
826 : MPTVAL=IVAGRF
827 : DO 9049 IC=1,NGRAF
828 : MELVAL=IVAL(IC)
829 : IGMN=MIN(IGAU,VELCHE(/1))
830 : IBMN=MIN(IB ,VELCHE(/2))
831 : IF (IC.EQ.3.OR.IC.GE.6) THEN
832 : VELCHE(IGMN,IBMN)=0.D0
833 : ELSE
834 : VELCHE(IGMN,IBMN)=GRADF(IC)
835 : ENDIF
836 : 9049 CONTINUE
837 : C
838 : 4049 CONTINUE
839 : 3049 CONTINUE
840 : GO TO 510
841 :
842 : C
843 : C COQ2
844 : C
845 : 44 CONTINUE
846 : NBNO=NBNN
847 : SEGINI MWRK1,MWRK2
848 : C
849 : NDDD=NDEP
850 : IF (IFOUR.EQ.-3) NDDD=NDEP-3
851 : DO 3044 IB=1,NBELEM
852 : C
853 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
854 : C
854 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
855 : C
856 : C ON CHERCHE LES DEPLACEMENTS
857 : C
858 : MPTVAL=IVADEP
859 : IE=1
860 : DO 2044 IGAU=1,NBNN
861 : DO 2044 ICOMP=1,NDDD
862 : MELVAL=IVAL(ICOMP)
863 : IGMN=MIN(IGAU,VELCHE(/1))
864 : IBMN=MIN(IB ,VELCHE(/2))
865 : XDDL(IE)=VELCHE(IGMN,IBMN)
866 : IE=IE+1
867 : 2044 CONTINUE
868 : IF (IFOUR.EQ.-3) THEN
869 : XDDL(IE)=UZDPG
870 : XDDL(IE+1)=RYDPG
871 : XDDL(IE+2)=RXDPG
872 : ENDIF
873 : C
874 : C BOUCLE SUR LES POINTS DE GAUSS
875 : C
876 : DO 4044 IGAU=1,NBPGAU
877 : MPTVAL=IVACAR
878 : IF (IVAL(2).NE.0) THEN
879 : MELVAL=IVAL(2)
880 : IBMN=MIN(IB,VELCHE(/2))
881 : EXCEN=VELCHE(1,IBMN)
882 : ELSE
883 : EXCEN=0.D0
884 : ENDIF
885 : C APPEL A BGFCQ2
886 : C
886 : CALL BGFCQ2(BGF,NGRAF,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU,
887 : . EXCEN,1.D0,IRR,XDPGE,YDPGE)
888 : C
889 : C GESTION D'ERREUR
890 : C
891 : IF (IRR.EQ.1) THEN
892 : INTERR(1)=IB
892 : CALL ERREUR(255)
893 : GOTO 9990
894 : ELSE IF(IRR.EQ.2) THEN
895 : INTERR(1)=IB
895 : CALL ERREUR(256)
896 : GOTO 9990
897 : ENDIF
898 : C
898 : CALL BST(BGF,XDDL,LRE,NGRAF,GRADF)
899 : C
900 : C REMPLISSAGE DU SEGMENT CONTENANT LES GRADIENTS DE FLEXION
901 : C
902 : MPTVAL=IVAGRF
903 : DO 9044 ICOMP=1,NGRAF
904 : MELVAL=IVAL(ICOMP)
905 : IGMN=MIN(IGAU,VELCHE(/1))
906 : IBMN=MIN(IB ,VELCHE(/2))
907 : VELCHE(IGMN,IBMN)=GRADF(ICOMP)
908 : 9044 CONTINUE
909 : 4044 CONTINUE
910 : 3044 CONTINUE
911 : C
912 : GOTO 510
913 :
914 :
915 : C
916 : C POUTRE, TUYA, TIMO
917 : C
918 :
919 : 29 CONTINUE
920 : NBNO=NBNN
921 : NBBB=NBNN
922 :
923 : SEGINI MWRK1,MWRK3
924 : DO 3029 IB=1,NBELEM
925 : C
926 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
927 : C
927 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
928 : C
929 : C ON CHERCHE LES DEPLACEMENTS
930 : C
931 : IE=0
932 : MPTVAL=IVADEP
933 : DO 4029 IGAU=1,NBNN
934 : DO 4029 ICOMP=1,NDEP
935 : IE=IE+1
936 : MELVAL=IVAL(ICOMP)
937 : IF (MELVAL.NE.0) THEN
938 : IGMN=MIN(IGAU,VELCHE(/1))
939 : IBMN=MIN(IB ,VELCHE(/2))
940 : XDDL(IE)=VELCHE(IGMN,IBMN)
941 : ELSE
942 : XDDL(IE)=0.D0
943 : ENDIF
944 : 4029 CONTINUE
945 : C
946 : C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
947 : C
947 : CALL ZERO(WORK,NCAR,1)
948 : DO 5029 IGAU=1,NBNN
949 : MPTVAL=IVACAR
950 : DO 6029 IC=1,NCAR
951 : IF(IVAL(IC).NE.0) THEN
952 : MELVAL=IVAL(IC)
953 : IBMN=MIN(IB,VELCHE(/2))
954 : IGMN=MIN(IGAU,VELCHE(/1))
955 : IF(IGMN.GT.0.AND.IBMN.GT.0) THEN
956 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
957 : ELSE
958 : WORK(IC)=0.
959 : ENDIF
960 : ELSE
961 : WORK(IC)=0.
962 : ENDIF
963 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
964 : 6029 CONTINUE
965 : 5029 CONTINUE
966 : C
967 : C CAS OU ON A LU LE MOT VECTEUR
968 : C
969 : IF (IFOUR.EQ.2) THEN
970 : C
971 : IF (IVECT.EQ.1) THEN
972 : IF (IVAL(NCAR).NE.0) THEN
973 : MELVAL=IVAL(NCAR)
974 : IBMN=MIN(IB,IELCHE(/2))
975 : IP=IELCHE(1,IBMN)
976 : IREF=(IP-1)*(IDIM+1)
977 : DO 6129 IC=1,IDIM
978 : WORK(NCAR+IC-1)=XCOOR(IREF+IC)
979 : 6129 CONTINUE
980 : ELSE
981 : DO 6229 IC=1,IDIM
982 : WORK(NCAR+IC-1)=0.D0
983 : 6229 CONTINUE
984 : ENDIF
985 : ENDIF
986 : C
987 : ENDIF
988 : C
989 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
990 : C EQUIVALENTE
991 : IF(MELE.EQ.42) THEN
992 : CISA=WORK(4)
993 : VX=WORK(5)
994 : VY=WORK(6)
995 : VZ=WORK(7)
995 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
996 : ENDIF
997 : C
998 : C ON CALCULE LES GRADIENTS
999 : C
1000 : IF(MELE.EQ.84) THEN
1001 : C
1002 : IF(CMATE.EQ.'SECTION') THEN
1003 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
1003 : CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
1004 : ELSE
1004 : CALL TIMGF1(XE,XDDL,WORK(1),WORK(12),WORK(25))
1005 : ENDIF
1006 : ELSE
1007 : C
1008 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
1008 : CALL TIMGF2(XE,XDDL,WORK(12),WORK(25))
1009 : C
1010 : ELSE
1010 : CALL TIMGF1(XE,XDDL,WORK(7),WORK(12),WORK(25))
1011 : ENDIF
1012 : ENDIF
1013 : ELSE
1014 : C
1015 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
1015 : CALL POUGF2(XE,XDDL,WORK,WORK(12),WORK(25))
1016 : ELSE
1017 : C
1017 : CALL POUGF1(XE,XDDL,WORK,WORK(12),WORK(25))
1018 : ENDIF
1019 : ENDIF
1020 :
1021 : * REMPLISSAGE
1022 :
1023 : DO iGau=1,NBPGAU
1024 : MPTVAL=IVAGRF
1025 : DO i=1,NGRAF
1026 : MELVAL=IVAL(i)
1027 : IGMN=MIN(iGau,VELCHE(/1))
1028 : IBMN=MIN(IB,VELCHE(/2))
1029 : * IDECA=11+I+(IGAU-1)*NGRAF
1030 : VELCHE(IGMN,IBMN)=WORK(I)
1031 : ENDDO
1032 : ENDDO
1033 : 3029 CONTINUE
1034 : GOTO 510
1035 : C
1036 : C JOINT UNIDIMENSIONNELS JOI1
1037 : C
1038 : 265 CONTINUE
1039 : NBNO=NBNN
1040 : NBBB=NBNN
1041 : SEGINI MWRK1,MWRK3,MWRK4
1042 : DO 3265 IB=1,NBELEM
1043 : C
1044 : C RANGEMENT DES CARACTERISTIQUES DANS WORK
1045 : C
1046 : MPTVAL=IVAMAT
1047 : DO IC=1,NMATT
1048 : IF(IVAL(IC).NE.0) THEN
1049 : MELVAL=IVAL(IC)
1050 : IBMN=MIN(IB,VELCHE(/2))
1051 : WORK(IC)=VELCHE(1,IBMN)
1052 : ELSE
1053 : WORK(IC)=0.D0
1054 : ENDIF
1055 : END DO
1056 : C
1056 : CALL MAPALU(NMATT,WORK,BPSS,IDIM)
1057 : C
1058 : C ON CHERCHE LES DEPLACEMENTS
1059 : C
1060 : IE=0
1061 : MPTVAL=IVADEP
1062 : DO 4265 IGAU=1,NBNN
1063 : DO 4265 ICOMP=1,NDEP
1064 : IE=IE+1
1065 : MELVAL=IVAL(ICOMP)
1066 : IF (MELVAL.NE.0) THEN
1067 : IGMN=MIN(IGAU,VELCHE(/1))
1068 : IBMN=MIN(IB ,VELCHE(/2))
1069 : XDDL(IE)=VELCHE(IGMN,IBMN)
1070 : ELSE
1071 : XDDL(IE)=0.D0
1072 : ENDIF
1073 : 4265 CONTINUE
1074 : C
1075 : C CALCUL DES DEPLACEMENTS LOCAUX
1076 : C
1077 : IAW1 = 101
1078 : IAW2 = IAW1 + LRE
1078 : CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
1079 : C
1080 : C ON CALCULE LES GRADIENTS
1081 : C
1081 : CALL JOIGF1(XDDL,WORK,LRE,NGRAF,IDIM)
1082 : * REMPLISSAGE
1083 : DO iGau=1,NBPGAU
1084 : MPTVAL=IVAGRF
1085 : DO i=1,NGRAF
1086 : MELVAL=IVAL(i)
1087 : IGMN=MIN(iGau,VELCHE(/1))
1088 : IBMN=MIN(IB,VELCHE(/2))
1089 : IDECA=11+I+(IGAU-1)*NGRAF
1090 : VELCHE(IGMN,IBMN)=WORK(IDECA)
1091 : ENDDO
1092 : ENDDO
1093 : 3265 CONTINUE
1094 : GOTO 510
1095 :
1096 : C
1097 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
1098 : C
1099 : 510 CONTINUE
1100 : * Desactivation des segments
1101 : *
1102 : IF (MWRK1.NE.0) SEGSUP,MWRK1
1103 : IF (MWRK2.NE.0) SEGSUP,MWRK2
1104 : IF (MWRK3.NE.0) SEGSUP,MWRK3
1105 : IF (MWRK4.NE.0) SEGSUP,MWRK4
1106 : IF (MVELCH.NE.0) SEGSUP,MVELCH
1107 : *
1107 : CALL DTMVAL(IVADEP,1)
1108 : *
1108 : CALL DTMVAL(IVAMAT,1)
1109 : *
1109 : CALL DTMVAL(IVACAR,1)
1110 : *
1110 : CALL DTMVAL(IVAGRF,1)
1111 : *
1112 : NOMID=MODEPL
1113 : if(lsupdp)SEGSUP NOMID
1114 : NOMID=MOGRAF
1115 : if(lsupgf)SEGSUP NOMID
1116 : IF (MOMATR.NE.0) THEN
1117 : NOMID=MOMATR
1118 : SEGSUP NOMID
1119 : ENDIF
1120 : IF (MOCARA.NE.0) THEN
1121 : NOMID=MOCARA
1122 : SEGSUP NOMID
1123 : ENDIF
1124 : *
1125 : * SEGSUP INFO
1126 : SEGDES,IMODEL,MELEME
1127 : SEGDES,MCHAML,MINTE
1128 : *
1129 : 500 CONTINUE
1130 : SEGDES,MMODEL,MCHELM
1130 : * CALL DTCHAM(IPCHE2)
1131 : *
1132 : RETURN
1133 : *
1134 : 9990 CONTINUE
1135 : *
1136 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
1137 : *
1138 : IRET=0
1139 : *
1140 : * Gestion des messages d'erreur
1141 : *
1142 : IF (IMESS.NE.0) THEN
1143 : INTERR(1) = IB
1143 : CALL ERREUR(IMESS)
1144 : ENDIF
1145 : *
1146 : IF (MWRK1.NE.0) SEGSUP,MWRK1
1147 : IF (MWRK2.NE.0) SEGSUP,MWRK2
1148 : IF (MWRK3.NE.0) SEGSUP,MWRK3
1149 : IF (MWRK4.NE.0) SEGSUP,MWRK4
1150 : IF (MVELCH.NE.0) SEGSUP,MVELCH
1151 : *
1151 : CALL DTMVAL(IVADEP,1)
1152 : *
1152 : CALL DTMVAL(IVAMAT,1)
1153 : *
1153 : CALL DTMVAL(IVACAR,1)
1154 : *
1154 : CALL DTMVAL(IVAGRF,3)
1155 : *
1156 : IF(MODEPL.NE.0.and.lsupdp) THEN
1157 : NOMID=MODEPL
1158 : SEGSUP NOMID
1159 : ENDIF
1160 : *
1161 : IF(MOGRAF.NE.0)THEN
1162 : NOMID=MOGRAF
1163 : if(lsupgf)SEGSUP NOMID
1164 : ENDIF
1165 : *
1166 : IF (MOCARA.NE.0) THEN
1167 : NOMID=MOCARA
1168 : SEGSUP NOMID
1169 : ENDIF
1170 : *
1171 : IF (MOMATR.NE.0) THEN
1172 : NOMID=MOMATR
1173 : SEGSUP NOMID
1174 : ENDIF
1175 : *
1176 : SEGDES MELEME
1177 : SEGDES IMODEL
1178 : *
1179 : SEGDES MMODEL
1180 : IF (IPCHE1.NE.0) THEN
1181 : MCHELM=IPCHE1
1182 : SEGDES MCHELM
1183 : ENDIF
1184 : *
1184 : * IF (IPCHE2.NE.0) CALL DTCHAM(IPCHE2)
1185 : SEGDES MINTE
1186 : * SEGSUP INFO
1187 :
1188 : RETURN
1189 : END
1190 :
1191 :
1192 :
1193 :
1194 :
1195 :
1196 :
1197 :
1198 :
1199 :
1200 :
1201 :
1202 :
1203 :
1204 :
1205 :
1206 :
1207 :
© Cast3M 2003 - All rights reserved.
Disclaimer