1 : C BSIGMP SOURCE AM 13/12/16 21:15:17 7825
2 : SUBROUTINE BSIGMP(IPMOD0,IPCHE1,IPCHE2,IPCHE3,
3 : 1 IMAT,ICONV,IPCHE4,IRET)
4 : C_______________________________________________________________________
5 : C
6 : C Entr{es:
7 : C ________
8 : C
9 : C IPMOD0 Pointeur sur un MMODEL
10 : C IPCHE1 Pointeur sur un MCHAML de contraintes
11 : C IPCHE2 Pointeur sur un MCHAML de caract{ristiques (FACULTATIF)
12 : C IPCHE3 POINTEUR SUR UN MCHAML DE HOOKE (FACULTATIF)
13 : C IMAT Flag de HOOKE (2 si oui, 1 sinon)
14 : C ICONV 0
15 : C
16 : C SORTIES:
17 : C ________
18 : C
19 : C IPCHE4 Pointeur sur un CHPOINT de forces aux noeuds
20 : C IRET = 1 OU 0 suivant succes ou pas (Message d'erreur
21 : C imprime dans ce cas)
22 : C
23 : C Passage aux nouveaux CHAMELEMs par I.Monnier le 13.06.90
24 : C
25 : C_______________________________________________________________________
26 : C
27 : IMPLICIT INTEGER(I-N)
28 : IMPLICIT REAL*8(A-H,O-Z)
29 : *
30 : -INC CCOPTIO
31 : -INC CCHAMP
32 : -INC SMCHAML
33 : -INC SMCHPOI
34 : -INC SMELEME
35 : -INC SMCOORD
36 : -INC SMMODEL
37 : -INC SMINTE
38 : -INC SMLENTI
39 : C
40 : SEGMENT INFO
41 : INTEGER INFELL(JG)
42 : ENDSEGMENT
43 : *
44 : SEGMENT NOTYPE
45 : CHARACTER*16 TYPE(NBTYPE)
46 : ENDSEGMENT
47 : *
48 : SEGMENT MPTVAL
49 : INTEGER IPOS(NS) ,NSOF(NS)
50 : INTEGER IVAL(NCOSOU)
51 : CHARACTER*16 TYVAL(NCOSOU)
52 : ENDSEGMENT
53 : *
54 : SEGMENT LIMODE(0)
55 : *
56 : PARAMETER ( NINF=3 )
57 : INTEGER INFOS(NINF)
58 : CHARACTER*8 CMATE
59 : CHARACTER*(NCONCH) CONM
60 : CHARACTER*4 MDDLG(3)
61 : LOGICAL BDPGE,ldpge,lsupfo,lsupco,lsupma,dcmate
62 : *
63 : * CREATION D UNE VARIABLE UTILISEE LORS DE LA DESTRUCTION D UN
64 : * CHAMP POINT
65 : *
66 : CHARACTER*4 LAGEOM
67 : DATA LAGEOM / 'GEOM' /
68 :
69 : ICHPAN=0
70 : isup1=0
71 : isup2=0
72 : isup3=0
73 : IRET = 0
74 : llent2 = 0
75 : klent2 = 0
76 : *
77 : * Verification du lieu support du MCHAML de contraintes
78 : *
79 : * teste le contenu du mchelm de contraintes
80 : mchelm = ipche1
81 : segact mchelm
82 : * deroule le modele
83 : MMODEL=IPMOD0
84 : SEGACT MMODEL
85 : NSOUS=KMODEL(/1)
86 : * en cas de modele melange derouler : creer un nouveau mmode
87 : segini limode
88 : do 1160 im = 1,NSOUS
89 : imodel = kmodel(im)
90 : segact imodel
91 : if (formod(1).eq.'LIAISON') goto 1160
92 : do icz = 1 ,imache(/1)
93 : if (conche(icz).eq.conmod) then
94 : limode(**) = imodel
95 : goto 1160
96 : endif
97 : enddo
98 : if (formod(1).eq.'MELANGE') then
99 : if (ivamod(/1).ge.1) then
100 : do 1170 ivm1 = 1,ivamod(/1)
101 : if (tymode(ivm1).eq.'IMODEL') then
102 : imode1 = ivamod(ivm1)
103 : segact imode1
104 : do icz = 1 ,imache(/1)
105 : if (conche(icz).eq.imode1.conmod) then
106 : limode(**) = imode1
107 : goto 1170
108 : endif
109 : enddo
110 : interr(1) = imode1
111 : interr(2) = imamod
111 : call erreur(973)
112 : RETURN
113 : endif
114 : 1170 continue
115 : endif
116 : else
117 : interr(1) = imodel
118 : interr(2) = imamod
118 : call erreur(973)
119 : RETURN
120 : endif
121 : 1160 continue
122 : segdes mmodel
123 : * test non redondance
124 : N1 = 1
125 : if (limode(/1).gt.1) then
126 : do 1161 it1 = limode(/1),2,-1
127 : imode1 = limode(it1)
128 : segact imode1
129 : do it2 = (it1 - 1) ,1,-1
130 : imode2 = limode(it2)
131 : segact imode2
132 : if (imode1.imamod.eq.imode2.imamod.and.
133 : & imode1.conmod.eq.imode2.conmod) then
134 : limode(it1) = 0
135 : goto 1161
136 : endif
137 : enddo
138 : N1 = N1 + 1
139 : 1161 continue
140 : endif
141 :
142 : is1 = 0
143 : if (limode(/1).gt.0) then
144 : segini,mmodel
145 : do is = 1,limode(/1)
146 : if (limode(is).gt.0) then
147 : * teste
148 : is1 = is1 + 1
149 : kmodel(is1) = limode(is)
150 : endif
151 : enddo
152 : else
153 : endif
154 : segsup,limode
155 :
156 : IPMODL = MMODEL
157 : NSOUS=KMODEL(/1)
158 : * redu
158 : call ecrobj('MCHAML ',ipche1)
158 : call ecrobj('MMODEL ',ipmodl)
158 : call redu
158 : call lirobj('MCHAML ',ipche10,1,irt)
159 : if (ierr.ne.0) return
159 : CALL QUESUP(IPMODL,IPCHE10,3,0,ISUP1,IRET1C)
160 : IF (ISUP1.GT.1) RETURN
161 : ipche1 = ipche10
162 : mchel2 = ipche1
163 : segact mchel2
164 : *
165 : * Verification du lieu support du MCHAML de caracteristiques
166 : *
167 : IF (IPCHE2.NE.0) THEN
168 : * reduction
168 : call ecrobj('MCHAML ',ipche2)
168 : call ecrobj('MMODEL ',ipmod0)
168 : call redu
168 : call lirobj('MCHAML ',ipche20,1,irt)
169 : if (ierr.ne.0) return
169 : CALL QUESUP(IPMOD0,IPCHE20,3,1,ISUP2,IRET2C)
170 : IF (ISUP2.GT.1) RETURN
171 : ENDIF
172 : *
173 : * Verification du lieu support du MCHAML de Hooke
174 : *
175 : IF (IPCHE3.NE.0) THEN
175 : CALL QUESUP (IPMODL,IPCHE3,3,1,ISUP3,IRET3C)
176 : IF (ISUP3.NE.0) RETURN
177 : ENDIF
178 : C_______________________________________________________________________
179 : C
180 : C ACTIVATION DU MODELE
181 : C_______________________________________________________________________
182 : C
183 : MMODEL=IPMODL
184 : SEGACT MMODEL
185 : NSOUS=KMODEL(/1)
186 : C On active tous les sous-modeles
187 : KNB22=0
188 : DO I=1,NSOUS
189 : IMODEL=KMODEL(I)
190 : SEGACT IMODEL
191 : IF (FORMOD(1).EQ.'LIAISON' .OR. NEFMOD.EQ.22) KNB22=KNB22+1
192 : END DO
193 : C
194 : C ACTIVATION DES CONTRAINTES
195 : C
196 : MCHEL1=IPCHE1
197 : SEGACT MCHEL1
198 : C
199 : C INITIALISATION DU MCHELM DE FORCES
200 : C
201 : N1=NSOUS-KNB22
202 : L1=6
203 : N3=5
204 : SEGINI MCHELM
205 : IPCHE5=MCHELM
206 : IFOCHE=IFOUR
207 : TITCHE='FORCES'
208 : C
209 : C Cas des modes de calcul GENERALISES (2D et 1D) pour la mecanique :
210 : K_DPGE=0
211 : IF (IFOUR.EQ.-3) THEN
212 : BDPGE=.TRUE.
213 : NFORDG=3
214 : MDDLG(1)='FZ '
215 : MDDLG(2)='MY '
216 : MDDLG(3)='MX '
217 : ELSE IF (IFOUR.EQ.11) THEN
218 : BDPGE=.TRUE.
219 : NFORDG=2
220 : MDDLG(1)='FZ '
221 : MDDLG(2)='FY '
222 : ELSE IF (IFOUR.EQ.9.OR.IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
223 : BDPGE=.TRUE.
224 : NFORDG=1
225 : MDDLG(1)='FZ '
226 : ELSE IF (IFOUR.EQ.7.OR.IFOUR.EQ.8) THEN
227 : BDPGE=.TRUE.
228 : NFORDG=1
229 : MDDLG(1)='FY '
230 : ELSE
231 : BDPGE=.FALSE.
232 : NFORDG=0
233 : ENDIF
234 : C
235 : C_______________________________________________________________________
236 : C
237 : C BOUCLE SUR LES SOUS ZONES
238 : C_______________________________________________________________________
239 : C
240 : ISOUS=0
241 : DO 200 KISOUS=1,NSOUS
242 : *
243 : * INITIALISATION
244 : *
245 : IVAMAT=0
246 : IVACAR=0
247 : IVASTR=0
248 : IVAFOR=0
249 : MOMATR=0
250 : MOCARA=0
251 : MOSTRS=0
252 : MOFORC=0
253 : lsupfo=.false.
254 : lsupco=.false.
255 : lsupma=.true.
256 : dcmate = .false.
257 : IPMINT=0
258 : C
259 : C TRAITEMENT DU MODELE
260 : C
261 : IMODEL=KMODEL(KISOUS)
262 : C* SEGACT IMODEL
263 : if (formod(1).eq.'LIAISON' .or. nefmod.eq.22) go to 200
264 : *
265 : ISOUS=ISOUS+1
266 : IIPDPG=IPDPGE
267 : MELE=NEFMOD
268 : IPMAIL=IMAMOD
269 : CONM =CONMOD
270 :
271 : c write(6,*) '---------------------------------------------------'
272 : c write(6,*) 'bsigmp: sous modele',ISOUS,'/',NSOUS
273 : c write(6,*) ' ',KISOUS,IMODEL,MELE
274 : C
275 : C COQUE INTEGREE OU PAS ?
276 : C
277 : IF(INFMOD(/1).NE.0)THEN
278 : NPINT=INFMOD(1)
279 : ELSE
280 : NPINT=0
281 : ENDIF
282 : C
283 : C NATURE DU MATERIAU
284 : C
285 : * NFOR=FORMOD(/2)
286 : * NMAT=MATMOD(/2)
286 : * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
287 : CMATE = CMATEE
288 : MATE = IMATEE
289 : INAT = INATUU
290 : do im = 1,matmod(/2)
291 : if (matmod(im).eq.'IMPEDANCE') dcmate =.true.
292 : enddo
293 : * IF (CMATE.EQ.' ')THEN
293 : * CALL ERREUR(251)
294 : * GOTO 9992
295 : * ENDIF
296 : C____________________________________________________________________
297 : C
298 : C ACTIVATION DU MELEME
299 : C
300 : MELEME=IPMAIL
301 : SEGACT MELEME
302 : NBNN=NUM(/1)
303 : NBELEM=NUM(/2)
304 : C
305 : C RECOPIE DU MCHELM
306 : C
307 : IMACHE(ISOUS)=IPMAIL
308 : C
309 : C CREATION DU TABLEAU INFOS
310 : C
310 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
311 : IF (IRTD.EQ.0) GOTO 9991
312 : C_______________________________________________________________________
313 : C
314 : C INFORMATIONS SUR L'{L{MENT FINI
315 : C_______________________________________________________________________
316 : C
317 : if(infmod(/1).lt.5) then
317 : CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
318 : IF (IERR.NE.0) GOTO 9991
319 : INFO=IPINF
320 : NBPGAU= INFELL(4)
321 : NBG = INFELL(6)
322 : MINTE = INFELL(11)
323 : MINTE1= INFELL(12)
324 : LHOOK = INFELL(10)
325 : MFR = INFELL(13)
326 : NSTRS = INFELL(16)
327 : LW = INFELL(7)
328 : NDDL = INFELL(15)
329 : LRE = INFELL(9)
330 : IPORE = INFELL(8)
331 : SEGSUP INFO
332 : else
333 : NBPGAU= INFELE(4)
334 : NBG = INFELE(6)
335 : MINTE = infmod(5)
336 : MINTE1= INFmod(8)
337 : LHOOK = INFELE(10)
338 : MFR = INFELE(13)
339 : NSTRS = INFELE(16)
340 : LW = INFELE(7)
341 : NDDL = INFELE(15)
342 : LRE = INFELE(9)
343 : IPORE = INFELE(8)
344 : endif
345 : *
346 : IPMINT= MINTE
347 : IPMIN1= MINTE1
348 : NHRM = NIFOUR
349 : IPPORE=0
350 : IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE=NBNN
351 : ldpge = BDPGE
352 : IF (MFR.EQ.35 .OR. MFR.EQ.71 .OR. MFR.EQ.73) ldpge = .FALSE.
353 : C
354 : LHOO2 = LHOOK*LHOOK
355 : if(mele.ne.260) then
356 : SEGACT MINTE
357 : NBNO=SHPTOT(/2)
358 : endif
359 : C
360 : INFCHE(ISOUS,1)=0
361 : INFCHE(ISOUS,2)=0
362 : INFCHE(ISOUS,3)=NIFOUR
363 : INFCHE(ISOUS,4)=0
364 : INFCHE(ISOUS,5)=0
365 : C__________________________________
366 : C
367 : C NOMS DE COMPOSANTES NECESSAIRES ( CONTRAINTES )
368 : C_______________________________________________________________________
369 : C
370 : if(lnomid(4).ne.0) then
371 : mostrs=lnomid(4)
372 : nomid=mostrs
373 : segact nomid
374 : nstr=lesobl(/2)
375 : nfac=lesfac(/2)
376 : else
377 : lsupco=.true.
377 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
378 : nomid=mostrs
379 : segact nomid
380 : endif
381 : C
382 : if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
383 : * recherche composante FMOD
384 : if (llent2.eq.0) then
385 : jg = NSOUS
386 : jgl2 = jg
387 : segini mlent2
388 : llent2 = mlent2
389 : endif
390 : do im2 = 1, mchel2.imache(/1)
391 : if (mchel2.imache(im2).eq.imamod.and.
392 : &mchel2.conche(im2).eq.conmod) then
393 : mcham2 = mchel2.ichaml(im2)
394 : segact mcham2
395 : do in2 = 1,mcham2.nomche(/2)
396 : if (mcham2.nomche(in2)(1:4).eq.'FMOD') then
397 : melva2 = mcham2.ielval(in2)
398 : segact melva2
399 : if (klent2 + melva2.ielche(/2).gt.jgl2) then
400 : jgl2 = jgl2 + melva2.ielche(/2)
401 : jg = jgl2
402 : segadj mlent2
403 : endif
404 : do iel2 = 1,melva2.ielche(/2)
405 : klent2 = klent2 + 1
406 : mlent2.lect(klent2) = melva2.ielche(1,iel2)
407 : enddo
408 : segdes mcham2
409 : segdes melva2
410 : goto 11
411 : endif
412 : enddo
413 : segdes mcham2
414 : endif
415 : enddo
416 : 11 continue
417 : *JK truande le test komcha
418 : IF(NSTRS.LT.1) THEN
419 : segdes nomid
419 : CALL ERREUR(922)
420 : GO TO 9990
421 : ENDIF
422 : mostrs0 = mostrs
423 : if (ifomod.eq.6) then
424 : nbrobl = 1
425 : nbrfac = 1
426 : segini nomid
427 : lesobl(1) = 'EFFX'
428 : lesfac(1) = 'IFFX'
429 : else
430 : nbrobl = 1
431 : nbrfac = 0
432 : segini nomid
433 : lesobl(1) = 'EFFX'
434 : endif
435 : mostrs = nomid
436 : else
437 : IF(NSTR+NFAC.NE.NSTRS) THEN
438 : segdes nomid
438 : CALL ERREUR(922)
439 : GO TO 9990
440 : ENDIF
441 : endif
442 : C
443 : C VERIFICATION DE LEUR PRESENCE
444 : C
445 : NBTYPE=1
446 : SEGINI NOTYPE
447 : TYPE(1)='REAL*8'
448 : MOTYPE=NOTYPE
448 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
449 : SEGSUP NOTYPE
450 : segdes nomid
451 : IF (IERR.NE.0) GOTO 9991
452 : C
453 : if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
454 : mptval = ivastr
455 : segact mptval*mod
456 : ns = ipos(/1)
457 : ncosou = 0
458 : jg = ival(/1)
459 : segini mlenti
460 : do ico = 1,ival(/1)
461 : if (ival(ico).gt.0) then
462 : ncosou = ncosou + 1
463 : lect(ncosou) = ival(ico)
464 : endif
465 : enddo
466 : segadj mptval
467 : do ico = 1,ncosou
468 : ival(ico) = lect(ico)
469 : enddo
470 : segsup mlenti
471 : segsup nomid
472 : mostrs = mostrs0
473 : endif
474 :
475 :
476 : IF (ISUP1.EQ.1) THEN
477 : ifai=1
478 : if( mele.eq.260.and.iret1c.eq.5) ifai=0
478 : IF (ifai.eq.1) CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE)
479 : ENDIF
480 : C_______________________________________________________________________
481 : C
482 : C NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
483 : C_______________________________________________________________________
484 : C
485 : if(lnomid(2).ne.0) then
486 : MOFORC = lnomid(2)
487 : NOMID=MOFORC
488 : segact nomid
489 : nforc=lesobl(/2)
490 : NFACF=LESFAC(/2)
491 : else
492 : lsupfo=.true.
492 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFACF)
493 : NOMID=MOFORC
494 : SEGACT NOMID
495 : endif
496 : C
497 : C CREATION DU MCHAML
498 : C
499 : C CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX
500 : C
501 : NFOREF=NFORC
502 : IF (ldpge) NFOREF=NFOREF-NFORDG
503 : c N2=NFOREF
504 : c bp: les composantes facultatives peuvent elles aussi exister !
505 : * on ajustera apres bsigmx la taille reellement utilisée par la force
506 : N2=NFOREF+NFACF
507 : if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
508 : * write(6,*) 'bs',n2,ncosou,nforef,nfacf
509 : if (ncosou.lt.n2) then
510 : *jk : rustique
511 : nfacf = 0
512 : n2 = ncosou
513 : nforef = ncosou
514 : endif
515 : endif
516 : C
517 : SEGINI MCHAML
518 : ICHAML(ISOUS)=MCHAML
519 : C
520 : c DO 110 ICOMP=1,N2
521 : DO 110 ICOMP=1,NFOREF
522 : NOMCHE(ICOMP)=LESOBL(ICOMP)
523 : TYPCHE(ICOMP)='REAL*8'
524 : 110 CONTINUE
525 : if(NFACF .ne. 0) then
526 : IFAC = 0
527 : DO 111 ICOMP=(NFOREF+1),N2
528 : IFAC = IFAC + 1
529 : NOMCHE(ICOMP)=LESFAC(IFAC)
530 : TYPCHE(ICOMP)='REAL*8'
531 : 111 CONTINUE
532 : endif
533 : SEGDES NOMID
534 : C
535 : C TAILLES DE MELVAL
536 : C
537 : N1EL=NBELEM
538 : N1PTEL=NBNN
539 : NBPTEL=NBPGAU
540 : NEL =N1EL
541 : C
542 : C CREATION DU MELVAL DE FORCES
543 : C
544 : NS=1
545 : * NCOSOU=NFOREF
546 : NCOSOU=NFOREF+NFACF
547 : SEGINI MPTVAL
548 : IVAFOR=MPTVAL
549 : DO 100 ICOMP=1,NCOSOU
550 : N2PTEL=0
551 : N2EL=0
552 : SEGINI MELVAL
553 : IELVAL(ICOMP)=MELVAL
554 : IVAL(ICOMP)=MELVAL
555 : 100 CONTINUE
556 : C____________________________________________________________________
557 : C
558 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
559 : C____________________________________________________________________
560 : NBROBL=0
561 : NBRFAC=0
562 : NOMID=0
563 : IVECT=0
564 : *
565 : * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
566 : *
567 : IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR.
568 : + (MELE.GE.79.AND.MELE.LE.83)).AND.
569 : + IFOUR.EQ.-2)THEN
570 : *
571 : NBROBL=0
572 : NBRFAC=1
573 : SEGINI NOMID
574 : LESFAC(1)='DIM3'
575 : *
576 : NBTYPE=1
577 : SEGINI NOTYPE
578 : TYPE(1)='REAL*8'
579 : *
580 : * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
581 : *
582 : ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
583 : NBROBL=1
584 : IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
585 : NBRFAC=2
586 : ELSE
587 : NBRFAC=1
588 : ENDIF
589 : SEGINI NOMID
590 : LESOBL(1)='EPAI'
591 : LESFAC(1)='EXCE'
592 : IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3'
593 : *
594 : NBTYPE=1
595 : SEGINI NOTYPE
596 : TYPE(1)='REAL*8'
597 : *
598 : * SECTION POUR LES BARRES
599 : *
600 : ELSE IF (MFR.EQ.27) THEN
601 : IF(.NOT.dcmate) THEN
602 : NBROBL=1
603 : SEGINI NOMID
604 : LESOBL(1)='SECT'
605 : *
606 : NBTYPE=1
607 : SEGINI NOTYPE
608 : TYPE(1)='REAL*8'
609 : ENDIF
610 : *
611 : * section, excentrements et orientation pour les barres excentrees
612 : *
613 : ELSE IF (MFR.EQ.49) THEN
614 : NBROBL=6
615 : SEGINI NOMID
616 : LESOBL(1)='SECT'
617 : LESOBL(2)='EXCZ'
618 : LESOBL(3)='EXCY'
619 : LESOBL(4)='VX '
620 : LESOBL(5)='VY '
621 : LESOBL(6)='VZ '
622 : *
623 : NBTYPE=1
624 : SEGINI NOTYPE
625 : TYPE(1)='REAL*8'
626 : *
627 : * raideurs locales et orientation pour l'element LIA2
628 : * de liaison a 2 noeuds
629 : *
630 : ELSE IF (MFR.EQ.51) THEN
631 : NBROBL=9
632 : SEGINI NOMID
633 : LESOBL(1)='RLUX'
634 : LESOBL(2)='RLUY'
635 : LESOBL(3)='RLUZ'
636 : LESOBL(4)='RLRX'
637 : LESOBL(5)='RLRY'
638 : LESOBL(6)='RLRZ'
639 : LESOBL(7)='VX '
640 : LESOBL(8)='VY '
641 : LESOBL(9)='VZ '
642 : *
643 : NBTYPE=1
644 : SEGINI NOTYPE
645 : TYPE(1)='REAL*8'
646 : *
647 : * CARACTERISTIQUES POUR LES POUTRES
648 : *
649 : ELSE IF (MFR.EQ.7 ) THEN
650 : if (dcmate) then
651 : NBROBL=0
652 : NBRFAC=4
653 : SEGINI NOMID
654 : MOCARA=NOMID
655 : LESFAC(1)='TORS'
656 : LESFAC(2)='INRY'
657 : LESFAC(3)='INRZ'
658 : LESFAC(4)='VECT'
659 : IVECT=1
660 : *
661 : NBTYPE=4
662 : SEGINI NOTYPE
663 : MOTYPE=NOTYPE
664 : TYPE(1)='REAL*8'
665 : TYPE(2)='REAL*8'
666 : TYPE(3)='REAL*8'
667 : TYPE(4)='POINTEURPOINT '
668 : else
669 : IF (CMATE.EQ.'SECTION') THEN
670 : NBROBL=0
671 : NBRFAC=1
672 : SEGINI NOMID
673 : LESFAC='VECT'
674 : IVECT=1
675 : *
676 : NBTYPE=1
677 : SEGINI NOTYPE
678 : TYPE(1)='POINTEURPOINT '
679 : *
680 : ELSEIF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
681 : NBROBL=2
682 : NBRFAC=1
683 : SEGINI NOMID
684 : LESOBL(1)='SECT'
685 : LESOBL(2)='INRZ'
686 : LESFAC(1)='SECY'
687 : *
688 : NBTYPE=1
689 : SEGINI NOTYPE
690 : TYPE(1)='REAL*8'
691 : *
692 : ELSE
693 : NBROBL=4
694 : NBRFAC=3
695 : SEGINI NOMID
696 : LESOBL(1)='TORS'
697 : LESOBL(2)='INRY'
698 : LESOBL(3)='INRZ'
699 : LESOBL(4)='SECT'
700 : LESFAC(1)='SECY'
701 : LESFAC(2)='SECZ'
702 : LESFAC(3)='VECT'
703 : IVECT=1
704 : *
705 : NBTYPE=7
706 : SEGINI NOTYPE
707 : TYPE(1)='REAL*8'
708 : TYPE(2)='REAL*8'
709 : TYPE(3)='REAL*8'
710 : TYPE(4)='REAL*8'
711 : TYPE(5)='REAL*8'
712 : TYPE(6)='REAL*8'
713 : TYPE(7)='POINTEURPOINT '
714 : ENDIF
715 : endif
716 : *
717 : * CARACTERISTIQUES POUR LES TUYAUX
718 : *
719 : ELSE IF (MFR.EQ.13) THEN
720 : NBROBL=2
721 : NBRFAC=3
722 : SEGINI NOMID
723 : LESOBL(1)='EPAI'
724 : LESOBL(2)='RAYO'
725 : LESFAC(1)='RACO'
726 : LESFAC(2)='CISA'
727 : LESFAC(3)='VECT'
728 : IVECT=1
729 : *
730 : NBTYPE=5
731 : SEGINI NOTYPE
732 : TYPE(1)='REAL*8'
733 : TYPE(2)='REAL*8'
734 : TYPE(3)='REAL*8'
735 : TYPE(4)='REAL*8'
736 : TYPE(5)='POINTEURPOINT '
737 : *
738 : * CARACTERISTIQUES POUR LES LINESPRING
739 : *
740 : ELSE IF (MFR.EQ.15) THEN
741 : NBROBL=5
742 : SEGINI NOMID
743 : LESOBL(1)='EPAI'
744 : LESOBL(2)='FISS'
745 : LESOBL(3)='VX '
746 : LESOBL(4)='VY '
747 : LESOBL(5)='VZ '
748 : *
749 : NBTYPE=1
750 : SEGINI NOTYPE
751 : TYPE(1)='REAL*8'
752 : *
753 : * CARACTERISTIQUES POUR LES TUYAUX FISSURES
754 : *
755 : ELSE IF (MFR.EQ.17) THEN
756 : NBROBL=9
757 : SEGINI NOMID
758 : LESOBL(1)='RAYO'
759 : LESOBL(2)='EPAI'
760 : LESOBL(3)='VX '
761 : LESOBL(4)='VY '
762 : LESOBL(5)='VZ '
763 : LESOBL(6)='VXF '
764 : LESOBL(7)='VYF '
765 : LESOBL(8)='VZF '
766 : LESOBL(9)='ANGL'
767 : *
768 : NBTYPE=1
769 : SEGINI NOTYPE
770 : TYPE(1)='REAL*8'
771 : *
772 : * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
773 : *
774 : ELSE IF (MFR.EQ.37) THEN
775 : IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
776 : NBROBL=4
777 : SEGINI NOMID
778 : LESOBL(1)='SCEL'
779 : LESOBL(2)='SFLU'
780 : LESOBL(3)='EPS '
781 : LESOBL(4)='XINE'
782 : ELSE
783 : NBROBL=3
784 : SEGINI NOMID
785 : LESOBL(1)='SCEL'
786 : LESOBL(2)='SFLU'
787 : LESOBL(3)='EPS '
788 : ENDIF
789 : *
790 : NBTYPE=1
791 : SEGINI NOTYPE
792 : TYPE(1)='REAL*8'
793 : *
794 : C CARACTERISTIQUE POUR LES JOINTS GENE
795 : C
796 : ELSE IF (MFR.EQ.55) THEN
797 : NBROBL=0
798 : NBRFAC=1
799 : SEGINI NOMID
800 : LESFAC(1)='EPAI'
801 : C
802 : NBTYPE=1
803 : SEGINI NOTYPE
804 : TYPE(1)='REAL*8'
805 : ENDIF
806 :
807 : MOCARA=NOMID
808 : * rendement kich 09/01 /// à remettre en cause avec phases (kich 04/09)
809 : if (MOCARA.EQ.0) then
810 : nbtype = 0
811 : segini notype
812 : nbrobl = 0
813 : nbrfac = 0
814 : segini nomid
815 : mocara = nomid
816 : endif
817 : motype = notype
818 :
819 : ifac = nbrfac
820 : NCAR1=NBROBL + NBRFAC + 1
821 : NBRFAC= nbrfac + 10
822 : segadj nomid
823 : lesfac(ifac + 1) = 'REND'
824 : lesfac(ifac + 2) = 'W1X '
825 : lesfac(ifac + 3) = 'W1Y '
826 : lesfac(ifac + 4) = 'W1Z '
827 : lesfac(ifac + 5) = 'W2X '
828 : lesfac(ifac + 6) = 'W2Y '
829 : lesfac(ifac + 7) = 'W2Z '
830 : lesfac(ifac + 8) = 'REN1'
831 : lesfac(ifac + 9) = 'REN2'
832 : lesfac(ifac + 10) = 'REN3'
833 : nbtype = nbtype + 1
834 : segadj notype
835 : type(nbtype) = 'REAL*8'
836 : *
837 : NCARA=NBROBL
838 : NCARF=NBRFAC
839 : NCARR=NCARA+NCARF
840 : *
841 : C* IF (MOCARA.NE.0) THEN
842 : IF (IPCHE2.NE.0) THEN
843 : *
843 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
844 : $ IVACAR)
845 : SEGSUP NOTYPE
846 : IF (IERR.NE.0) GOTO 9990
847 : IF (ISUP2.EQ.1.and.mele.ne.260) THEN
847 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
848 : IF (IERR.NE.0)THEN
849 : ISUP2=0
850 : GOTO 9990
851 : ENDIF
852 : ENDIF
853 : ELSE IF (NCARA.GT.0) THEN
854 : SEGSUP NOTYPE
855 : MOTERR(1:8)='CARACTER'
856 : MOTERR(9:12)=NOMTP(MELE)
857 : MOTERR(13:20)='BSIGMA'
857 : CALL ERREUR(145)
858 : GOTO 9990
859 : ENDIF
860 : C* ENDIF
861 : *
862 : * utiliser la densite pour ponderer par la prop de phase
863 : IF (IPCHE2.NE.0.AND.CONMOD(17:24).ne.' ') THEN
864 : * rechercher le melval
865 : iptm = 0
866 : MCHEL6 = IPCHE2
867 : segact MCHEL6
868 : do ima = 1,mchel6.imache(/1)
869 : if (mchel6.imache(ima).eq.imamod) then
870 : mcham6 = mchel6.ichaml(ima)
871 : segact mcham6
872 : do ic = 1,mcham6.nomche(/2)
873 : if (mcham6.nomche(ic)(1:4).eq.conmod(17:20)) then
874 : iptm = mcham6.ielval (ic)
875 : segdes mcham6
876 : segdes mchel6
877 : goto 20
878 : endif
879 : enddo
880 : segdes mcham6
881 : endif
882 : enddo
883 : segdes mchel6
884 : * avertissement
885 : 20 if (iptm.eq.0)
886 : & write(6,*) ' proportion phase non trouvee ',conmod(17:24)
887 : * ponderation
888 : if (iptm.gt.0) then
889 : if(ivacar.ne.0) then
890 : mptval = ivacar
891 : segact mptval*mod
892 : if (ival(ncar1).gt.0) then
893 : melva1 = ival(ncar1)
894 : melva2 = iptm
895 : segact melva1,melva2
896 : n1ptel = max(melva1.velche(/1),melva2.velche(/1))
897 : n1el = max(melva1.velche(/2),melva2.velche(/2))
898 : n2ptel = melva1.ielche(/1)
899 : n2el = melva1.ielche(/2)
900 : segini melval
901 : do jptel = 1,n1ptel
902 : do jel = 1,n1el
903 : i1 = min(jptel,melva1.velche(/1))
904 : j1 = min(jel,melva1.velche(/2))
905 : i2 = min(jptel,melva2.velche(/1))
906 : j2 = min(jel,melva2.velche(/2))
907 : velche(jptel,jel) = melva1.velche(i1,j1)*melva2.velche(i2,j2)
908 : enddo
909 : enddo
910 : ival(ncar1) = melval
911 : segdes melva1,melva2
912 : else if (ival(ncar1+7).gt.0.or.ival(ncar1+8).gt.0.or.
913 : & ival(ncar1+9).gt.0) then
914 : else
915 : ival(ncar1) = iptm
916 : tyval(ncar1) = 'REAL*8'
917 : melval = iptm
918 : segact melval
919 : endif
920 : endif
921 : endif
922 : ENDIF
923 :
924 : C____________________________________________________________________
925 : C
926 : * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL *
927 : * UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST
928 : C____________________________________________________________________
929 : *
930 : NBGMAT = 0
931 : NELMAT = 0
932 : NMATR = 0
933 : NMATF = 0
934 : NMATT = 0
935 : IF(MELE.EQ.93.or.mele.eq.260)THEN
936 : IF (IMAT.EQ.2) THEN
937 : NBRFAC=0
938 : IF(CMATE.NE.'ISOTROPE')THEN
939 : NBROBL=3
940 : SEGINI NOMID
941 : LESOBL(1)='MAHO'
942 : LESOBL(2)='V1X '
943 : LESOBL(3)='V1Y '
944 : NBTYPE=3
945 : SEGINI NOTYPE
946 : TYPE(1)='POINTEURLISTREEL'
947 : TYPE(2)='REAL*8'
948 : TYPE(3)='REAL*8'
949 : ELSE
950 : NBROBL=1
951 : SEGINI NOMID
952 : LESOBL(1)='MAHO'
953 : NBTYPE=1
954 : SEGINI NOTYPE
955 : TYPE(1)='POINTEURLISTREEL'
956 : ENDIF
957 : MOMATR=NOMID
958 : MOTYPE=NOTYPE
958 : CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
959 : SEGSUP NOTYPE
960 : IF (IERR.NE.0) GOTO 9990
961 : MPTVAL=IVAMAT
962 : MELVAL=IVAL(1)
963 : NBGMAT=IELCHE(/1)
964 : NELMAT=IELCHE(/2)
965 : NMATR=NBROBL
966 : NMATF=NBRFAC
967 : NMATT=NMATR+NMATF
968 : ELSE
969 : C____________________________________________________________________
970 : *
971 : * SINON TRAITEMENT DES CHAMPS DE MATERIAU
972 : C____________________________________________________________________
973 : *
974 : NBROBL=0
975 : NBRFAC=0
976 : IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
977 : NBROBL=2
978 : SEGINI NOMID
979 : MOMATR=NOMID
980 : LESOBL(1)='YOUN'
981 : LESOBL(2)='NU '
982 : ELSEIF(FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ORTHOTRO')THEN
983 : IF(INAT.EQ.67) THEN
984 : NBROBL=6
985 : SEGINI NOMID
986 : MOMATR=NOMID
987 : LESOBL(1)='YG1 '
988 : LESOBL(2)='YG2 '
989 : LESOBL(3)='NU12'
990 : LESOBL(4)='G12 '
991 : LESOBL(5)='V1X '
992 : LESOBL(6)='V1Y '
993 : ELSE
994 : if(lnomid(6).ne.0) then
995 : nomid=lnomid(6)
996 : segact nomid
997 : momatr=nomid
998 : nbrobl=lesobl(/2)
999 : nbrfac=lesfac(/2)
1000 : lsupma=.false.
1001 : else
1001 : CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
1002 : endif
1003 : ENDIF
1004 : ENDIF
1005 : NMATR=NBROBL
1006 : NMATF=NBRFAC
1007 : NMATT=NMATR+NMATF
1008 : *
1009 : IF (MOMATR.NE.0) THEN
1010 : NBTYPE=1
1011 : SEGINI NOTYPE
1012 : TYPE(1)='REAL*8'
1013 : MOTYPE=NOTYPE
1013 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
1014 : SEGSUP NOTYPE
1015 : IF (IERR.NE.0) GOTO 9990
1016 : *
1017 : IF (ISUP2.EQ.1.and.mele.ne.260) THEN
1017 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE)
1018 : IF (IERR.NE.0)THEN
1019 : ISUP2=0
1020 : GOTO 9990
1021 : ENDIF
1022 : ENDIF
1023 : *
1024 : MPTVAL=IVAMAT
1025 : NBGMAT = 0
1026 : NELMAT = 0
1027 : DO 1108 IM=1,NMATT
1028 : IF(IVAL(IM).NE.0)THEN
1029 : MELVAL=IVAL(IM)
1030 : NBGMAT=MAX(NBGMAT,VELCHE(/1))
1031 : NELMAT=MAX(NELMAT,VELCHE(/2))
1032 : ENDIF
1033 : 1108 CONTINUE
1034 : ENDIF
1035 : ENDIF
1036 : ENDIF
1037 : C
1038 : C================================================
1039 : C
1040 : C CAS D'UN JOINT UNIDIMENSIONNEL JOI1
1041 : C Chargement des vecteurs stitués dans les caractéristiques matériau
1042 : C
1043 : C================================================
1044 : IF(MFR.EQ.75) THEN
1045 : IF(IFOUR.EQ.2) THEN
1046 : NBROBL=6
1047 : NBRFAC=0
1048 : SEGINI NOMID
1049 : MOMATR=NOMID
1050 : LESOBL(1)='V1X'
1051 : LESOBL(2)='V1Y'
1052 : LESOBL(3)='V1Z'
1053 : LESOBL(4)='V2X'
1054 : LESOBL(5)='V2Y'
1055 : LESOBL(6)='V2Z'
1056 : NMATR=NBROBL
1057 : NMATF=NBRFAC
1058 : ELSE IF(IFOUR.EQ.-2.OR.IFOUR.EQ.-1) THEN
1059 : NBROBL=2
1060 : NBRFAC=0
1061 : SEGINI NOMID
1062 : MOMATR=NOMID
1063 : LESOBL(1)='V1X'
1064 : LESOBL(2)='V1Y'
1065 : NMATR=NBROBL
1066 : NMATF=NBRFAC
1067 : ENDIF
1068 : NBTYPE=1
1069 : SEGINI NOTYPE
1070 : TYPE(1)='REAL*8'
1071 : MOTYPE=NOTYPE
1072 : *
1072 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
1073 : SEGSUP NOTYPE
1074 : IF (IERR.NE.0) GOTO 9990
1075 : *
1076 : NMATT=NMATR+NMATF
1077 : * C
1078 : IF(ISUP1.EQ.1)THEN
1078 : CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE)
1079 : IF(IERR.NE.0)THEN
1080 : ISUP1=0
1081 : GOTO 9990
1082 : ENDIF
1083 : ENDIF
1084 : MPTVAL=IVAMAT
1085 : NBGMAT = 0
1086 : NELMAT = 0
1087 : DO 11265 IM=1,NMATT
1088 : IF(IVAL(IM).NE.0)THEN
1089 : MELVAL=IVAL(IM)
1090 : IF (CMATE.EQ.'SECTION') THEN
1091 : NBGMAT=MAX(NBGMAT,IELCHE(/1))
1092 : NELMAT=MAX(NELMAT,IELCHE(/2))
1093 : ELSE
1094 : NBGMAT=MAX(NBGMAT,VELCHE(/1))
1095 : NELMAT=MAX(NELMAT,VELCHE(/2))
1096 : ENDIF
1097 : ENDIF
1098 : 11265 CONTINUE
1099 : nmattd=nmatt
1100 : ivamtd= ivamat
1101 : segdes nomid
1102 : ENDIF
1103 :
1104 : if (dcmate) goto 29
1105 : C_______________________________________________________________________
1106 : C
1107 : C NUMERO DES ETIQUETTES :
1108 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
1109 : C Les elements sont groupes comme suit :
1110 : C - massif, poreux, joints poreux,incompressibles --> BSIGM1
1111 : C - coq3,dkt,coq4,coq8,coq2,jot3,joi4,joi2,joi3 ----> BSIGM2
1112 : C - poutre,tuyau,linespring,tuyau fissure,barre ----> BSIGM3
1113 : c et poutre Timoschenko
1114 : C_______________________________________________________________________
1115 : C
1116 : IF (MELE.LE.100)
1117 : &GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
1118 : 1 99,99, 4, 4, 4, 4,27,27,29,29,99,99,99,99,99,99,99,99,99,99,
1119 : 2 27,29,29,27,29,29,99,99,27,29,99,99,99,99,99,27,99,99,99,99,
1120 : 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99,99,99,99, 4, 4,
1121 : 4 4, 4, 4,29,27,27,27,27,99,99,99,99,27,99,29,29,99,99,99,99
1122 : 5 ),MELE
1123 : IF (MELE.LE.200)
1124 : &GOTO (99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
1125 : 1 4, 4,29,29,29,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1126 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1127 : 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1128 : 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34
1129 : 5 ),MELE-100
1130 : IF (MELE.LE.300)
1131 : &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1132 : 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1133 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
1134 : 3 34,34,34,34,29,29,29,29),MELE-200
1135 : C
1136 : C CASE OF THE NEW JOINT ELEMENTS (JCT3 AND JCI4)
1137 : C (JGI2 2D GENERALIZED)
1138 : C (JGT3 AND JGI4 GENERALIZED)
1139 : C
1140 : 34 CONTINUE
1141 : IF (MELE.GE.168.AND.MELE.LE.172) GOTO 27
1142 : C
1143 : IF (MELE.GE.173.and.MELE.LE.184) GO TO 4
1144 : *
1145 : C Elements mecaniques 1D (M1Dx)
1146 : IF (MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
1147 : *
1148 : * elemment shb8
1149 : IF ( mele.eq.260) goto 29
1150 : c
1151 : C_______________________________________________________________________
1152 : C POUR les XFEM on fait un cas particuliers
1153 : IF(MFR.EQ.63) THEN
1154 :
1154 : CALL BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFORC,
1155 : & IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER)
1156 : IF(IRETER.NE.0) RETURN
1157 :
1158 : MPTVAL = IVAFOR
1159 : N1TOT = IPOS(/1)
1160 : N1SUP = N1TOT - 1
1161 : N2TOT = IVAL(/1)
1162 : * si le nombre de sous-zones fournies par BSIGMX doit augmenter...
1163 : c write(6,*) N1TOT,N1SUP,N2TOT,N1,NFOREF,NFACF
1164 : IF (N1SUP.ge.1) THEN
1165 : N1 = N1 + N1SUP
1166 : segadj,MCHELM
1167 : ENDIF
1168 :
1169 : I2TOT = 0
1170 : I1NN = 1
1171 : DO I1=1,(1+N1SUP)
1172 :
1173 : * -cas ou la zone est vide
1174 : if (IPOS(I1).eq.0) then
1175 : N1 = N1 - 1
1176 : segadj,MCHELM
1177 : I2TOT = I2TOT + NSOF(I1)
1178 : if(I1.eq.I1NN) I1NN=I1NN+1
1179 :
1180 : * -cas ou il faut remplir ICHAML avec MCHAM1 = copie du MCHAML pere
1181 : else
1182 : N2=NFOREF+NFACF
1183 : segini,MCHAM1=MCHAML
1184 : * la 1ere fois est repérée par I1NN
1185 : if(I1.ne.I1NN) ISOUS = ISOUS + 1
1186 : ICHAML(ISOUS) = MCHAM1
1187 : c write(6,*) 'bsigmp: creation de ICHAML(',ISOUS,')=',MCHAM1
1188 : IMACHE(ISOUS) = IPOS(I1)
1189 : N2 = NSOF(I1)
1190 : segadj,MCHAM1
1191 : do i2=1,N2
1192 : I2TOT = I2TOT + 1
1193 : MCHAM1.IELVAL(i2) = IVAL(I2TOT)
1194 : enddo
1195 : segdes,MCHAM1
1196 : endif
1197 : ENDDO
1198 :
1199 : * Quand on a fini avec cette zone on n oublie pas de supprimer
1200 : * le MCHAML pere des MCHAM1.
1201 : c * Dans le cas ou ils n ont pas été utilisés,
1202 : c * les MELVAL du MCHAML pere peuvent etre supprimés aussi.
1203 : c if (IPOS(1).eq.0) then
1204 : c DO IB=1,IELVAL(/1)
1205 : c MELVAL=IELVAL(IB)
1206 : c SEGSUP MELVAL
1207 : c ENDDO
1208 : c endif
1209 : * -> cela semble etre une erreur car les melval sont utilisés !!!
1210 : SEGSUP MCHAML
1211 :
1212 : GO TO 510
1213 : ENDIF
1214 : C fin des XFEM _________________________________________________________
1215 : C
1216 : 99 CONTINUE
1217 : MOTERR(1:4)=NOMTP(MELE)
1218 : MOTERR(5:12)='BSIGMA'
1218 : CALL ERREUR(86)
1219 : GOTO 9990
1220 : C_______________________________________________________________________
1221 : C
1222 : C massifs, poreux, joints poreux, incompressibles
1223 : C_______________________________________________________________________
1224 : C
1225 : 4 CONTINUE
1226 : IF (MFR.EQ.71) THEN
1226 : CALL BSIGEL(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
1227 : & IVAFOR,NFORC)
1228 : ELSE IF (MFR.EQ.73) THEN
1228 : CALL BSIGDI(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
1229 : & IVAFOR,NFORC)
1230 : ELSE
1230 : CALL BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,IPMINT,
1231 : & IVACAR,IPORE,LHOOK,NFORC,IVAFOR,ADPG,BDPG,CDPG,
1232 : & IIPDPG,ncar1)
1233 : ENDIF
1234 : GOTO 510
1235 : C_______________________________________________________________________
1236 : C
1237 : C coq3,dkt,coq4,coq8,coq2,dst,jot3,joi4,joi2,joi3
1238 : C_______________________________________________________________________
1239 : C
1240 : 27 CONTINUE
1240 : CALL BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,NBPTEL,
1241 : & MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,NPINT,
1242 : & NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG)
1243 : GOTO 510
1244 : C_______________________________________________________________________
1245 : C
1246 : C poutre,tuyau,linespring,tuyau fissure,barre,poutre Timoschenko
1247 : C joi1, zone_cohesive
1248 : C_______________________________________________________________________
1249 : C
1250 : 29 CONTINUE
1251 : ncaru = ncar1 - 1
1251 : CALL BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,ncaru,IVECT,MELE,CMATE,
1252 : &IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFORC,IVAFOR,ADPG,BDPG,CDPG
1253 : &,IIPDPG,ivamat,NMATT,MFR)
1254 : GOTO 510
1255 : C_______________________________________________________________________
1256 : C
1257 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
1258 : C_______________________________________________________________________
1259 : C
1260 : 510 CONTINUE
1261 : C
1262 : C Cas des modes de calculs GENEralises :
1263 : C creation d'un CHPOINT contenant les forces associees au point
1264 : C support et ajout aux autres CHPOINTs si besoin est
1265 : C
1266 : IF (ldpge) THEN
1267 : K_DPGE=K_DPGE+1
1268 : NSOUPO=1
1269 : NAT=1
1270 : SEGINI , MCHPOI
1271 : ICHPO1=MCHPOI
1272 : MOCHDE=' '
1273 : MTYPOI=' '
1274 : JATTRI(1)=2
1275 : IFOPOI=IFOUR
1276 : NC=NFORDG
1277 : SEGINI , MSOUPO
1278 : IPCHP(1)=MSOUPO
1279 : DO i=1,NFORDG
1280 : NOCOMP(i)=MDDLG(i)
1281 : ENDDO
1282 : KPOINT=IIPDPG
1282 : CALL CRELEM(KPOINT)
1283 : IGEOC=KPOINT
1284 : N=1
1285 : NC=NFORDG
1286 : SEGINI , MPOVAL
1287 : IPOVAL=MPOVAL
1288 : VPOCHA(1,1)=ADPG
1289 : IF (NFORDG.GE.2) THEN
1290 : VPOCHA(1,2)=BDPG
1291 : IF (NFORDG.GE.3) VPOCHA(1,3)=CDPG
1292 : ENDIF
1293 : SEGDES MCHPOI,MSOUPO,MPOVAL
1293 : IF(ICHPAN.NE.0) CALL ADCHPO(ICHPO1,ICHPAN,ICHPO1,1.D0,1.D0)
1294 : ICHPAN=ICHPO1
1295 : ENDIF
1296 : C
1297 : SEGDES MELEME
1298 : *
1299 : IF(ISUP1.EQ.1)THEN
1299 : CALL DTMVAL(IVASTR,3)
1300 : ELSE
1300 : CALL DTMVAL(IVASTR,1)
1301 : ENDIF
1302 : *
1302 : CALL DTMVAL(IVAFOR,1)
1303 : *
1304 : IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
1304 : CALL DTMVAL(IVAMAT,3)
1305 : ELSE
1305 : CALL DTMVAL(IVAMAT,1)
1306 : ENDIF
1307 : *
1308 : IF(ISUP2.EQ.1)THEN
1308 : CALL DTMVAL(IVACAR,3)
1309 : ELSE
1309 : CALL DTMVAL(IVACAR,1)
1310 : ENDIF
1311 : *
1312 : NOMID=MOSTRS
1313 : if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
1314 : NOMID=MOFORC
1315 : if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
1316 : NOMID=MOCARA
1317 : IF (MOCARA.NE.0) SEGSUP NOMID
1318 : NOMID=MOMATR
1319 : IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
1320 : *
1321 : if (mele.ne.260) SEGDES,MINTE
1322 : IF (IERR.NE.0) GO TO 9991
1323 : c if(MCHAML.ne.0) SEGDES MCHAML
1324 : C
1325 : 200 CONTINUE
1326 : C_______________________________________________________________________
1327 : C
1328 : C TRANSFORMATION DU CHAMELEM EN CHPOINT
1329 : C_______________________________________________________________________
1330 : C
1331 : c write(6,*) '--- avant appel a CHAMPO ---'
1332 : c write(6,*) ' isous MCHAML <- IELVAL(...)'
1333 : c do itoto=1,ICHAML(/1)
1334 : c MCHAML=ICHAML(itoto)
1335 : c segact,MCHAML
1336 : c write(6,*)itoto,MCHAML,' <- ',(IELVAL(iou),iou=1,IELVAL(/1))
1337 : c segdes,MCHAML
1338 : c enddo
1338 : CALL CHAMPO(IPCHE5,0,IPCHE4,IRET)
1338 : CALL DTCHAM(IPCHE5)
1339 : IF (IRET.EQ.0) GOTO 9000
1340 : C
1341 : C CAS des modes de calculs GENERALISEs :
1342 : C ON ADDITIONNE LE CHPOINT RESULTANT DE LA TRANSFORMATION DU CHAMELEM
1343 : C ET LE PETIT CHPOINT DES FORCES INTERNES AUx NOEUDs supports
1344 : C
1345 : IF (K_DPGE.NE.0) THEN
1346 :
1346 : CALL ADCHPO(ICHPAN,IPCHE4,IPCHE6,1D0,1D0)
1347 : C
1348 : C PUIS ON DETRUIT LE PETIT CHPOINT ET LE MAILLAGE ASSOCIE
1349 : C
1349 : * CALL ECRCHA(LAGEOM)
1349 : CALL ECROBJ('CHPOINT',ICHPAN)
1349 : CALL DETRUI
1350 : C
1350 : CALL DTCHPO(IPCHE4)
1351 : IPCHE4=IPCHE6
1352 : ENDIF
1353 : if (llent2.gt.0) then
1354 : ipc1 = ipche4
1355 : jg = klent2
1356 : segadj mlent2
1357 : do ipj= 1,jg
1358 : ipcj = mlent2.lect(ipj)
1359 : if (ipcj.gt.0) then
1359 : call adchpo(ipc1,ipcj,ipc2,1.D0,1.D0)
1359 : call dtchpo(ipc1)
1360 : ipc1 = ipc2
1361 : endif
1362 : enddo
1363 : ipche4 = ipc1
1364 : segsup mlent2
1365 : endif
1366 :
1367 : C* Fin normale
1368 : IRET = 1
1369 : GOTO 9000
1370 : *
1371 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
1372 : *
1373 : 9990 CONTINUE
1374 : *
1375 : IF(ISUP1.EQ.1)THEN
1375 : CALL DTMVAL(IVASTR,3)
1376 : ELSE
1376 : CALL DTMVAL(IVASTR,1)
1377 : ENDIF
1378 : *
1378 : CALL DTMVAL(IVAFOR,3)
1379 : *
1380 : IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
1380 : CALL DTMVAL(IVAMAT,3)
1381 : ELSE
1381 : CALL DTMVAL(IVAMAT,1)
1382 : ENDIF
1383 : *
1384 : IF(ISUP2.EQ.1)THEN
1384 : CALL DTMVAL(IVACAR,3)
1385 : ELSE
1385 : CALL DTMVAL(IVACAR,1)
1386 : ENDIF
1387 : *
1388 : NOMID=MOSTRS
1389 : if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
1390 : NOMID=MOFORC
1391 : if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
1392 : NOMID=MOCARA
1393 : IF (MOCARA.NE.0) SEGSUP NOMID
1394 : NOMID=MOMATR
1395 : IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
1396 : if (mele.ne.260) SEGDES,MINTE
1397 : 9991 CONTINUE
1398 : SEGSUP MCHAML
1399 : SEGDES MELEME
1400 : 9992 CONTINUE
1401 : IRET = 0
1402 : SEGSUP MCHELM
1403 :
1404 : C Dernieres desactivations avant de quitter :
1405 : 9000 CONTINUE
1406 : MMODEL=IPMODL
1407 : DO I=1,NSOUS
1408 : IMODEL=KMODEL(I)
1409 : SEGDES,IMODEL
1410 : END DO
1411 : SEGSUP,MMODEL
1412 : SEGDES,MCHEL1
1413 :
1414 : RETURN
1415 : END
1416 :
1417 :
1418 :
1419 :
1420 :
1421 :
1422 :
1423 :
1424 :
1425 :
1426 :
© Cast3M 2003 - All rights reserved.
Disclaimer