1 : C KSIGMP SOURCE AM 13/12/16 21:15:51 7825
2 :
3 : SUBROUTINE KSIGMP(IPMODL,IPCHE1,IPCHE2,IFLAM, IPRIGG)
4 :
5 : c_______________________________________________________________________
6 : c
7 : c
8 : c construction de la matrice de raideur geometrique a partir d'un
9 : c mchaml de contraintes
10 : c
11 : c entr{es:
12 : c ________
13 : c
14 : c ipmodl pointeur sur un mmodel
15 : c ipche1 pointeur sur un mchaml de contraintes
16 : c ipche2 pointeur sur un mchaml de caracteristiques
17 : c iflam flag de flambage
18 : c
19 : c sorties:
20 : c ________
21 : c
22 : c iprigg pointeur sur un objet rigidite
23 : c = 0 en cas d'erreur
24 : c_______________________________________________________________________
25 : c
26 : IMPLICIT INTEGER(I-N)
27 : IMPLICIT REAL*8(A-H,O-Z)
28 :
29 : -INC CCOPTIO
30 : -INC CCHAMP
31 : -INC CCREEL
32 :
33 : -INC SMCHAML
34 : -INC SMCOORD
35 : -INC SMELEME
36 : -INC SMINTE
37 : -INC SMMODEL
38 : -INC SMRIGID
39 : *
40 : INTEGER oooval
41 :
42 : SEGMENT NOTYPE
43 : CHARACTER*16 TYPE(NBTYPE)
44 : ENDSEGMENT
45 : *
46 : SEGMENT MPTVAL
47 : INTEGER IPOS(NS) ,NSOF(NS)
48 : INTEGER IVAL(NCOSOU)
49 : CHARACTER*16 TYVAL(NCOSOU)
50 : ENDSEGMENT
51 : c
52 : SEGMENT MWRK1
53 : REAL*8 REL(LRE,LRE) ,XE(3,NBBB) ,XSTRS(NSTRS)
54 : ENDSEGMENT
55 : *
56 : SEGMENT MWRK2
57 : REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
58 : ENDSEGMENT
59 : *
60 : SEGMENT MWRK3
61 : REAL*8 WORK(LW)
62 : ENDSEGMENT
63 : *
64 : SEGMENT MWRK4
65 : REAL*8 BPSS(3,3) ,XEL(3,NBBB)
66 : ENDSEGMENT
67 : *
68 : SEGMENT MWRK5
69 : REAL*8 GEOM(20), tabw(6,9), tabrot(4,9), XX(3), YY(3)
70 : ENDSEGMENT
71 : *
72 : * segment pour shb8
73 : SEGMENT MWRK7
74 : REAL*8 PROPEL(1),out(1),d(1), work1(30)
75 : ENDSEGMENT
76 : *
77 : character*6 msorse
78 : CHARACTER*8 CMATE
79 : CHARACTER*(NCONCH) CONM
80 : PARAMETER ( NINF=3 )
81 : INTEGER INFOS(NINF)
82 : LOGICAL lsupfo,lsupde,lsupco
83 :
84 : IPRIGG = 0
85 :
86 : IDIMP1 = IDIM+1
87 : *
88 : * verification du lieu support du mchaml de contraintes
89 : *
89 : CALL QUESUP(IPMODL,IPCHE1,3,0,ISUP1,IRET1C)
90 : IF (ISUP1.GT.1) RETURN
91 : *
92 : * verification du lieu support du mchaml de caracteristiques
93 : *
94 : IF (IPCHE2.NE.0) THEN
94 : CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP2,iret2c)
95 : IF (ISUP2.GT.1) RETURN
96 : ENDIF
97 : c
98 : c_______________________________________________________________________
99 : c
100 : c initialisation du chapeau de l objet rigidite
101 : c_______________________________________________________________________
102 : c
103 : NRIGEL = 0
104 : SEGINI,MRIGID
105 : IFORIG = IFOMOD
106 : c* IFORIG = IFOUR
107 : ICHOLE = 0
108 : IMGEO1 = 0
109 : IMGEO2 = 0
110 : ISUPEQ = 0
111 : IF (IFLAM.NE.0) THEN
112 : MTYMAT = 'MASSE'
113 : ELSE
114 : MTYMAT = 'RIGIDITE'
115 : ENDIF
116 : c
117 : c_______________________________________________________________________
118 : c
119 : c activation du modele
120 : c_______________________________________________________________________
121 : c
122 : MMODEL = IPMODL
123 : SEGACT,MMODEL
124 : NSOUS = KMODEL(/1)
125 : c
126 : c boucle sur les modeles elementaires
127 : c
128 : DO 500 ISOUS = 1,NSOUS
129 : c
130 : c traitement du modele
131 : c
132 : IMODEL = KMODEL(ISOUS)
133 : SEGACT,IMODEL
134 : *
135 : * INITIALISATIONS
136 : *
137 : IPMINT = 0
138 : IPMIN1 = 0
139 :
140 : MOSTRS = 0
141 : MOCARA = 0
142 : MOTYPS = 0
143 : MOTYPC = 0
144 :
145 : MODEPL = 0
146 : MOFORC = 0
147 : lsupde = .false.
148 : lsupfo = .false.
149 : lsupco = .false.
150 :
151 : IDESCR = 0
152 :
153 : C- Recuperation d'informations sur le maillage elementaire
154 : IPT1 = IMAMOD
155 : SEGACT,IPT1
156 : NBNOE1 = IPT1.NUM(/1)
157 : NBELE1 = IPT1.NUM(/2)
158 :
159 : C- Quelques informations sur le modele
160 : IIPDPG= IPDPGE
161 :
162 : CONM = CONMOD
163 : CMATE = CMATEE
164 : MATE = IMATEE
165 : c* INAT = INATUU
166 :
167 : IRTD = 1
167 : CALL IDENT(IPT1,CONM,IPCHE1,IPCHE2, INFOS,IRTD)
168 : IF (IRTD.EQ.0) GOTO 599
169 : C
170 : C- Recuperation d'informations sur l'element fini
171 : MELE = NEFMOD
172 : c pour l'el. timo on utilise l'el. barr
173 : c IF (MELE .EQ. 84) MELE = 46
174 : c bp: comme il n y a plus elquoi, ce n'est pas ici que ca intervient...
175 :
176 : c coque integree ou pas ?
177 : IF (INFMOD(/1).NE.0)THEN
178 : NPINT = INFMOD(1)
179 : IF (NPINT.NE.0) THEN
179 : CALL ERREUR(615)
180 : GOTO 599
181 : ENDIF
182 : ELSE
183 : NPINT = 0
184 : ENDIF
185 :
186 : LHOOK = INFELE(10)
187 : c* LHOO2 = LHOOK*LHOOK
188 : NSTRS = INFELE(16)
189 : MFR = INFELE(13)
190 : LW = INFELE(7)
191 : NDDL = INFELE(15)
192 : LRE = INFELE(9)
193 : IPORE = INFELE(8)
194 : NHRM = NIFOUR
195 :
196 : IPPORE = 0
197 : IF (MFR.EQ.33) IPPORE = NBNOE1
198 :
199 : c_______________________________________________________________________
200 : * segments d'integration *
201 : c_______________________________________________________________________
202 : * minte : 1er segment d'integration, il existe pour tous les e.f.
203 : * minte1: 2eme segment d'integration, uniquement pour certains e.f.
204 : * en particulier pour coq6 et coq8
205 : * nbpg:nb de points de gauss = nbpgau du segment minte
206 : * iele:no d'element geometrique associe a l'e.f. mele
207 : * nbff:nb de fonctions de forme = nbno du segment minte
208 : NBPGAU = INFELE( 6)
209 : IELE = INFELE( 14)
210 : c* ICARA = INFELE( 5)
211 : IPMINT = INFMOD(5)
212 : c* IPMINT = INFELE(11)
213 : IPMIN1 = INFMOD(8)
214 : MINTE = IPMINT
215 : IF (IPMINT.NE.0) SEGACT,MINTE
216 :
217 : c_______________________________________________________________________
218 : c
219 : * initialisation du segment descr, segment descripteur des *
220 : * des inconnues relatives a la matrice de rigidite *
221 : c_______________________________________________________________________
222 : if (lnomid(1).ne.0) then
223 : MODEPL = lnomid(1)
224 : else
225 : lsupde = .true.
225 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NDUM)
226 : endif
227 : nomid = MODEPL
228 : segact,nomid
229 : ndepl = lesobl(/2)
230 : c* ndum = lesfac(/2)
231 :
232 : if (lnomid(2).ne.0) then
233 : moforc = lnomid(2)
234 : else
235 : lsupfo=.true.
235 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM)
236 : endif
237 : nomid = MOFORC
238 : segact,nomid
239 : nforc = lesobl(/2)
240 : c* ndum = lesfac(/2)
241 : *
242 : IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
242 : CALL ERREUR(5)
243 : GOTO 598
244 : ENDIF
245 : *
246 : * REMPLISSAGE DU SEGMENT DESCRIPTEUR
247 : *
248 : NLIGRP = LRE
249 : NLIGRD = LRE
250 :
251 : SEGINI DESCR
252 : c
253 : NCOMP=NDEPL
254 : NBNNS=NBNOE1
255 : IF (MFR.EQ.33) NCOMP=NDEPL-1
256 : IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS = NBNOE1/2
257 : IDDL = 1
258 : DO 1004 INOEUD=1,NBNNS
259 : DO 1005 ICOMP=1,NCOMP
260 : NOMID=MODEPL
261 : LISINC(IDDL)=LESOBL(ICOMP)
262 : NOMID=MOFORC
263 : LISDUA(IDDL)=LESOBL(ICOMP)
264 : NOELEP(IDDL)=INOEUD
265 : NOELED(IDDL)=INOEUD
266 : IDDL=IDDL+1
267 : 1005 CONTINUE
268 : 1004 CONTINUE
269 : *
270 : * cas des milieux poreux
271 : *
272 : * if (mfr.eq.33) then
273 : * ipos = nspos(iele)
274 : * do 1104 inoeud=1,nbsom(iele)
275 : * nomid=modepl
276 : * lisinc(iddl)=lesobl(ndepl)
277 : * nomid=moforc
278 : * lisdua(iddl)=lesobl(ndepl)
279 : * i = ibsom(ipos+inoeud-1)
280 : * noelep(iddl)=i
281 : * noeled(iddl)=i
282 : * iddl=iddl+1
283 : *1104 continue
284 : * endif
285 : *
286 : * cas des element raccord
287 : *
288 : IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
288 : CALL IDDEPL(MFR+1000,IFOUR,MODPL1,NDEPL,NDUM)
288 : CALL IDFORC(MFR+1000,IFOUR,MOFRC1,NFORC,NDUM)
289 : DO 1106 INOEUD=NBNNS+1,NBNN
290 : DO 1107 ICOMP=1,NDEPL
291 : NOMID=MODPL1
292 : LISINC(IDDL)=LESOBL(ICOMP)
293 : NOMID=MOFRC1
294 : LISDUA(IDDL)=LESOBL(ICOMP)
295 : NOELEP(IDDL)=INOEUD
296 : NOELED(IDDL)=INOEUD
297 : IDDL=IDDL+1
298 : 1107 continue
299 : 1106 continue
300 : NOMID=MODPL1
301 : SEGSUP,NOMID
302 : NOMID=MOFRC1
303 : SEGSUP,NOMID
304 : ENDIF
305 :
306 : SEGDES,DESCR
307 : IDESCR = DESCR
308 : c_______________________________________________________________________
309 : c
310 : * composantes de contraintes necessaires *
311 : c_______________________________________________________________________
312 : if (lnomid(4).ne.0) then
313 : MOSTRS = lnomid(4)
314 : else
315 : lsupco=.true.
315 : CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
316 : endif
317 : nomid = MOSTRS
318 : segact,nomid
319 : nstr=lesobl(/2)
320 : c* nfac=lesfac(/2)
321 : c* write(6,*) 'mostrts',mostrs,nstr,nfac
322 : nbtype = 1
323 : SEGINI,notype
324 : TYPE(1)='REAL*8'
325 : MOTYPS = notype
326 :
327 : ifai = 1
328 : if (mele.eq.260.and.IRET1C.eq.5) ifai = 0
329 : ISUP1L = 0
330 : IF (ISUP1.EQ.1.AND.ifai.eq.1) ISUP1L = 1
331 :
332 : c____________________________________________________________________
333 : c
334 : * traitement des champs de caracteristiques *
335 : c____________________________________________________________________
336 : NBROBL = 0
337 : NBRFAC = 0
338 : IVECT = 0
339 : notype = 0
340 : nomid = 0
341 : *
342 : * v1x v1y dans le cas de la coque dst orthotrope
343 : *
344 : IF (MFR.EQ.9) THEN
345 : IF (MELE.EQ.93.AND.CMATE.NE.'ISOTROPE')THEN
346 : NBROBL=2
347 : SEGINI NOMID
348 : LESOBL(1)='V1X '
349 : LESOBL(2)='V1Y '
350 : *
351 : NBTYPE=1
352 : SEGINI NOTYPE
353 : TYPE(1)='REAL*8'
354 : ENDIF
355 : *
356 : * epaisseur dans le cas massif et coq2 en contraintes planes
357 : *
358 : ELSE IF ( (MFR.EQ.1.OR.MFR.EQ.3.OR.MFR.EQ.31) .AND.
359 : + IFOUR.EQ.-2 .AND. IPCHE2.NE.0) THEN
360 : NBRFAC=1
361 : SEGINI NOMID
362 : LESFAC(1)='DIM3'
363 : *
364 : NBTYPE=1
365 : SEGINI NOTYPE
366 : TYPE(1)='REAL*8'
367 : *
368 : * epaisseur et excentrement dans le cas des coques epaisses
369 : *
370 : ELSE IF (MFR.EQ.5 .OR. (MFR.EQ.3.AND.IFOUR.NE.-2)) THEN
371 : NBROBL=1
372 : NBRFAC=1
373 : SEGINI NOMID
374 : LESOBL(1)='EPAI'
375 : LESFAC(1)='EXCE'
376 :
377 : NBTYPE=1
378 : SEGINI NOTYPE
379 : TYPE(1)='REAL*8'
380 : *
381 : * caracteristiques pour les poutres
382 : *
383 : ELSE IF (MFR.EQ.7 ) THEN
384 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
385 : NBROBL=2
386 : NBRFAC=1
387 : SEGINI NOMID
388 : LESOBL(1)='SECT'
389 : LESOBL(2)='INRZ'
390 : LESFAC(1)='SECY'
391 : *
392 : NBTYPE=1
393 : SEGINI NOTYPE
394 : TYPE(1)='REAL*8'
395 : ELSE
396 : NBROBL=4
397 : NBRFAC=6
398 : IVECT =1
399 : SEGINI NOMID
400 : LESOBL(1)='TORS'
401 : LESOBL(2)='INRY'
402 : LESOBL(3)='INRZ'
403 : LESOBL(4)='SECT'
404 : LESFAC(1)='SECY'
405 : LESFAC(2)='SECZ'
406 : LESFAC(3)='VECT'
407 : LESFAC(4)='VX '
408 : LESFAC(5)='VY '
409 : LESFAC(6)='VZ '
410 : *
411 : NBTYPE=10
412 : SEGINI NOTYPE
413 : TYPE(1)='REAL*8'
414 : TYPE(2)='REAL*8'
415 : TYPE(3)='REAL*8'
416 : TYPE(4)='REAL*8'
417 : TYPE(5)='REAL*8'
418 : TYPE(6)='REAL*8'
419 : TYPE(7)='POINTEURPOINT '
420 : TYPE(8)='REAL*8'
421 : TYPE(9)='REAL*8'
422 : TYPE(10)='REAL*8'
423 : ENDIF
424 : *
425 : * caracteristiques pour les tuyaux
426 : *
427 : ELSE IF (MFR.EQ.13) THEN
428 : NBROBL = 2
429 : NBRFAC = 6
430 : IVECT = 1
431 : SEGINI NOMID
432 : LESOBL(1)='EPAI'
433 : LESOBL(2)='RAYO'
434 : LESFAC(1)='RACO'
435 : LESFAC(2)='CISA'
436 : LESFAC(3)='VECT'
437 : LESFAC(4)='VX '
438 : LESFAC(5)='VY '
439 : LESFAC(6)='VZ '
440 : *
441 : NBTYPE = 8
442 : SEGINI NOTYPE
443 : TYPE(1)='REAL*8'
444 : TYPE(2)='REAL*8'
445 : TYPE(3)='REAL*8'
446 : TYPE(4)='REAL*8'
447 : TYPE(5)='POINTEURPOINT '
448 : TYPE(6)='REAL*8'
449 : TYPE(7)='REAL*8'
450 : TYPE(8)='REAL*8'
451 : ENDIF
452 : *
453 : MOCARA = NOMID
454 : MOTYPC = NOTYPE
455 : NCARA = NBROBL
456 : NCARF = NBRFAC
457 : NCARR = NCARA+NCARF
458 :
459 : IF (MOCARA.NE.0 .AND. IPCHE2.EQ.0) THEN
460 : MOTERR(1:8) = 'CARACTER'
461 : MOTERR(9:12) = NOMTP(MELE)
462 : MOTERR(13:20)= 'KSIGMA'
462 : CALL ERREUR(145)
463 : GOTO 598
464 : ENDIF
465 :
466 : ifai = 1
467 : IF (mele.EQ.260) ifai = 0
468 : ISUP2L = 0
469 : IF (ISUP2.EQ.1.AND.ifai.eq.1) ISUP2L = 1
470 :
471 : C- Partionnement si necessaire de la matrice de capacite
472 : C- determinant ainsi le nombre d'objets elementaires de MRIGID
473 : LTRK = oooval(1,4)
474 : IF (LTRK.EQ.0) LTRK = oooval(1,1)
475 : * Ajout a la taille en mots de la matrice des infos du segment
476 : LSEG = LRE*LRE*NBELE1 + 16
477 : NBLPRT = (LSEG-1)/LTRK + 1
478 : NBLMAX = (NBELE1-1)/NBLPRT + 1
479 : NBLPRT = (NBELE1-1)/NBLMAX + 1
480 : * write(ioimp,*) ' capa1 : nblprt nblmax = ',nblprt,nblmax,nbele1
481 :
482 : C Ajout de la matrice a la matrice globale
483 : C ========================================
484 : NRIGE0 = IRIGEL(/2)
485 : * NRIGEL = NRIGE0 + NBLPRT
486 : * SEGADJ,MRIGID
487 :
488 : descr = IDESCR
489 : meleme = IPT1
490 : nbnn = NBNOE1
491 : nbelem = NBELE1
492 : nbsous = 0
493 : nbref = 0
494 : *
495 : ************************************************************************
496 : * P H A S E 2
497 : *
498 : * Boucle sur les PARTITIONS elementaires de la matrice
499 : *
500 : ************************************************************************
501 : DO irige = 1, NBLPRT
502 :
503 : IF (NBLPRT.GT.1) THEN
504 : C- Partitionnement du maillage support de la matrice elementaire
505 : C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
506 : SEGACT,IPT1
507 : ielem = (irige-1)*NBLMAX
508 : nbelem = MIN(NBLMAX,NBELE1-ielem)
509 : * write(ioimp,*) ' creation segment ',nbnn,nbelem
510 : SEGINI,meleme
511 : itypel = IPT1.itypel
512 : DO ielt = 1, nbelem
513 : jelt = ielt + ielem
514 : DO inoe = 1, nbnn
515 : num(inoe,ielt) = IPT1.NUM(inoe,jelt)
516 : ENDDO
517 : icolor(ielt) = IPT1.ICOLOR(jelt)
518 : ENDDO
519 : C- Recopie du descripteur
520 : des1 = IDESCR
521 : SEGINI,descr=des1
522 : SEGDES,descr
523 : ENDIF
524 :
525 : ipmail = meleme
526 : ipdesc = descr
527 :
528 : C- Initialisation de la matrice de rigidite elementaire (xmatri)
529 : NELRIG = nbelem
530 : SEGINI,xmatri
531 : ipmatr = xmatri
532 :
533 : C- Recuperation des valeurs des contraintes et proprietes geometriques
534 : IVASTR = 0
535 : IVACAR = 0
536 : IVECTL = IVECT
537 : NCARR1 = NCARR
538 : *
538 : CALL KOMCHA(IPCHE1,ipmail,CONM,MOSTRS,MOTYPS,1,INFOS,3,IVASTR)
539 : IF (IERR.NE.0) GOTO 597
540 : IF (ISUP1L.EQ.1) THEN
540 : CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE)
541 : IF (IERR.NE.0) THEN
542 : ISUP1L = 0
543 : GOTO 597
544 : ENDIF
545 : ENDIF
546 :
547 : IF (MOCARA.NE.0) THEN
547 : CALL KOMCHA(IPCHE2,ipmail,CONM,MOCARA,MOTYPC,1,
548 : & INFOS,3,IVACAR)
549 : IF (IERR.NE.0) GOTO 597
550 : IF (ISUP2L.EQ.1) THEN
550 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
551 : IF (IERR.NE.0) THEN
552 : ISUP2L = 0
553 : GOTO 597
554 : ENDIF
555 : ENDIF
556 : IF (IVECT.EQ.1) THEN
557 : MPTVAL = IVACAR
558 : NCARR1 = NCARR - 3
559 : IF (IVAL(NCARR1).EQ.0) IVECTL = 2
560 : ENDIF
561 : ENDIF
562 :
563 : c_______________________________________________________________________
564 : c
565 : c numero des etiquettes :
566 : c etiquettes de 1 a 98 pour traitement specifique a l element
567 : c dans la zone specifique a chaque element commencant par :
568 : c 5 continue
569 : c element 5 etiquettes 1005 2005 3005 4005 ...
570 : c 44 continue
571 : c element 44 etiquettes 1044 2044 3044 4044 ...
572 : c_______________________________________________________________________
573 :
574 : IF (MELE.LE.100) THEN
575 : GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
576 : 1 99,99, 4, 4, 4, 4,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
577 : 2 41,29,43,44,99,46,99,99,49,99,51,99,99,99,99,41,99,99,99,99,
578 : 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,
579 : 4 99,99,99,29,99,99,99,99,99,99,99,99,28,99,46,99,99,99,99,99
580 : 5 ),MELE
581 : ELSE IF (MELE.LE.200) THEN
582 : GOTO (99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
583 : 1 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
584 : 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
585 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
586 : 4 99,99, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
587 : 5 ),MELE-100
588 : ELSE IF (MELE.LE.300) THEN
589 : GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
590 : 1 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
591 : 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
592 : & 260,
593 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
594 : 4 99,99, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
595 : 5 ),MELE-200
596 : ENDIF
597 : c
598 : 99 CONTINUE
599 : * MOTERR(1:4) = NOMTP(MELE)
600 : * MOTERR(5:12) = 'KSIGMP '
600 : * CALL ERREUR(86)
601 : GOTO 510
602 : c
603 : c_______________________________________________________________________
604 : c
605 : c secteur de calcul pour les elements massifs
606 : c_______________________________________________________________________
607 : 4 CONTINUE
608 : NBNO = NBNN
609 : NBBB = NBNN
610 : SEGINI,MWRK1,MWRK2
611 : c recuperation de l'epaisseur
612 : DIM3 = 1.D0
613 : MEPDI3 = 0
614 : c* IF (IFOUR.EQ.-2.AND.IPCHE2.NE.0) THEN
615 : IF (IVACAR.NE.0) THEN
616 : MPTVAL = IVACAR
617 : MEPDI3 = IVAL(1)
618 : ENDIF
619 :
620 : DO 3004 IB=1,NBELEM
621 : c
622 : c on cherche les coordonnees des noeuds de l element ib
623 : c
623 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
623 : CALL ZERO(REL,LRE,LRE)
624 : c
625 : c boucle sur les points de gauss
626 : c
627 : ISDJC = 0
628 : DO 4004 IGAU=1,NBPGAU
629 : c
630 : c recuperation de l'epaisseur
631 : IF (MEPDI3.NE.0) THEN
632 : MELVAL = MEPDI3
633 : IGMN=MIN(IGAU,VELCHE(/1))
634 : IBMN=MIN( IB,VELCHE(/2))
635 : DIM3=VELCHE(IGMN,IBMN)
636 : ENDIF
637 : c
638 : DO 100 IA=1,NBNN
639 : DO 100 IO=1,IDIMP1
640 : SHPWRK(IO,IA)=SHPTOT(IO,IA,IGAU)
641 : 100 CONTINUE
641 : CALL DEVOLU(XE,SHPWRK,MFR,NBNN,IFOUR,NIFOUR,IDIM,DIM3,
642 : & RR,DJAC)
643 : c
644 : c verification du signe du jacobien
645 : c
646 : IF (DJAC.LT.0.) ISDJC=ISDJC+1
647 : DJAC = ABS(DJAC)
648 : IF (DJAC.LT.XPETIT) THEN
649 : INTERR(1) = IB
649 : CALL ERREUR(259)
650 : GOTO 9004
651 : ENDIF
652 : DJAC = DJAC * POIGAU(IGAU)
653 : c
654 : c on recupere les contraintes
655 : c
656 : MPTVAL=IVASTR
657 : DO 5004 ICOMP=1,NSTR
658 : MELVAL=IVAL(ICOMP)
659 : IGMN = MIN(IGAU,VELCHE(/1))
660 : IBMN = MIN(IB ,VELCHE(/2))
661 : XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
662 : 5004 CONTINUE
663 : c
664 : IF (IFOUR.EQ.1) THEN
665 : IF (NIFOUR.EQ.0) THEN
665 : CALL THSIG1(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,RR)
666 : ELSE
666 : CALL THSIG2(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,NIFOUR,RR)
667 : ENDIF
668 : ELSE IF (IFOUR.EQ.0) THEN
668 : CALL THSIG3(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,RR)
669 : ELSE
669 : CALL THSIGH(SHPWRK,DJAC,XSTRS,NBNN,IDIM,LRE,REL)
670 : ENDIF
671 : c
672 : 4004 CONTINUE
673 :
674 : IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
675 : INTERR(1) = IB
675 : CALL ERREUR(195)
676 : GOTO 9004
677 : ENDIF
678 : c
679 : c remplissage de xmatri
680 : c
680 : CALL REMPMT(REL,LRE,RE(1,1,ib))
681 : c
682 : 3004 CONTINUE
683 :
684 : 9004 CONTINUE
685 : SEGSUP MWRK1,MWRK2
686 : GOTO 510
687 : c
688 : c_______________________________________________________________________
689 : c
690 : ccccccccccccccccccc element coq3
691 : c_______________________________________________________________________
692 : 27 CONTINUE
693 : NBBB = NBNN
694 : SEGINI,MWRK1,MWRK3,MWRK4
695 :
696 : DO 3027 IB = 1, NBELEM
697 : c
698 : c on cherche les coordonnees des noeuds de l element ib
699 : c
699 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
700 : c
700 : CALL ZERO(REL,LRE,LRE)
701 : c
702 : c on cherche les contraintes
703 : c
704 : MPTVAL=IVASTR
705 : DO 5027 ICOMP=1,NSTR
706 : MELVAL=IVAL(ICOMP)
707 : IBMN=MIN(IB ,VELCHE(/2))
708 : XSTRS(ICOMP)=VELCHE(1,IBMN)
709 : 5027 CONTINUE
710 : c
711 : ccccccc on calcule k(sigma)
712 : c
712 : CALL COQ3KS(REL,XSTRS,XE,1.D0,WORK)
713 : c
714 : c remplissage de xmatri
715 : c
715 : CALL REMPMT(REL,LRE,RE(1,1,ib))
716 :
717 : 3027 CONTINUE
718 :
719 : 9027 CONTINUE
720 : SEGSUP,MWRK1,MWRK3,MWRK4
721 : GOTO 510
722 : c
723 : c_______________________________________________________________________
724 : c
725 : c element dkt , dst
726 : c_______________________________________________________________________
727 : 28 CONTINUE
728 : DIM3 = 1.D0
729 : NBNO = NBNN
730 : IDI2=IDIM-1
731 : NBBB=NBNN
732 : SEGINI MWRK1,MWRK2,MWRK4,MWRK5
733 : XX(1)=.5D0
734 : XX(2)=.0D0
735 : XX(3)=.5D0
736 : YY(1)=.0D0
737 : YY(2)=.5D0
738 : YY(3)=.5D0
739 : C Pour la recuperation de l'epaisseur des elements DKT
740 : IEPDKT = 0
741 : IF (MFR.EQ.3 .AND. IFOUR.NE.-2) IEPDKT = IVACAR
742 : c*of 2011/06/22 : Quid de l'epaisseur pour les DST ????? EPAI = 0 ici !!
743 : C Pour la recuperation des axes d'orthotropie des elements DST
744 : IAODST = 0
745 : IF (MELE.EQ.93.AND.CMATE.NE.'ISOTROPE') IAODST = IVACAR
746 :
747 : DO 3028 IB=1,NBELEM
748 :
749 : c on cherche les coordonnees des noeuds de l element ib
750 : c
750 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
751 :
751 : CALL ZERO(REL,LRE,LRE)
751 : CALL VPAST(XE,BPSS)
752 : c bpss stocke la matrice de passage
752 : CALL VCORLC (XE,XEL,BPSS)
753 : c
754 : c boucle sur les points de gauss
755 : c
756 : DO 4028 IGAU=1,NBPGAU
757 : c
758 : c recuperation de l'epaisseur (element DKT)
759 : IF (IEPDKT.NE.0) THEN
760 : MPTVAL=IEPDKT
761 : MELVAL=IVAL(1)
762 : IGMN=MIN(IGAU,VELCHE(/1))
763 : IBMN=MIN(IB,VELCHE(/2))
764 : EPAI=VELCHE(IGMN,IBMN)
765 : ELSE
766 : EPAI = 0.D0
767 : ENDIF
768 : c
768 : call DKTSHP(IGAU,XEL,tabw,DJAC)
768 : call GEOCST(XEL,GEOM)
768 : call BBGFDK(XX(IGAU),YY(IGAU),GEOM,tabrot)
769 :
770 : DO 6028 IC=1,NBNN
771 : DO 6028 ID=1,6
772 : SHPWRK(ID,IC)=SHPTOT(ID,IC,IGAU)
773 : 6028 CONTINUE
774 :
774 : CALL DEVOLU(XEL,SHPWRK,MFR,NBNN,IFOUR,NIFOUR,IDI2,DIM3,
775 : & RR,DJAC)
776 : DJAC=DJAC*POIGAU(IGAU)
777 : c
778 : c on cherche les contraintes
779 : c
780 : MPTVAL=IVASTR
781 : DO 5028 ICOMP=1,NSTRS
782 : MELVAL=IVAL(ICOMP)
783 : IGMN=MIN(IGAU,VELCHE(/1))
784 : IBMN=MIN(IB ,VELCHE(/2))
785 : XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
786 : * write(6,*)' xstrs(icomp)',icomp,XSTRS(ICOMP)
787 : 5028 CONTINUE
788 :
789 : C Recuperation des axes d'orthotropie (element DST)
790 : IF (IAODST.NE.0) THEN
791 : MPTVAL=IAODST
792 : MELVAL=IVAL(1)
793 : IBMN=MIN(IB ,VELCHE(/2))
794 : IGMN=MIN(IGAU,VELCHE(/1))
795 : COSA=VELCHE(IGMN,IBMN)
796 : MELVAL=IVAL(2)
797 : IBMN=MIN(IB ,VELCHE(/2))
798 : IGMN=MIN(IGAU,VELCHE(/1))
799 : SINA=VELCHE(IGMN,IBMN)
800 : CC=COSA*COSA
801 : SS=SINA*SINA
802 : CS=SINA*COSA
803 : *
804 : * chgt d'axes
805 : *
806 : SIG1=CC*XSTRS(1)+SS*XSTRS(2)-2.D0*CS*XSTRS(3)
807 : SIG2=CC*XSTRS(2)+SS*XSTRS(1)+2.D0*CS*XSTRS(3)
808 : SIG3=CS*(XSTRS(1)-XSTRS(2))+(CC-SS)*XSTRS(3)
809 : XSTRS(1)=SIG1
810 : XSTRS(2)=SIG2
811 : XSTRS(3)=SIG3
812 : ENDIF
813 : c
813 : CALL DKTHSH(SHPWRK,tabw,tabrot,DJAC,XSTRS,REL,EPAI)
814 : 4028 CONTINUE
815 :
815 : CALL TRANSK(REL,BPSS,LRE,3,1)
816 : c
817 : c remplissage de xmatri
818 : c
818 : CALL REMPMT(REL,LRE,RE(1,1,ib))
819 : c
820 : 3028 CONTINUE
821 :
822 : 9028 CONTINUE
823 : SEGSUP,MWRK1,MWRK2,MWRK4,MWRK5
824 : GOTO 510
825 :
826 : c_______________________________________________________________________
827 : c
828 : c element poutre
829 : c_______________________________________________________________________
830 : 29 CONTINUE
831 : NBBB = NBNN
832 : SEGINI,MWRK1,MWRK3
833 :
834 : DO 3029 IB=1,NBELEM
835 : c
836 : c on cherche les coordonnees des noeuds de l elementib
837 : c
837 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
838 : c
839 : c il faudrait aussi modifier le vecteur local de la poutre
840 : c
841 : c mise a zero de la raideur geometrique
842 : c
842 : CALL ZERO(REL,LRE,LRE)
843 : c
844 : c rangement des caracteristiques dans work
845 : c
846 : MPTVAL=IVACAR
847 : DO 6029 IC=1,NCARR
848 : WORK(IC)=0.D0
849 : IF (IVAL(IC).NE.0) THEN
850 : MELVAL=IVAL(IC)
851 : IBMN=MIN(IB,VELCHE(/2))
852 : DO 4029 IGAU=1,NBNN
853 : IGMN=MIN(IGAU,VELCHE(/1))
854 : IF (IGMN.GT.0.AND.IBMN.GT.0) THEN
855 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
856 : ENDIF
857 : 4029 CONTINUE
858 : WORK(IC)=WORK(IC)/NBNN
859 : ENDIF
860 : 6029 CONTINUE
861 : c
862 : c cas ou on a lu le mot vecteur
863 : c
864 : IF (IVECTL.EQ.1) THEN
865 : MELVAL=IVAL(NCARR1)
866 : IBMN=MIN(IB,IELCHE(/2))
867 : IREF=(IELCHE(1,IBMN)-1)*(IDIM+1)
868 : DO 6129 IC=1,IDIM
869 : WORK(NCARR1+IC-1) = XCOOR(IREF+IC)
870 : 6129 CONTINUE
871 : c
872 : c cas du chamelem comverti
873 : c
874 : ELSE IF (IVECT.EQ.2) THEN
875 : DO 6429 IC=NCARR1+1,NCARR1+IDIM
876 : MELVAL=IVAL(IC)
877 : IF (MELVAL.NE.0) THEN
878 : IBMN=MIN(IB,VELCHE(/2))
879 : WORK(IC)=VELCHE(1,IBMN)
880 : ENDIF
881 : 6429 CONTINUE
882 : ENDIF
883 : c
884 : c cas des tuyaux - on calcule les caracteristiques de la poutre
885 : c equivalente
886 : c
887 : IF (MELE.EQ.42) THEN
888 : CISA=WORK(4)
889 : VX=WORK(5)
890 : VY=WORK(6)
891 : VZ=WORK(7)
891 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0)
892 : IF (KERRE.EQ.77) THEN
892 : CALL ERREUR(77)
893 : GOTO 9029
894 : ENDIF
895 : ENDIF
896 : c
897 : c on cherche les contraintes - on les met dans work
898 : c
899 : IE = 9
900 : MPTVAL=IVASTR
901 : DO 7029 ID=1,2
902 : ID2=ID
903 : IF (NBPGAU.EQ.1.AND.ID.EQ.2) ID2=1
904 : DO 7029 ICOMP=1,NSTR
905 : IE = IE+1
906 : MELVAL=IVAL(ICOMP)
907 : IGMN=MIN(ID2 ,VELCHE(/1))
908 : IBMN=MIN(IB ,VELCHE(/2))
909 : WORK(IE)=VELCHE(IGMN,IBMN)
910 : 7029 CONTINUE
911 : c
912 : c on calcule la rigidite geometrique
913 : c
914 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
914 : CALL POUKS2(REL,LRE,WORK(10),WORK,XE,WORK(22),KERRE)
915 : ELSE
915 : CALL POUKSG(REL,LRE,WORK(10),WORK,XE,WORK(22),KERRE)
916 : ENDIF
917 :
918 : IF (KERRE.NE.0) THEN
919 : INTERR(1)=ISOUS
920 : INTERR(2)=IB
920 : CALL ERREUR(128)
921 : GOTO 9029
922 : ENDIF
923 : c
924 : c remplissage de xmatri
925 : c
925 : CALL REMPMT(REL,LRE,RE(1,1,ib))
926 : *
927 : 3029 CONTINUE
928 : c
929 : 9029 CONTINUE
930 : SEGSUP,MWRK1,MWRK3
931 : c
932 : GOTO 510
933 : c_______________________________________________________________________
934 : c
935 : c elements coq8 et coq6
936 : c_______________________________________________________________________
937 : 41 CONTINUE
938 : NBBB=NBNN
939 : LRI =NBNN*5
940 : SEGINI,MWRK1,MWRK3
941 : c
942 : MINTE1 = IPMIN1
943 : SEGACT,MINTE1
944 : c
945 : DO 3041 IB=1,NBELEM
946 : c
947 : c on cherche les coordonnees des noeuds de l elementib
948 : c
948 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
949 :
949 : CALL ZERO(REL,LRE,LRE)
950 : c
951 : c on cherche les caracteristiques de l element ib
952 : c
953 : MPTVAL = IVACAR
954 : MELVAL = IVAL(1)
955 : IF (MELVAL.NE.0) THEN
956 : IBMN = MIN(IB ,VELCHE(/2))
957 : DO IGAU = 1, NBNN
958 : IGMN = MIN(IGAU,VELCHE(/1))
959 : WORK(IGAU) = VELCHE(IGMN,IBMN)
960 : ENDDO
961 : ELSE
962 : DO IGAU = 1, NBNN
963 : WORK(IGAU)=0.D0
964 : ENDDO
965 : ENDIF
966 : c
967 : c on cherche les contraintes - on les met dans work
968 : c
969 : IE = 9
970 : MPTVAL=IVASTR
971 : DO 7041 IGAU=1,NBPGAU
972 : DO 7041 ICOMP=1,NSTRS
973 : MELVAL=IVAL(ICOMP)
974 : IGMN=MIN(IGAU,VELCHE(/1))
975 : IBMN=MIN(IB ,VELCHE(/2))
976 : WORK(IE)=VELCHE(IGMN,IBMN)
977 : IE=IE+1
978 : 7041 CONTINUE
979 : c
980 : c on calcule la rigidite geometrique
981 : c
981 : CALL COQ8KS(REL,XE,SHPTOT,MINTE1.SHPTOT,
982 : & NBPGAU,POIGAU,DZEGAU,
983 : & WORK(1),WORK(9),NBNN,LRE,LRI,WORK(51))
984 : c
985 : c remplissage de xmatri
986 : c
986 : CALL REMPMT(REL,LRE,RE(1,1,ib))
987 : *
988 : 3041 CONTINUE
989 :
990 : 9041 CONTINUE
991 : SEGDES,MINTE1
992 : SEGSUP,MWRK1,MWRK3
993 : GO TO 510
994 : c_______________________________________________________________________
995 : c
996 : c tuyau fissure
997 : c_______________________________________________________________________
998 : 43 CONTINUE
999 : c ksigma n a pas de sens evident pour cet element
1000 : c on cree une matrice nulle
1001 : c DO 3043 IB=1,NBELEM
1002 : c do 4043 ic=1,lval
1003 : c re(ic,ic,ib)=0.d0
1004 : c 4043 continue
1005 : c 3043 CONTINUE
1006 : GOTO 510
1007 : c
1008 : c_______________________________________________________________________
1009 : c
1010 : c element coq2
1011 : c_______________________________________________________________________
1012 : c
1013 : 44 CONTINUE
1014 : DIM3=1.D0
1015 : NBBB=NBNN
1016 : SEGINI MWRK1,MWRK3,MWRK4
1017 : c
1018 : DO 3044 IB=1,NBELEM
1019 : c
1020 : c on cherche les coordonnees des noeuds de l element ib
1021 : c
1021 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
1022 :
1022 : CALL ZERO(REL,LRE,LRE)
1023 : c
1024 : c recuperation de l'epaisseur
1025 : c
1026 : IF (IFOUR.EQ.-2.AND.IPCHE2.NE.0) THEN
1027 : MPTVAL=IVACAR
1028 : MELVAL=IVAL(1)
1029 : IF (MELVAL.NE.0) THEN
1030 : IBMN=MIN(IB,VELCHE(/2))
1031 : DIM3=VELCHE(1,IBMN)
1032 : ELSE
1033 : DIM3 = 1.D0
1034 : ENDIF
1035 : ENDIF
1036 : c
1037 : c on cherche les contraintes on les met dans work...
1038 : c
1039 : JC = 0
1040 : MPTVAL=IVASTR
1041 : DO 5044 IGAU=1,NBPGAU
1042 : DO 5044 ICOMP=1,NSTRS
1043 : MELVAL=IVAL(ICOMP)
1044 : IGMN=MIN(IGAU,VELCHE(/1))
1045 : IBMN=MIN(IB ,VELCHE(/2))
1046 : JC=JC+1
1047 : WORK(JC)=VELCHE(IGMN,IBMN)
1048 : 5044 CONTINUE
1049 : c
1050 : c appel a coque2 ksigma...
1051 : c
1052 : AN=NHRM
1052 : CALL CQ2KSG(XE,1.D0,DIM3,IFOUR,AN,NBPGAU,WORK(1),WORK(19),
1053 : 1 WORK(22),QSIGAU,POIGAU,WORK(25),WORK(30),
1054 : 2 WORK(35),WORK(42),WORK(49),WORK(113),WORK(177),
1055 : 3 WORK(241),WORK(305),LRE,REL)
1056 : c
1057 : c remplissage de xmatri
1058 : c
1058 : CALL REMPMT(REL,LRE,RE(1,1,ib))
1059 : c
1060 : 3044 CONTINUE
1061 : c
1062 : 9044 CONTINUE
1063 : SEGSUP,MWRK1,MWRK3,MWRK4
1064 : GOTO 510
1065 : c
1066 : c_______________________________________________________________________
1067 : c
1068 : c elements barre et cercle (et TIMO)
1069 : c_______________________________________________________________________
1070 : 46 CONTINUE
1071 : C Cas particulier :
1072 : IF (MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) GOTO 99
1073 : *
1074 : NBBB = NBNN
1075 : SEGINI MWRK1,MWRK3
1076 : c
1077 : DO 3046 IB=1,NBELEM
1078 : c
1079 : c on cherche les coordonnees des noeuds de l elementib
1080 : c
1080 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
1081 : c
1082 : c mise a zero de la raideur geometrique
1083 : c
1083 : CALL ZERO(REL,LRE,LRE)
1084 : c
1085 : c on cherche l'effort
1086 : c
1087 : MPTVAL=IVASTR
1088 : MELVAL=IVAL(1)
1089 : NBPTEL=VELCHE(/1)
1090 : IBMN=MIN(IB,VELCHE(/2))
1091 : c
1092 : IF (NBPTEL.EQ.1) THEN
1093 : EFFORT=VELCHE(1,IBMN)
1094 : ELSE IF (NBPTEL.EQ.2) THEN
1095 : EFF1=VELCHE(1,IBMN)
1096 : EFF2=VELCHE(2,IBMN)
1097 : EFFORT=0.5D0*(EFF1+EFF2)
1098 : ENDIF
1099 : c
1100 : c on calcule la rigidite geometrique
1101 : c
1102 : IF (MELE.EQ.46.or.MELE.eq.84)
1102 : & CALL BARKSG(REL,LRE,EFFORT,XE,KERRE)
1102 : IF (MELE.EQ.95) CALL CERKSG(REL,LRE,EFFORT,XE,KERRE)
1103 : IF (KERRE.NE.0) THEN
1104 : INTERR(1)=ISOUS
1105 : INTERR(2)=IB
1105 : CALL ERREUR(128)
1106 : GO TO 9046
1107 : ENDIF
1108 : c
1109 : c remplissage de xmatri
1110 : c
1111 : c cas particulier TIMO : on saute les ddls de rotation
1112 : IF (MELE.EQ.84) THEN
1113 : NCOMPU=NCOMP/2
1114 : ii=0
1115 : iii=0
1116 : DO 841 INOEUD=1,NBNNS
1117 : DO 842 ICOMP=1,NCOMP
1118 : ii=ii+1
1119 : if(ii.gt.NCOMPU) goto 842
1120 : iii=iii+1
1121 : jj=0
1122 : jjj=0
1123 : DO 843 JNOEUD=1,NBNNS
1124 : DO 844 JCOMP=1,NCOMP
1125 : jj=jj+1
1126 : if(jj.gt.ii) goto 842
1127 : if(jj.gt.NCOMPU) goto 844
1128 : jjj=jjj+1
1129 : RE(ii,jj,ib)=REL(iii,jjj)
1130 : RE(jj,ii,ib)=REL(iii,jjj)
1131 : 844 CONTINUE
1132 : 843 CONTINUE
1133 : 842 CONTINUE
1134 : 841 CONTINUE
1135 : ELSE
1135 : CALL REMPMT(REL,LRE,RE(1,1,ib))
1136 : ENDIF
1137 : *
1138 : 3046 CONTINUE
1139 :
1140 : 9046 CONTINUE
1141 : SEGSUP,MWRK1,MWRK3
1142 : GOTO 510
1143 :
1144 : c_______________________________________________________________________
1145 : c
1146 : c element coq4
1147 : c_______________________________________________________________________
1148 : 49 CONTINUE
1149 : NBBB=NBNN
1150 : NBNO=NBNN
1151 : SEGINI,MWRK1,MWRK2,MWRK4
1152 :
1153 : DO 3049 IB=1,NBELEM
1154 : c
1155 : c on cherche les coordonnees des noeuds de l element ib
1156 : c
1156 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
1157 :
1157 : CALL ZERO(REL,LRE,LRE)
1157 : CALL CQ4LOC(XE,XEL,BPSS,IRRT,0)
1158 : *
1159 : * attention : rien de prevu en cas d'excentrement
1160 : *
1160 : CALL BCOQ4(5,XEL,SHPTOT,SHPWRK,BGENE,DJAC,0.D0,0,IRRT,0)
1161 : c
1162 : MPTVAL=IVASTR
1163 : DO 5049 ICOMP=1,NSTRS
1164 : MELVAL=IVAL(ICOMP)
1165 : IGMN=MIN(5,VELCHE(/1))
1166 : IBMN=MIN(IB ,VELCHE(/2))
1167 : XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
1168 : 5049 CONTINUE
1169 : c
1169 : CALL CQ4KSG(DJAC,XSTRS,SHPWRK, REL)
1169 : CALL TRANSK(REL,BPSS,LRE,4,0)
1170 : c
1171 : c remplissage de xmatri
1172 : c
1172 : CALL REMPMT(REL,LRE,RE(1,1,ib))
1173 : *
1174 : 3049 CONTINUE
1175 :
1176 : 9049 CONTINUE
1177 : SEGSUP,MWRK1,MWRK2,MWRK4
1178 : GOTO 510
1179 :
1180 : c_______________________________________________________________________
1181 : c
1182 : c element cof3
1183 : c_______________________________________________________________________
1184 : c
1185 : 51 CONTINUE
1186 : c
1187 : NBBB=NBNN
1188 : SEGINI,MWRK1,MWRK3,MWRK4
1189 : c
1189 : CALL ERREUR(19)
1190 : GOTO 9051
1191 :
1192 : DO 3051 IB=1,NBELEM
1193 : c
1194 : c on cherche les coordonnees des noeuds de l element ib
1195 : c
1195 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
1196 :
1196 : CALL ZERO(REL,LRE,LRE)
1197 :
1198 : MPTVAL=IVACAR
1199 : MELVAL=IVAL(1)
1200 : IF (MELVAL.NE.0) THEN
1201 : IBMN=MIN(IB ,VELCHE(/2))
1202 : EPAI=VELCHE(1,IBMN)
1203 : ELSE
1204 : EPAI=0.D0
1205 : ENDIF
1206 : c
1207 : c on cherche les contraintes on les met dans work...
1208 : c
1209 : JC=0
1210 : MPTVAL=IVASTR
1211 : DO 5051 IGAU=1,NBPGAU
1212 : DO 5051 ICOMP=1,NSTRS
1213 : MELVAL=IVAL(ICOMP)
1214 : IGMN=MIN(IGAU,VELCHE(/1))
1215 : IBMN=MIN(IB ,VELCHE(/2))
1216 : JC=JC+1
1217 : WORK(JC)=VELCHE(IGMN,IBMN)
1218 : 5051 CONTINUE
1219 : c
1220 : c appel a coque2 ksigma...
1221 : c
1222 : AN=NHRM
1222 : * call cq3ksg(xe,epai,an,nbpgau,work(1),work(19),work(22),
1223 : * 1 work(25),work(30),work(35),work(42),work(49),
1224 : * 2 work(113),work(177),work(241),work(305),rel)
1225 : c
1226 : c remplissage de xmatri
1227 : c
1227 : CALL REMPMT(REL,LRE,RE(1,1,ib))
1228 : c
1229 : 3051 CONTINUE
1230 :
1231 : 9051 CONTINUE
1232 : SEGSUP MWRK1,MWRK3,MWRK4
1233 : GOTO 510
1234 :
1235 : c_______________________________________________________________________
1236 : c
1237 : c element shb8
1238 : c_______________________________________________________________________
1239 : 260 CONTINUE
1240 : NBBB=NBNN
1241 : SEGINI,MWRK1,MWRK7
1242 : * write(6,*) ' nbnn nbpgau nstrs lre' , nbnn,nbpgau,nstrs,lre
1243 :
1244 : DO 3260 IB=1,NBELEM
1245 : c
1246 : c on cherche les coordonnees des noeuds de l element ib
1247 : c
1247 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
1248 :
1249 : MPTVAL=IVASTR
1250 : IE=0
1251 : do 3268 igau=1,nbpgau
1252 : DO 3268 ICOMP=1,NSTRS
1253 : iE=IE+1
1254 : MELVAL=IVAL(ICOMP)
1255 : IGMN=MIN(IGAU,VELCHE(/1))
1256 : IBMN=MIN(IB ,VELCHE(/2))
1257 : work1(ie)=VELCHE(IGMN,IBMN)
1258 : * write(6,*)' xstrs(icomp)',icomp,XSTRS(ICOMP)
1259 : 3268 CONTINUE
1260 : propel(1)=0.
1260 : call shb8 (9,xe,D,propel,work1,rel,out)
1261 :
1262 : * remplissage de xmatri
1262 : CALL REMPMT(REL,LRE,RE(1,1,ib))
1263 : *
1264 : 3260 CONTINUE
1265 : c
1266 : 9260 CONTINUE
1267 : SEGSUP,MWRK1,MWRK7
1268 : GOTO 510
1269 :
1270 : c_______________________________________________________________________
1271 : c
1272 : c desactivation des segments propres a la zone geometrique isous
1273 : c_______________________________________________________________________
1274 : c
1275 : 510 CONTINUE
1276 : 597 CONTINUE
1277 : IF (ISUP1L.EQ.1 .OR. nblprt.GT.1) THEN
1277 : CALL DTMVAL(IVASTR,3)
1278 : ELSE
1278 : CALL DTMVAL(IVASTR,1)
1279 : ENDIF
1280 : IF (ISUP2L.EQ.1 .OR. nblprt.GT.1) THEN
1280 : CALL DTMVAL(IVACAR,3)
1281 : ELSE
1281 : CALL DTMVAL(IVACAR,1)
1282 : ENDIF
1283 : xmatri = ipmatr
1284 : SEGDES,xmatri
1285 : IF (NBLPRT.GT.1) THEN
1286 : meleme = ipmail
1287 : SEGDES,meleme
1288 : ENDIF
1289 : C- Sortie prematuree en cas d'erreur
1290 : IF (IERR.NE.0) GOTO 598
1291 :
1292 : C- Stockage de la matrice
1293 : nrigel=irigel(/2) +1
1294 : segadj,mrigid
1295 : * jrige = NRIGE0 + irige
1296 : jrige=nrigel
1297 : COERIG(jrige) = 1.
1298 : IRIGEL(1,jrige) = ipmail
1299 : IRIGEL(2,jrige) = 0
1300 : IRIGEL(3,jrige) = ipdesc
1301 : IRIGEL(4,jrige) = ipmatr
1302 : IRIGEL(5,jrige) = NIFOUR
1303 : IRIGEL(6,jrige) = 0
1304 : IRIGEL(7,jrige) = 0
1305 : IRIGEL(8,jrige) = 0
1306 :
1307 : ENDDO
1308 : C- Fin de la boucle sur les partitions
1309 : *
1310 : 598 CONTINUE
1311 : IF (MOSTRS.NE.0) THEN
1312 : nomid = MOSTRS
1313 : SEGDES,nomid
1314 : IF (lsupco) SEGSUP,nomid
1315 : notype = MOTYPS
1316 : SEGSUP,notype
1317 : ENDIF
1318 : IF (MOCARA.NE.0) THEN
1319 : NOMID = MOCARA
1320 : SEGSUP,NOMID
1321 : notype = MOTYPC
1322 : SEGSUP,notype
1323 : ENDIF
1324 : *
1325 : NOMID=MODEPL
1326 : SEGDES,NOMID
1327 : IF (lsupde) SEGSUP,NOMID
1328 : NOMID = MOFORC
1329 : SEGDES,NOMID
1330 : IF (lsupfo) SEGSUP,NOMID
1331 :
1332 : 599 CONTINUE
1333 : IF (IPMINT.NE.0) SEGDES,MINTE
1334 : SEGDES,IPT1
1335 : SEGDES,IMODEL
1336 :
1337 : IF (IERR.NE.0) GOTO 999
1338 : *
1339 : 500 CONTINUE
1340 : C* Fin de la boucle sur les modeles elementaires
1341 :
1342 : 999 CONTINUE
1343 : IF (IERR.NE.0) THEN
1343 : CALL DERIGI(MRIGID,-1,msorse)
1344 : SEGSUP,MRIGID
1345 : IPRIGG = 0
1346 : ELSE
1347 : if( irigel(/2).eq.0) then
1347 : call erreur (86)
1348 : return
1349 : endif
1350 : SEGDES,MRIGID
1351 : IPRIGG = MRIGID
1352 : ENDIF
1353 :
1354 : SEGDES,MMODEL
1355 :
1356 : RETURN
1357 : END
1358 :
1359 :
1360 :
1361 :
1362 :
© Cast3M 2003 - All rights reserved.
Disclaimer