1 : C PIOCAP SOURCE PV 12/06/08 21:15:01 7395
2 : SUBROUTINE PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,
3 : . IM,IPCHE2,IRET)
4 : C_______________________________________________________________________
5 : C
6 : C
7 : C Entr{es:
8 : C ________
9 : C
10 : C IPMODL Pointeur sur un MMODEL
11 : C IPCHE1 Pointeur sur un MCHAML de contraintes de KIRCHHOFF
12 : C OU DE DEFORMATIONS
13 : C IPCHP1 Pointeur sur le CHAMPOINT d{placements entre
14 : C configuration de depart et arrivee
15 : C IM Flag ,= 0 KIRCHHOFF------> CAUCHY
16 : C = 1 CAUCHY-------> KIRCHHOFF
17 : C attention si derivee de jauman on fait RTENS RART avec R matrice
18 : C de rotation
19 : C Sorties:
20 : C ________
21 : C
22 : C IPCHE2 Pointeur sur un MCHAML de CONTRAINTES
23 : C OU DE DEFORMATIONS
24 : C IRET 1 ou 0 suivant succes ou pas
25 : C
26 : C
27 : C PASSAGE AUX NOUVEAUX CHAMELEMS PAR P.DOWLATYARI LE 12/4/91
28 : C_______________________________________________________________________
29 : C
30 : IMPLICIT INTEGER(I-N)
31 : IMPLICIT REAL*8(A-H,O-Z)
32 : *
33 : -INC CCOPTIO
34 : -INC CCHAMP
35 : -INC SMCHAML
36 : -INC SMCHPOI
37 : -INC SMELEME
38 : -INC SMCOORD
39 : -INC SMMODEL
40 : -INC SMINTE
41 : -INC SMLREEL
42 : C
43 : SEGMENT MWRK1
44 : REAL*8 XE(3,NBNN) ,XE1(3,NBNN) ,XE2(3,NBNN)
45 : ENDSEGMENT
46 : *
47 : SEGMENT MWRK2
48 : REAL*8 SHPWRK(6,NBNN)
49 : ENDSEGMENT
50 : *
51 : SEGMENT MWRK3
52 : REAL*8 STRESS(NBPTEL,NSTRS),STRES1(NBPTEL,NSTRS)
53 : ENDSEGMENT
54 : *
55 : SEGMENT MWRK4
56 : REAL*8 XEL(3,3), BPSS (3,3), XDDL(18), XDDLOC(18)
57 : ENDSEGMENT
58 : SEGMENT NOTYPE
59 : CHARACTER*16 TYPE(NBTYPE)
60 : ENDSEGMENT
61 : *
62 : SEGMENT MWRK5
63 : REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
64 : REAL*8 TENS(9),tentra(9),xddls2(lre)
65 : ENDSEGMENT
66 : SEGMENT MPTVAL
67 : INTEGER IPOS(NS) ,NSOF(NS)
68 : INTEGER IVAL(NCOSOU)
69 : CHARACTER*16 TYVAL(NCOSOU)
70 : ENDSEGMENT
71 : *
72 : *as xfem 2010_01_13
73 : SEGMENT MRACC
74 : INTEGER TLREEL(NBNN)
75 : ENDSEGMENT
76 :
77 : SEGMENT TABA
78 : REAL*8 TABA1(IDIM,NBNN),TABA2(IDIM,NBNN)
79 : ENDSEGMENT
80 : *fin as xfem 2010_01_13
81 :
82 : CHARACTER*(NCONCH) CONM
83 : PARAMETER ( NINF=3 )
84 : INTEGER INFOS(NINF)
85 : *as xfem 2010_01_22
86 : LOGICAL lsupdp,lsupno,lsupdp0
87 : C
88 : NHRM=NIFOUR
89 : IRET=0
90 : IMESS=0
91 : *
92 : * Verification du lieu support du MCHAML
93 : *
93 : call reduaf(ipche1,ipmodl,ipch,0,iretou,kerr)
93 : if (iretou.ne.1) call erreur(kerr)
94 : if (ierr.ne.0) return
95 : ipche1=ipch
95 : CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP,IRET2)
96 : IF (ISUP.GT.1) RETURN
97 : c
98 : *as xfem 2010_01_13
99 : * Calcul du niveau d'enrichissement du modèle :
100 : IF (ichax1.ne.0) then
101 : ipchp2=0
102 : MCHAM1=ICHAX1
103 : SEGACT MCHAM1
104 : nbenr1=MCHAM1.IELVAL(/1)
105 : if (nbenr1.gt.1) then
106 : SEGDES,MCHAM1
107 : write(ioimp,*) 'XFEM : on ne sait pas traiter les grandes ',
108 : & 'transformations avec un niveau denrichissement >1'
108 : CALL ERREUR(21)
109 : return
110 : endif
111 : * Calcul des déplacements vrais :
111 : call XPOST1(IPCHP1,IPMODL,IPCHP2)
112 : ENDIF
113 : *fin as xfem 2010_01_13
114 : *
115 : * CONTRAINTES (KCAS=1) OU DEFORMATIONS (KCAS=2) ?
116 : *
117 : MCHELM=IPCHE1
118 : SEGACT MCHELM
119 : IF (TITCHE.EQ.'CONTRAINTES') THEN
120 : KCAS=1
121 : ELSE IF(TITCHE.EQ.'DEFORMATIONS') THEN
122 : KCAS=2
123 : ELSE
124 : MOTERR(1:8)='CONTRAIN'
125 : MOTERR(9:16)='DEFORMAT'
125 : CALL ERREUR(109)
126 : SEGDES MCHELM
127 : RETURN
128 : ENDIF
129 : SEGDES MCHELM
130 : C
131 : C ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT
132 : C____________________________________________________________________
133 : C
133 : CALL CHAME1(0,IPMODL,IPCHP1,' ',IPCHE3,1)
134 : *as xfem 2010_01_13
135 : if(ichax1.ne.0) then
136 : * IPCHP1 : Deplacement enrichi : config initiale -> config finale
137 : * Deplacement enrichi : config de reference -> config finale
137 : CALL CHAME1(0,IPMODL,IPCHP0,' ',IPCHE0,1)
138 : * Deplacement vrai : config initiale -> config finale
138 : CALL CHAME1(0,IPMODL,IPCHP2,' ',IPCHE4,1)
139 : endif
140 : *fin as xfem 2010_01_13
141 : C
142 : C ACTIVATION DU MODELE
143 : C
144 : MMODEL=IPMODL
145 : SEGACT MMODEL
146 : NSOUS=KMODEL(/1)
147 : C
148 : C CREATION DU MCHELM
149 : C
150 : N1=NSOUS
151 : IF (KCAS.EQ.1) L1=11
152 : IF (KCAS.EQ.2) L1=12
153 : N3=6
154 : SEGINI MCHELM
155 : IF(KCAS.EQ.1) TITCHE='CONTRAINTES'
156 : IF(KCAS.EQ.2) TITCHE='DEFORMATIONS'
157 : IFOCHE=IFOUR
158 : IPCHE2=MCHELM
159 : C____________________________________________________________________
160 : C
161 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
162 : C____________________________________________________________________
163 : C
164 : DO 500 ISOUS=1,NSOUS
165 : C
166 : C INITIALISATION
167 : C
168 : MWRK1=0
169 : MWRK2=0
170 : MWRK3=0
171 : MWRK4=0
172 : IVADEP=0
173 : NDEP=0
174 : IVAST1=0
175 : IVASTR=0
176 : NSTR=0
177 : MODEPV=0
178 : MODEPL=0
179 : MOSTRS=0
180 : C
181 : C ON RECUPERE L INFORMATION GENERALE
182 : C
183 : IMODEL=KMODEL(ISOUS)
184 : SEGACT IMODEL
185 : IPMAIL=IMAMOD
186 : IMACHE(ISOUS)=IPMAIL
187 : CONCHE(ISOUS)=CONMOD
188 : CONM=CONMOD
189 : C
190 : C TRAITEMENT DU MODELE
191 : C
192 : MELE=NEFMOD
193 : MELEME=IMAMOD
194 : ideri=ideriv
195 : C____________________________________________________________________
196 : C
197 : C INFORMATION SUR L'ELEMENT FINI
198 : C____________________________________________________________________
199 : C
199 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
200 : * IF (IERR.NE.0) THEN
201 : * SEGDES IMODEL,MMODEL
202 : * SEGSUP MCHELM
202 : * CALL DTCHAM(IPCHE3)
203 : * RETURN
204 : * ENDIF
205 : * INFO=IPINF
206 : MFR =INFELE(13)
207 : IPORE=INFELE(8)
208 : NBG =INFELE(6)
209 : NBGS =INFELE(4)
210 : NSTRS=INFELE(16)
211 : LRE =INFELE(9)
212 : LW =INFELE(7)
213 : LHOOK=INFELE(10)
214 : LHOO2=LHOOK*LHOOK
215 : NDDL =INFELE(15)
216 : * MINTE=INFELE(11)
217 : minte=infmod(7)
218 : IPMINT=MINTE
219 : MINTE1=INFMOD(8)
220 : * SEGSUP INFO
221 : C
222 : C CREATION DU TABLEAU INFOS
223 : C
224 : INFOS(1)=0
225 : INFOS(2)=0
226 : INFOS(3)=NIFOUR
227 : C
228 : INFCHE(ISOUS,1)=0
229 : INFCHE(ISOUS,2)=0
230 : INFCHE(ISOUS,3)=NHRM
231 : INFCHE(ISOUS,4)=MINTE
232 : INFCHE(ISOUS,5)=0
233 : INFCHE(ISOUS,6)=5
234 : C
235 : C INITIALISATION DE MINTE
236 : C
237 : SEGACT MINTE
238 : NBPGAU=POIGAU(/1)
239 : C
240 : C ACTIVATION DU MELEME
241 : C
242 : SEGACT MELEME
243 : NBNN =NUM(/1)
244 : NBELEM=NUM(/2)
245 : *as xfem 2010_01_13
246 : if (MFR.eq.63) then
247 : NBSH=INFELE(8)
248 : else
249 : NBSH=NBNN
250 : endif
251 : *fin as xfem 2010_01_13
252 : IPPORE=0
253 : IF(MFR.EQ.33) IPPORE=NBNN
254 : C____________________________________________________________________
255 : C
256 : C RECHERCHE DES NOMS DE COMPOSANTES
257 : C____________________________________________________________________
258 : C
259 : lsupno=.false.
260 : IF(KCAS.EQ.1) THEN
261 : if(lnomid(4).ne.0) then
262 : nomid=lnomid(4)
263 : segact nomid
264 : mostrs=nomid
265 : nstr=lesobl(/2)
266 : nfac=lesfac(/2)
267 : else
268 : lsupno=.true.
268 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
269 : endif
270 : ENDIF
271 : IF(KCAS.EQ.2) THEN
272 : if(lnomid(5).ne.0) then
273 : nomid=lnomid(5)
274 : segact nomid
275 : nstr=lesobl(/2)
276 : mostrs=nomid
277 : nfac=lesfac(/2)
278 : else
279 : lsupno=.true.
279 : CALL IDDEFO(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
280 : endif
281 : ENDIF
282 : C
283 : if(lnomid(1).ne.0) then
284 : nomid=lnomid(1)
285 : segact nomid
286 : modepl=nomid
287 : ndep=lesobl(/2)
288 : nfac=lesfac(/2)
289 : lsupdp=.false.
290 : else
291 : lsupdp=.true.
291 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEP,NFAC)
292 : endif
293 : if(ideri.eq.4) then
294 : IF(LNOMID(3).NE.0) then
295 : MOGRAD=LNOMID(3)
296 : NOMID=MOGRAD
297 : SEGACT,NOMID
298 : NGRA=LESOBL(/2)
299 : segdes nomid
300 : ELSE
300 : CALL IDGRAD(MDM,IFOUR,MOGRAD,NGRA,NFAC)
301 : NOMID=MOGRAD
302 : SEGACT,NOMID
303 : NGRA=LESOBL(/2)
304 : segdes nomid
305 : ENDIF
306 : endif
307 :
308 : *as xfem 2010_01_13
309 : * On récupère les noms des composantes du cas massif, pour les depl. vrais
310 : lsupdp0=.false.
311 : IF (ichax1.ne.0) then
311 : call iddepl(1,IFOUR,MODEPV,NDEPV,NFACV)
312 : * as 2010_01_22
313 : lsupdp0=.true.
314 : ENDIF
315 : *fin as xfem 2010_01_13
316 :
317 : C____________________________________________________________________
318 : C
319 : C VERIFICATION DE LEUR PRESENCE
320 : C____________________________________________________________________
321 : C
322 : NBTYPE=1
323 : SEGINI NOTYPE
324 : MOTYPE=NOTYPE
325 : TYPE(1)='REAL*8'
325 : CALL KOMCHA(IPCHE3,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP)
326 : *as xfem 2010_01_13
327 : if (ichax1.ne.0) then
327 : call KOMCHA(IPCHE0,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP0)
327 : call KOMCHA(IPCHE4,IPMAIL,CONM,MODEPV,MOTYPE,1,INFOS,3,IVADEPV)
328 : endif
329 : *fin as xfem 2010_01_13
330 : IF (IERR.NE.0)THEN
331 : SEGSUP NOTYPE
332 : GOTO 9990
333 : ENDIF
334 : C
334 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVAST1)
335 : SEGSUP NOTYPE
336 : IF (IERR.NE.0) GOTO 9990
337 : IF (ISUP.EQ.1) THEN
337 : CALL VALCHE(IVAST1,NSTR,IPMINT,IPPORE)
338 : ENDIF
339 : C
340 : C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
341 : C
342 : N1PTEL=NBGS
343 : N1EL=NBELEM
344 : NBPTEL=N1PTEL
345 : NEL=N1EL
346 : C
347 : C CREATION DU MCHAML DE LA SOUS ZONE
348 : C
349 : N2=NSTRS
350 : SEGINI MCHAML
351 : ICHAML(ISOUS)=MCHAML
352 : NS=1
353 : NCOSOU=NSTRS
354 : SEGINI MPTVAL
355 : IVASTR=MPTVAL
356 : NOMID=MOSTRS
357 : SEGACT NOMID
358 : DO 100 ICOMP=1,NSTRS
359 : NOMCHE(ICOMP)=LESOBL(ICOMP)
360 : TYPCHE(ICOMP)='REAL*8'
361 : N2PTEL=0
362 : N2EL=0
363 : SEGINI MELVAL
364 : IELVAL(ICOMP)=MELVAL
365 : IVAL(ICOMP)=MELVAL
366 : 100 CONTINUE
367 : SEGDES NOMID
368 : C
369 : *as xfem 2010_01_13
370 : IF(MFR.EQ.1.or.MFR.EQ.63)THEN
371 : SEGINI,MWRK1,MWRK2,MWRK3
372 : ELSE IF(MFR.EQ.3)THEN
373 : SEGINI,MWRK1,MWRK2,MWRK3,MWRK4
374 : ELSE
375 : SEGINI,MWRK3
376 : ENDIF
377 : C
378 : C ---------------------------------------------------
379 : C TRANSFORMATION DES TENSEURS SI ELEMENTS MASSIFS sauf shb8
380 : C ---------------------------------------------------
381 : IF((MFR.EQ.1.or.MFR.EQ.63).and.mele.ne.260)THEN
382 :
383 : *as xfem 2010_01_13
384 : IF(MFR.EQ.63) then
385 : SEGINI,MRACC
386 : SEGINI,TABA
387 : SEGACT,MCHAM1
388 : ENDIF
389 : *fin as xfem 2010_01_13
390 : C
391 : C BOUCLE SUR LES ELEMENTS
392 : C
393 : DO 200 IB=1,NBELEM
394 :
395 : *as xfem 2010_01_13
396 : * Cacul du niveau d'enrichissement de l'élément :
397 : nbenrj=0
398 : if (ichax1.ne.0) then
399 : if (nbenr1.ne.0) then
400 : MELVA1=MCHAM1.IELVAL(1)
401 : SEGACT MELVA1
402 : do i=1,NBNN
403 : mlree1=MELVA1.IELCHE(I,IB)
404 : tlreel(i)=mlree1
405 : if (mlree1.ne.0) then
406 : nbenrj=max(nbenrj,1)
407 : segact,mlree1
408 : endif
409 : enddo
410 : segdes MELVA1
411 : endif
412 : endif
413 : *fin as xfem 2010_01_13
414 :
415 : C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
416 : C
416 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
417 : C
418 : IF(IM.EQ.0)THEN
419 : DO 220 INO=1,NBNN
420 : DO 220 ID=1,IDIM
421 : XE1(ID,INO)=XE(ID,INO)
422 : 220 CONTINUE
423 : C
424 : *as xfem 2010_01_13
425 : if (nbenrj.eq.0) then
426 : MPTVAL=IVADEP
427 : else
428 : MPTVAL=IVADEPV
429 : endif
430 : *fin as xfem 2010_01_13
431 : DO 230 INO=1,NBNN
432 : DO 230 ID=1,IDIM
433 : MELVAL=IVAL(ID)
434 : IBMN=MIN(IB,VELCHE(/2))
435 : INMN=MIN(INO,VELCHE(/1))
436 : XE2(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
437 : 230 CONTINUE
438 : C
439 : *as xfem 2010_01_13
440 : * Si élément enrichi :
441 : if (nbenrj.ne.0) then
442 : * Stockage des sauts config. initiale -> config de reference
443 : MPTVAL=IVADEP0
444 : do INO=1,NBNN
445 : DO ID=1,IDIM
446 : MELVAL=IVAL(ID+IDIM)
447 : IBMN=MIN(IB,VELCHE(/2))
448 : INMN=MIN(INO,VELCHE(/1))
449 : TABA1(ID,INO)=VELCHE(INMN,IBMN)
450 : ENDDO
451 : enddo
452 : * Stockage des sauts config. initiale -> config finale
453 : MPTVAL=IVADEP
454 : do INO=1,NBNN
455 : DO ID=1,IDIM
456 : MELVAL=IVAL(ID+IDIM)
457 : IBMN=MIN(IB,VELCHE(/2))
458 : INMN=MIN(INO,VELCHE(/1))
459 : TABA2(ID,INO)= TABA1(ID,INO) + VELCHE(INMN,IBMN)
460 : ENDDO
461 : enddo
462 : endif
463 : *fin as xfem 2010_01_13
464 : ELSE
465 : *as xfem 2010_01_13
466 : if (nbenrj.eq.0) then
467 : MPTVAL=IVADEP
468 : else
469 : MPTVAL=IVADEPV
470 : endif
471 : *fin as xfem 2010_01_13
472 : DO 210 INO=1,NBNN
473 : DO 210 ID=1,IDIM
474 : MELVAL=IVAL(ID)
475 : IBMN=MIN(IB,VELCHE(/2))
476 : INMN=MIN(INO,VELCHE(/1))
477 : XE1(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
478 : 210 CONTINUE
479 : DO 215 INO=1,NBNN
480 : DO 215 ID=1,IDIM
481 : XE2(ID,INO)=XE(ID,INO)
482 : 215 CONTINUE
483 :
484 : *as xfem 2010_01_13
485 : * Si élément enrichi :
486 : if (nbenrj.ne.0) then
487 : * Stockage des sauts config. initiale -> config de reference
488 : MPTVAL=IVADEP0
489 : do INO=1,NBNN
490 : DO ID=1,IDIM
491 : MELVAL=IVAL(ID+IDIM)
492 : IBMN=MIN(IB,VELCHE(/2))
493 : INMN=MIN(INO,VELCHE(/1))
494 : TABA2(ID,INO)=VELCHE(INMN,IBMN)
495 : ENDDO
496 : enddo
497 : * Stockage des sauts config. initiale -> config finale
498 : MPTVAL=IVADEP
499 : do INO=1,NBNN
500 : DO ID=1,IDIM
501 : MELVAL=IVAL(ID+IDIM)
502 : IBMN=MIN(IB,VELCHE(/2))
503 : INMN=MIN(INO,VELCHE(/1))
504 : TABA1(ID,INO)= TABA2(ID,INO) + VELCHE(INMN,IBMN)
505 : ENDDO
506 : enddo
507 : endif
508 : *fin as xfem 2010_01_13
509 : ENDIF
510 : C
511 : C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
512 : C OU LES DEFORMATIONS
513 : C
514 : MPTVAL=IVAST1
515 : DO 240 IGAU=1,NBPTEL
516 : DO 240 ICOMP=1,NSTRS
517 : MELVAL=IVAL(ICOMP)
518 : IBMN=MIN(IB,VELCHE(/2))
519 : IGMN=MIN(IGAU,VELCHE(/1))
520 : STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
521 : 240 CONTINUE
522 : C
523 : *as xfem 2010_01_13
524 : if (nbenrj.eq.0) then
525 : if(ideri.eq.4) then
526 : segini mwrk5
526 : call jaucau(NBNN,nbsh,STRES1,NSTRS,NBPTEL,SHPTOT,XE1
527 : 1 ,XE2, BGENE, SHPWRK,STRESS,KCAS,KERRE,mwrk5,
528 : 1 ipmint,mele)
529 : kerre=0
530 : elseif(ideri.eq.5) then
531 : kerre=0
532 : do igau=1,nbptel
533 : do icomp=1,nstrs
534 : MELVAL=IVAL(ICOMP)
535 : IBMN=MIN(IB,VELCHE(/2))
536 : IGMN=MIN(IGAU,VELCHE(/1))
537 : STRESS(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
538 : enddo
539 : enddo
540 : else
540 : CALL PIOCAF(NBNN,nbsh,IDIM,STRES1,NSTRS,NBPTEL,SHPTOT,XE1
541 : 1 ,XE2, SHPWRK,STRESS,IFOUR,KCAS,KERRE)
542 : endif
543 : else
543 : CALL PIOCAX(NBNN,IDIM,STRES1,NSTRS,NBPTEL,IPMINT,XE1,XE2,
544 : 1 TABA,MRACC,SHPWRK,STRESS,IFOUR,KCAS,KERRE)
545 : endif
546 : *fin as xfem 2010_01_13 <
547 : C
548 : IF(KERRE.NE.0) THEN
548 : CALL ERREUR(716)
549 : GO TO 9990
550 : ENDIF
551 : C
552 : C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
553 : C
554 : MPTVAL=IVASTR
555 : DO 250 IGAU=1,NBPTEL
556 : DO 250 ICOMP=1,NSTRS
557 : MELVAL=IVAL(ICOMP)
558 : IBMN=MIN(IB,VELCHE(/2))
559 : VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
560 : 250 CONTINUE
561 :
562 : 200 CONTINUE
563 :
564 : *as xfem 2010_01_27
565 : IF(MFR.EQ.63) then
566 : SEGSUP,MRACC
567 : SEGSUP,TABA
568 : SEGDES,MCHAM1
569 : ENDIF
570 : *fin as xfem 2010_01_13
571 : C
572 : C ---------------------------------------------------
573 : C TRANSFORMATION DES TENSEURS SI ELEMENTS DKT
574 : C ---------------------------------------------------
575 : * supprime le 08/06/12 car inutile et donne un resultat faux
576 : *
577 : ************************************************************
578 :
579 : ELSE IF(MFR.EQ.3.and.MELE.EQ.28.and.(.false.))THEN
580 : C
581 : DO 3028 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=1
589 : DO 4028 IGAU=1,NBNN
590 : MPTVAL=IVADEP
591 : DO 4028 ICOMP=1,NDEP
592 : MELVAL=IVAL(ICOMP)
593 : IGMN=MIN(IGAU,VELCHE(/1))
594 : IBMN=MIN(IB ,VELCHE(/2))
595 : XDDL(IE)=VELCHE(IGMN,IBMN)
596 : IE=IE+1
597 : 4028 CONTINUE
598 : C
598 : CALL VPAST(XE,BPSS)
599 : C BPSS STOCKE LA MATRICE DE PASSAGE
599 : CALL VCORLC (XE,XEL,BPSS)
599 : CALL MATVEC(XDDL,XDDLOC,BPSS,6)
600 : C
601 : C
602 : C ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
603 : C
604 : IF(IM.EQ.0)THEN
605 : DO 320 INO=1,NBNN
606 : DO 320 ID=1,IDIM
607 : XE1(ID,INO)=XEL(ID,INO)
608 : 320 CONTINUE
609 : C
610 : IG=-6
611 : MPTVAL=IVADEP
612 : DO 330 INO=1,NBNN
613 : IE=1
614 : IG=IG+6
615 : DO 330 ID=1,IDIM
616 : MELVAL=IVAL(ID)
617 : IBMN=MIN(IB,VELCHE(/2))
618 : INMN=MIN(INO,VELCHE(/1))
619 : XE2(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
620 : IE = IE + 1
621 : 330 CONTINUE
622 : C
623 : ELSE
624 : IG=-6
625 : IE = 1
626 : MPTVAL=IVADEP
627 : DO 310 INO=1,NBNN
628 : IE=1
629 : IG=IG+6
630 : DO 310 ID=1,IDIM
631 : MELVAL=IVAL(ID)
632 : IBMN=MIN(IB,VELCHE(/2))
633 : INMN=MIN(INO,VELCHE(/1))
634 : XE1(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
635 : IE = IE + 1
636 : 310 CONTINUE
637 : DO 315 INO=1,NBNN
638 : DO 315 ID=1,IDIM
639 : XE2(ID,INO)=XEL(ID,INO)
640 : 315 CONTINUE
641 : ENDIF
642 : C
643 : C ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
644 : C
645 : MPTVAL=IVAST1
646 : DO 340 IGAU=1,NBPTEL
647 : DO 340 ICOMP=1,NSTRS
648 : MELVAL=IVAL(ICOMP)
649 : IBMN=MIN(IB,VELCHE(/2))
650 : IGMN=MIN(IGAU,VELCHE(/1))
651 : STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
652 : 340 CONTINUE
653 : C
653 : CALL PICAF2(NBNN,2,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
654 : 1 SHPWRK,STRESS,IFOUR,1,KERRE)
655 : C
656 : IF(KERRE.NE.0) THEN
656 : CALL ERREUR(716)
657 : GO TO 9990
658 : ENDIF
659 : C
660 : C ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
661 : C
662 : MPTVAL=IVASTR
663 : DO 350 IGAU=1,NBPTEL
664 : DO 350 ICOMP=1,NSTRS
665 : MELVAL=IVAL(ICOMP)
666 : IBMN=MIN(IB,VELCHE(/2))
667 : VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
668 : 350 CONTINUE
669 : C
670 : 3028 CONTINUE
671 : C
672 : C --------------------
673 : C AUTRES ELEMENTS
674 : C --------------------
675 :
676 : ELSE
677 : C
678 : C
679 : C BOUCLE SUR LES ELEMENTS
680 : C
681 : DO 400 IB=1,NBELEM
682 : C
683 : C POUR LES AUTRES ELEMENTS ,ON COPIE LES CONTRAINTES
684 : C OU LES DEFORMATIONS
685 : C SANS LA TRANSFORMATION
686 : C
687 : MPTVAL=IVAST1
688 : DO 460 IGAU=1,NBPTEL
689 : DO 460 ICOMP=1,NSTRS
690 : MELVAL=IVAL(ICOMP)
691 : IBMN=MIN(IB,VELCHE(/2))
692 : IGMN=MIN(IGAU,VELCHE(/1))
693 : STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
694 : 460 CONTINUE
695 : C
696 : MPTVAL=IVASTR
697 : DO 470 IGAU=1,NBPTEL
698 : DO 470 ICOMP=1,NSTRS
699 : MELVAL=IVAL(ICOMP)
700 : IBMN=MIN(IB,VELCHE(/2))
701 : VELCHE(IGAU,IBMN)=STRES1(IGAU,ICOMP)
702 : 470 CONTINUE
703 : 400 CONTINUE
704 : ENDIF
705 : C
706 : C DESACTIVATION DES SEGMENTS
707 : C
708 : *as xfem 2010_01_13
709 : IF(MFR.EQ.1.or.MFR.eq.63)THEN
710 : SEGSUP,MWRK1,MWRK2,MWRK3
711 : ELSE IF(MFR.EQ.3)THEN
712 : SEGSUP,MWRK1,MWRK2,MWRK3,MWRK4
713 : ELSE
714 : SEGSUP,MWRK3
715 : ENDIF
716 : *
716 : CALL DTMVAL(IVADEP,1)
717 : *
718 : IF(ISUP.EQ.1)THEN
718 : CALL DTMVAL(IVAST1,3)
719 : ELSE
719 : CALL DTMVAL(IVAST1,1)
720 : ENDIF
721 : *
721 : CALL DTMVAL(IVASTR,1)
722 : *
723 : NOMID=MODEPL
724 : if(lsupdp)SEGSUP NOMID
725 : NOMID=MOSTRS
726 : if(lsupno)SEGSUP NOMID
727 : nomid=modepv
728 : if(lsupdp0) SEGSUP NOMID
729 : *
730 : SEGDES,IMODEL,MELEME
731 : SEGDES,MCHAML,MINTE
732 : *
733 : 500 CONTINUE
734 : SEGDES,MMODEL,MCHELM
734 : CALL DTCHAM(IPCHE3)
735 : IRET = 1
736 : *
737 : RETURN
738 : *
739 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
740 : *
741 : 9990 CONTINUE
742 : *
743 : * Gestion des messages d'erreur
744 : *
745 : IF (IMESS.NE.0) THEN
746 : INTERR(1) = IB
746 : CALL ERREUR(IMESS)
747 : ENDIF
748 : *
748 : CALL DTMVAL(IVADEP,1)
749 : *
750 : IF(ISUP.EQ.1)THEN
750 : CALL DTMVAL(IVAST1,3)
751 : ELSE
751 : CALL DTMVAL(IVAST1,1)
752 : ENDIF
753 : *
753 : CALL DTMVAL(IVASTR,3)
754 : *
755 : IF(MODEPL.NE.0)THEN
756 : NOMID=MODEPL
757 : if(lsupdp)SEGSUP NOMID
758 : ENDIF
759 : *
760 : IF(MOSTRS.NE.0)THEN
761 : NOMID=MOSTRS
762 : if(lsupno)SEGSUP NOMID
763 : ENDIF
764 : *
765 : SEGDES MELEME
766 : SEGDES IMODEL
767 : *
768 : SEGDES MMODEL
769 : SEGSUP,MCHELM
770 : *
770 : CALL DTCHAM(IPCHE3)
771 : SEGDES MINTE
772 : * write(6,*) 'FIN piocap.eso si erreur'
773 : IRET = 0
774 : RETURN
775 : END
776 :
777 :
778 :
779 :
780 :
© Cast3M 2003 - All rights reserved.
Disclaimer