1 : C PRINPO SOURCE PV 12/09/25 21:15:00 7514
2 : SUBROUTINE PRINPO(IPCHE1,MMM,IPCHE2,IPMODL,IPSTRS,IRET)
3 : C=======================================================================
4 : C
5 : C entr{es :
6 : C ========
7 : C
8 : C IPCHE1 =pointeur sur un MCHAML de CONTRAINTES ou de DEFORMATIONS
9 : C MMM =motcle pour les COQUES ( sortie sur la peau SUP INF OU MOYE)
10 : C IPCHE2 =pointeur sur un MCHAML de CARACTERISTIQUES
11 : C IPMODL =pointeur sur un MODELE
12 : C
13 : C sorties :
14 : C =======
15 : C
16 : C IPSTRS =pointeur sur un MCHAML de CONTRAINTES PRINCIPALES
17 : C IRET =1 OU 0 SUIVANT SUCCES OU PAS (MESSAGE D'ERREUR
18 : C imprim{ dans ce cas)
19 : C
20 : C Passage aux nouveaux Chamelem par S.RAMAHANDRY le 21/09/90
21 : C
22 : C=======================================================================
23 : IMPLICIT INTEGER(I-N)
24 : IMPLICIT REAL*8(A-H,O-Z)
25 : -INC CCOPTIO
26 : -INC CCHAMP
27 : -INC SMCHAML
28 : -INC SMINTE
29 : -INC SMMODEL
30 : -INC SMCOORD
31 : -INC SMELEME
32 : C
33 : SEGMENT MWRK1
34 : REAL*8 XEL(3,NBNN)
35 : ENDSEGMENT
36 : C
37 : SEGMENT MWRK2
38 : REAL*8 TXR(3,3,NBNN) ,TH(NBNN)
39 : ENDSEGMENT
40 : C
41 : SEGMENT NOTYPE
42 : CHARACTER*16 TYPE(NBTYPE)
43 : ENDSEGMENT
44 : C
45 : SEGMENT MPTVAL
46 : INTEGER IPOS(NS) ,NSOF(NS)
47 : INTEGER IVAL(NCOSOU)
48 : CHARACTER*16 TYVAL(NCOSOU)
49 : ENDSEGMENT
50 : C
51 : PARAMETER ( NINF=3 )
52 : INTEGER INFOS(NINF)
53 : C
54 : CHARACTER*4 MOTCLE(6),MMM
55 : CHARACTER*(NCONCH) CONM
56 : LOGICAL lsuppr,lsupno
57 : DIMENSION A(3,3),D(3),S(3,3),BPSS(3,3),SIG(9),V1(4)
58 : C
59 : DATA MOTCLE/'SUP ','MOYE','INF ','SUPE','INFE','TRID'/
60 : DATA XZER,UN/0.D0,1.D0/
61 : C
62 : IDIMM=IDIM
63 : XFLOT =XZER
64 : IF(MMM.EQ.MOTCLE(1)) XFLOT= UN
65 : IF(MMM.EQ.MOTCLE(4)) XFLOT= UN
66 : IF(MMM.EQ.MOTCLE(2)) XFLOT= XZER
67 : IF(MMM.EQ.MOTCLE(3)) XFLOT=-UN
68 : IF(MMM.EQ.MOTCLE(5)) XFLOT=-UN
69 : C
70 : LETRID=0
71 : IF(MMM.EQ.MOTCLE(6)) LETRID=1
72 :
73 : NHRM=NIFOUR
74 : *
75 : IRET = 0
76 : C
77 : ICONT=0
78 : IDEFO=0
79 : MCHELM=IPCHE1
80 : SEGACT MCHELM
81 : IF (TITCHE .EQ.'CONTRAINTES') ICONT = 1
82 : IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
83 : SEGDES MCHELM
84 : C
85 : C ERREUR IL FAUT UN CHAMELEM DE SOUS TYPE CONTRAINTES OU DEFORMATIONS
86 : C
87 : IF (ICONT.NE.1.AND.IDEFO.NE.1) THEN
88 : MOTERR(1:8)='CONTRAIN'
89 : MOTERR(9:16)='DEFORMAT'
89 : CALL ERREUR(109)
90 : RETURN
91 : ENDIF
92 : *
93 : * Verification du lieu support du MCHAML de contraintes
94 : *
94 : CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
95 : IF (ISUP1.GT.1) RETURN
96 : *
97 : * Verification du lieu support du MCHAML de caracteristiques
98 : *
99 : IF (IPCHE2.NE.0) THEN
99 : CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
100 : IF (ISUP2.GT.1) RETURN
101 : ENDIF
102 : C
103 : C ACTIVATION DU MODELE
104 : C
105 : MMODEL=IPMODL
106 : SEGACT MMODEL
107 : NSOUS=KMODEL(/1)
108 : C
109 : C CREATION DU MCHELM
110 : C
111 : N1=NSOUS
112 : L1=23
113 : N3=6
114 : SEGINI MCHELM
115 : TITCHE='CONTRAINTES PRINCIPALES'
116 : IFOCHE=IFOUR
117 : IPSTRS=MCHELM
118 : C____________________________________________________________________
119 : C
120 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
121 : C____________________________________________________________________
122 : C
123 : DO 500 ISOUS=1,NSOUS
124 : C
125 : IVECT=0
126 : IVACAR=0
127 : IVACOM=0
128 : NCARF=0
129 : NCARA=0
130 : NPRIN=0
131 : MOCARA=0
132 : MOCOMP=0
133 : MOSPRI=0
134 : C
135 : C ON RECUPERE L'INFORMATION GENERALE
136 : C
137 : IMODEL=KMODEL(ISOUS)
138 : SEGACT IMODEL
139 : IPMAIL=IMAMOD
140 : CONM =CONMOD
141 : C
142 : C COQUE INTEGREE OU PAS ?
143 : C
144 : IF(INFMOD(/1).NE.0)THEN
145 : NPINT=INFMOD(1)
146 : ELSE
147 : NPINT=0
148 : ENDIF
149 : c+mdj
150 : C IF (NPINT.NE.0)THEN
150 : C CALL ERREUR(615)
151 : C SEGDES IMODEL,MMODEL
152 : C SEGSUP MCHELM
153 : C RETURN
154 : C ENDIF
155 : c+mdj
156 : C
157 : IMACHE(ISOUS)=IPMAIL
158 : CONCHE(ISOUS)=CONMOD
159 : C
160 : C TRAITEMENT DU MODELE
161 : C
162 : MELE=NEFMOD
163 : MELEME=IMAMOD
164 : C____________________________________________________________________
165 : C
166 : C INFORMATION SUR L'ELEMENT FINI
167 : C____________________________________________________________________
168 : C
168 : * CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
169 : * IF (IERR.NE.0) THEN
170 : * SEGDES IMODEL,MMODEL
171 : * SEGSUP MCHELM
172 : * RETURN
173 : * ENDIF
174 : * INFO=IPINF
175 : MFR =INFELE(13)
176 : NBGS =INFELE(4)
177 : NSTRS=INFELE(16)
178 : * MINTE=INFELE(11)
179 : MINTE=INFMOD(7)
180 : IPMINT=MINTE
181 : MINTE1=INFMOD(8)
182 : * SEGSUP,INFO
183 : C
184 : C CREATION DU TABLEAU INFOS
185 : C
185 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
186 : IF (IRTD.EQ.0) GOTO 9990
187 : C
188 : INFCHE(ISOUS,1)=0
189 : INFCHE(ISOUS,2)=0
190 : INFCHE(ISOUS,3)=NHRM
191 : INFCHE(ISOUS,4)=MINTE
192 : INFCHE(ISOUS,5)=0
193 : INFCHE(ISOUS,6)=5
194 : C
195 : C INITIALISATION DE MINTE
196 : C
197 : SEGACT MINTE
198 : NBPGAU=POIGAU(/1)
199 : C
200 : C ACTIVATION DU MELEME
201 : C
202 : SEGACT MELEME
203 : NBNN =NUM(/1)
204 : NBELEM=NUM(/2)
205 : IPPORE=0
206 : IF(MFR.EQ.33) IPPORE=NBNN
207 :
208 : C____________________________________________________________________
209 : C
210 : C RECHERCHE DES NOMS DE COMPOSANTES
211 : C____________________________________________________________________
212 : C
213 : lsupno=.false.
214 : IF(ICONT.EQ.1) THEN
215 : if(lnomid(4).ne.0) then
216 : nomid=lnomid(4)
217 : segact nomid
218 : mocomp=nomid
219 : ncomp=lesobl(/2)
220 : nfac=lesfac(/2)
221 : else
222 : lsupno=.true.
222 : CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
223 : endif
224 : ELSE IF(IDEFO.EQ.1) THEN
225 : if(lnomid(5).ne.0) then
226 : nomid=lnomid(5)
227 : segact nomid
228 : ncomp=lesobl(/2)
229 : mocomp=nomid
230 : else
231 : lsupno=.true.
231 : CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
232 : endif
233 : ENDIF
234 : C
235 : if(lnomid(9).ne.0) then
236 : nomid=lnomid(9)
237 : segact nomid
238 : mospri=nomid
239 : nprin=lesobl(/2)
240 : nfac=lesfac(/2)
241 : lsuppr=.false.
242 : else
243 : lsuppr=.true.
243 : CALL IDPRIN(MFR,IFOUR,MOSPRI,NPRIN,NFAC)
244 : endif
245 : C
246 : C____________________________________________________________________
247 : C
248 : C VERIFICATION DE LEUR PRESENCE
249 : C____________________________________________________________________
250 : C
251 : NBTYPE=1
252 : SEGINI NOTYPE
253 : MOTYPE=NOTYPE
254 : TYPE(1)='REAL*8'
254 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
255 : 1 MOTYPE,1,INFOS,3,IVACOM)
256 : SEGSUP NOTYPE
257 : IF (IERR.NE.0) GOTO 9990
258 : IF (ISUP1.EQ.1) THEN
258 : CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE)
259 : ENDIF
260 : C
261 : C RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
262 : C
263 : N1PTEL=0
264 : N1EL=0
265 : MPTVAL=IVACOM
266 : DO 111 IO=1,NCOMP
267 : MELVAL=IVAL(IO)
268 : N1PTEL=MAX(N1PTEL,VELCHE(/1))
269 : 111 CONTINUE
270 : NBGCOM=N1PTEL
271 : C
272 : N1EL=NBELEM
273 : C
274 : C CREATION DU MCHAML DE LA SOUS ZONE
275 : C
276 : N2=NPRIN
277 : SEGINI MCHAML
278 : ICHAML(ISOUS)=MCHAML
279 : NS=1
280 : NCOSOU=NPRIN
281 : SEGINI MPTVAL
282 : IVAPRI=MPTVAL
283 : NOMID=MOSPRI
284 : SEGACT NOMID
285 : DO 100 ICOMP=1,NPRIN
286 : NOMCHE(ICOMP)=LESOBL(ICOMP)
287 : TYPCHE(ICOMP)='REAL*8'
288 : N2PTEL=0
289 : N2EL=0
290 : SEGINI MELVAL
291 : IELVAL(ICOMP)=MELVAL
292 : IVAL(ICOMP)=MELVAL
293 : 100 CONTINUE
294 : SEGDES NOMID
295 : C____________________________________________________________________
296 : C
297 : * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
298 : C____________________________________________________________________
299 : C
300 : NBROBL=0
301 : NBRFAC=0
302 : MOCARA=0
303 : *
304 : * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
305 : *
306 : IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
307 : NBROBL=1
308 : NBRFAC=1
309 : SEGINI NOMID
310 : MOCARA=NOMID
311 : LESOBL(1)='EPAI'
312 : LESFAC(1)='EXCE'
313 : *
314 : * CARACTERISTIQUES POUR LES LINESPRING
315 : *
316 : ELSE IF (MFR.EQ.15) THEN
317 : NBROBL=1
318 : SEGINI NOMID
319 : MOCARA=NOMID
320 : LESOBL(1)='EPAI'
321 : ENDIF
322 : C
323 : IF (MOCARA.NE.0) THEN
324 : IF (IPCHE2.NE.0) THEN
325 : NBTYPE=1
326 : SEGINI NOTYPE
327 : MOTYPE=NOTYPE
328 : TYPE(1)='REAL*8'
328 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
329 : 1 MOTYPE,1,INFOS,3,IVACAR)
330 : SEGSUP NOTYPE
331 : IF (IERR.NE.0) GOTO 9990
332 : IF (IVECT.EQ.1) THEN
333 : MPTVAL=IVACAR
334 : IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
335 : C
336 : C MOT CLE VECT EN CAS DE CONVERSION
337 : C
338 : IVECT=2
339 : NOMID=MOCARA
340 : SEGACT NOMID
341 : NBRFAC=NBRFAC+2
342 : SEGADJ NOMID
343 : MOCARA=NOMID
344 : LESFAC(NBRFAC-2)='VX '
345 : LESFAC(NBRFAC-1)='VY '
346 : LESFAC(NBRFAC) ='VZ '
347 : C
348 : NBTYPE=1
349 : SEGINI NOTYPE
350 : MOTYPE=NOTYPE
351 : TYPE(1)='REAL*8'
351 : CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
352 : 1 MOTYPE,1,INFOS,3,IVACAR)
353 : SEGSUP NOTYPE
354 : IF (IERR.NE.0) GOTO 9990
355 : ENDIF
356 : ENDIF
357 : ELSE
358 : MOTERR(1:8)='CARACTER'
358 : CALL ERREUR(145)
359 : GOTO 9990
360 : ENDIF
361 : ENDIF
362 : *
363 : NCARA=NBROBL
364 : NCARF=NBRFAC
365 : NCARR=NCARA+NCARF
366 : IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
366 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE)
367 : IF(IERR.NE.0)THEN
368 : ISUP2=0
369 : GOTO 9990
370 : ENDIF
371 : ENDIF
372 : C
373 : C=================================================================
374 : C MASSI COQUE COQEP POUT CIST THER TUYAU LISP
375 : GOTO (10,66,30,66,50,66,66,66,30,66,66,66,66,66,90),MFR
376 : C Cas particulier des elements InCompressibles (MFR=31)
377 : IF (MFR.EQ.31) GOTO 10
378 : c cas Xfem: identique au cas massif
379 : IF(MFR.EQ.63) goto 10
380 : c
381 : C=================================================================
382 : 66 CONTINUE
383 : MOTERR(1:8)=NOMFR(MFR)
383 : CALL ERREUR (194)
384 : GOTO 9990
385 : C____________________________________________________________________
386 : C
387 : C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
388 : C____________________________________________________________________
389 : C
390 : 10 CONTINUE
391 : C
392 : C REMPLISSAGE DU SEGMENT CONTENANT LES MATRICES(JACOBIEN)
393 : C
394 : IF (IDIM.EQ.1) THEN
395 : DO IB=1,NBELEM
396 : DO IGAU=1,NBPGAU
397 : MPTVAL=IVACOM
398 : MELVAL=IVAL(1)
399 : IGMN=MIN(IGAU,VELCHE(/1))
400 : IBMN=MIN(IB ,VELCHE(/2))
401 : SIG(1)=VELCHE(IGMN,IBMN)
402 : MELVAL=IVAL(2)
403 : IGMN=MIN(IGAU,VELCHE(/1))
404 : IBMN=MIN(IB ,VELCHE(/2))
405 : SIG(2)=VELCHE(IGMN,IBMN)
406 : MELVAL=IVAL(3)
407 : IGMN=MIN(IGAU,VELCHE(/1))
408 : IBMN=MIN(IB ,VELCHE(/2))
409 : SIG(3)=VELCHE(IGMN,IBMN)
409 : CALL ORDO01(SIG(1),3,.FALSE.)
410 : MPTVAL=IVAPRI
411 : MELVAL=IVAL(1)
412 : IGMN=MIN(IGAU,VELCHE(/1))
413 : IBMN=MIN(IB ,VELCHE(/2))
414 : VELCHE(IGMN,IBMN)=SIG(1)
415 : MELVAL=IVAL(2)
416 : IGMN=MIN(IGAU,VELCHE(/1))
417 : IBMN=MIN(IB ,VELCHE(/2))
418 : VELCHE(IGMN,IBMN)=SIG(2)
419 : MELVAL=IVAL(3)
420 : IGMN=MIN(IGAU,VELCHE(/1))
421 : IBMN=MIN(IB ,VELCHE(/2))
422 : VELCHE(IGMN,IBMN)=SIG(3)
423 : ENDDO
424 : ENDDO
425 : GOTO 110
426 : ENDIF
427 :
428 : C BOUCLE SUR LES ELEMENTS
429 : DO 1010 IB=1,NBELEM
430 : C
431 : C BOUCLE SUR LES POINTS DE GAUSS
432 : C
433 : DO 1010 IGAU=1,NBPGAU
434 : C
435 : MPTVAL=IVACOM
436 :
437 : MELVAL=IVAL(1)
438 : IGMN=MIN(IGAU,VELCHE(/1))
439 : IBMN=MIN(IB ,VELCHE(/2))
440 : A(1,1) = VELCHE(IGMN,IBMN)
441 : C
442 : MELVAL=IVAL(2)
443 : IGMN=MIN(IGAU,VELCHE(/1))
444 : IBMN=MIN(IB ,VELCHE(/2))
445 : A(2,2) = VELCHE(IGMN,IBMN)
446 : C
447 : MELVAL=IVAL(3)
448 : IGMN=MIN(IGAU,VELCHE(/1))
449 : IBMN=MIN(IB ,VELCHE(/2))
450 : A(3,3) = VELCHE(IGMN,IBMN)
451 : C
452 : MELVAL=IVAL(4)
453 : IGMN=MIN(IGAU,VELCHE(/1))
454 : IBMN=MIN(IB ,VELCHE(/2))
455 : A(1,2) = VELCHE(IGMN,IBMN)
456 : A(2,1) = A(1,2)
457 : C
458 : IF(IFOUR.LT.1.AND.IFOUR.GE.-3) THEN
459 : IF(LETRID.EQ.1) THEN
460 : IDIMM = 3
461 : A(1,3)=0.
462 : A(2,3)=0.
463 : ENDIF
464 : GO TO 6610
465 : ENDIF
466 : C
467 : IF(IFOUR.EQ.1) IDIMM=3
468 : MELVAL=IVAL(5)
469 : IGMN=MIN(IGAU,VELCHE(/1))
470 : IBMN=MIN(IB ,VELCHE(/2))
471 : A(3,1) = VELCHE(IGMN,IBMN)
472 : C
473 : MELVAL=IVAL(6)
474 : IGMN=MIN(IGAU,VELCHE(/1))
475 : IBMN=MIN(IB ,VELCHE(/2))
476 : A(3,2) = VELCHE(IGMN,IBMN)
477 : A(1,3) = A(3,1)
478 : A(2,3) = A(3,2)
479 : C
480 : 6610 CONTINUE
481 : C
482 : C REMPLISSAGE DU SEGMENT CONTENANT LES VALEURS ET VECTEURS PROPRES
483 : C
483 : CALL JACOB3(A,IDIMM,D,S)
484 : C
485 : MPTVAL=IVAPRI
486 : C
487 : DO 2010 ID = 1,3
488 : MELVAL=IVAL(ID)
489 : IGMN=MIN(IGAU,VELCHE(/1))
490 : IBMN=MIN(IB ,VELCHE(/2))
491 : VELCHE(IGMN,IBMN) = D(ID)
492 : C
493 : MELVAL=IVAL(ID+3)
494 : IGMN=MIN(IGAU,VELCHE(/1))
495 : IBMN=MIN(IB ,VELCHE(/2))
496 : VELCHE(IGMN,IBMN) = S(ID,1)
497 : C
498 : MELVAL=IVAL(ID+6)
499 : IGMN=MIN(IGAU,VELCHE(/1))
500 : IBMN=MIN(IB ,VELCHE(/2))
501 : VELCHE(IGMN,IBMN) = S(ID,2)
502 : C
503 : MELVAL=IVAL(ID+9)
504 : IGMN=MIN(IGAU,VELCHE(/1))
505 : IBMN=MIN(IB ,VELCHE(/2))
506 : VELCHE(IGMN,IBMN) = S(ID,3)
507 : C
508 : 2010 CONTINUE
509 : C
510 : 1010 CONTINUE
511 : C
512 : GOTO 110
513 : 30 CONTINUE
514 : C____________________________________________________________________
515 : C
516 : C FORMULATION COQUE
517 : C____________________________________________________________________
518 : C
519 : SEGINI MWRK1
520 : C
521 : C BOUCLE SUR LES ELEMENTS
522 : DO 1030 IB=1,NBELEM
523 : C
524 : C BOUCLE SUR LES POINTS DE GAUSS
525 : C
526 : DO 1030 IGAU=1,NBPGAU
527 : C
527 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
528 : IF(IDIM.EQ.3) THEN
528 : CALL VPAST(XEL,BPSS)
529 : ELSE IF(IDIM.EQ.2) THEN
529 : CALL VPAST2(XEL,BPSS)
530 : ENDIF
530 : CALL TRPOSE(BPSS)
531 : C
532 : C REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES ET
533 : C CALCUL DES CONTRAINTES
534 : C
535 : MPTVAL=IVACOM
536 : C
537 : DO 130 ID = 1,NSTRS
538 : MELVAL=IVAL(ID)
539 : IGMN=MIN(IGAU,VELCHE(/1))
540 : IBMN=MIN(IB ,VELCHE(/2))
541 : SIG(ID) = VELCHE(IGMN,IBMN)
542 : 130 CONTINUE
543 : C
544 : MPTVAL=IVACAR
545 : C
546 : MELVAL=IVAL(1)
547 : EPAIST = VELCHE(1,1)
548 : C
549 : MELVAL=IVAL(2)
550 : IF (IVAL(2).NE.0) THEN
551 : EXCEN = VELCHE(1,1)
552 : ELSE
553 : EXCEN =0.D0
554 : ENDIF
555 : C
556 : c+mdj
557 : IF(NPINT.NE.0) THEN
557 : CALL PRINC(SIG,V1,NSTRS)
558 : MPTVAL=IVAPRI
559 : DO 161 ID = 1,4
560 : MELVAL=IVAL(ID)
561 : IGMN=MIN(IGAU,VELCHE(/1))
562 : IBMN=MIN(IB ,VELCHE(/2))
563 : VELCHE(IGMN,IBMN) = V1(ID)
564 : 161 CONTINUE
565 : GOTO 1130
566 : ENDIF
567 : c+mdj
568 : C
568 : CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
569 : C
570 : IF(IFOUR.GT.0) THEN
571 : C
572 : A(1,1) = SIG(1) + XFLOT*SIG(4)
573 : A(2,2) = SIG(2) + XFLOT*SIG(5)
574 : A(1,2) = SIG(3) + XFLOT*SIG(6)
575 : A(2,1) = A(1,2)
576 : ELSE IF(IFOUR.LE.0) THEN
577 : A(1,1) = SIG(1) + XFLOT*SIG(3)
578 : A(2,2) = SIG(2) + XFLOT*SIG(4)
579 : A(1,2) = 0.D0
580 : A(2,1) = 0.D0
581 : ENDIF
582 : C
582 : CALL JACOB3(A,2,D,S)
582 : CALL MULMAT(A,BPSS,S,3,3,3)
583 : C
584 : MPTVAL=IVAPRI
585 : C
586 : DO 61 ID = 1,2
587 : MELVAL=IVAL(ID)
588 : IGMN=MIN(IGAU,VELCHE(/1))
589 : IBMN=MIN(IB ,VELCHE(/2))
590 : VELCHE(IGMN,IBMN) = D(ID)
591 : 61 CONTINUE
592 : C
593 : DO 2030 ID = 1,3
594 : MELVAL=IVAL(ID+2)
595 : IGMN=MIN(IGAU,VELCHE(/1))
596 : IBMN=MIN(IB ,VELCHE(/2))
597 : VELCHE(IGMN,IBMN)= A(ID,1)
598 : C
599 : MELVAL=IVAL(ID+5)
600 : IGMN=MIN(IGAU,VELCHE(/1))
601 : IBMN=MIN(IB ,VELCHE(/2))
602 : VELCHE(IGMN,IBMN)= A(ID,2)
603 : C
604 : 2030 CONTINUE
605 : 1130 CONTINUE
606 : 1030 CONTINUE
607 : GOTO 110
608 : 50 CONTINUE
609 : C
610 : C FORMULATION COQUE EPAISSE PLUS COMPLIQUE CAR IL FAUT
611 : C RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
612 : C
613 : C PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
614 : C
615 : SEGACT MINTE1
616 : SEGINI MWRK1,MWRK2
617 : N1PTEL=NBGS
618 : C
619 : DO 1052 IB = 1,NBNN
620 : TH(IB)=UN
621 : 1052 CONTINUE
622 :
623 : C BOUCLE SUR LES ELEMENTS
624 : DO 1050 IB=1,NBELEM
625 : C
626 : C BOUCLE SUR LES POINTS DE GAUSS
627 : C
628 : DO 1050 IGAU=1,NBPGAU
629 :
630 : C
630 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
630 : CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
631 : C
632 : DO 1050 IC=1,NBGS
633 : E=DZEGAU(IC)
634 : C
634 : CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
635 : C
636 : MPTVAL=IVACOM
637 : C
638 : MELVAL=IVAL(1)
639 : IGMN=MIN(IGAU,VELCHE(/1))
640 : IBMN=MIN(IB ,VELCHE(/2))
641 : A(1,1) = VELCHE(IGMN,IBMN)
642 : C
643 : MELVAL=IVAL(2)
644 : IGMN=MIN(IGAU,VELCHE(/1))
645 : IBMN=MIN(IB ,VELCHE(/2))
646 : A(2,2) = VELCHE(IGMN,IBMN)
647 : C
648 : MELVAL=IVAL(3)
649 : IGMN=MIN(IGAU,VELCHE(/1))
650 : IBMN=MIN(IB ,VELCHE(/2))
651 : A(1,2) = VELCHE(IGMN,IBMN)
652 : A(2,1) = A(1,2)
653 : C
653 : CALL JACOB3(A,2,D,S)
653 : CALL MULMAT(A,BPSS,S,3,3,3)
654 : C
655 : MPTVAL=IVAPRI
656 : C
657 : MELVAL=IVAL(1)
658 : IGMN=MIN(IGAU,VELCHE(/1))
659 : IBMN=MIN(IB ,VELCHE(/2))
660 : VELCHE(IGMN,IBMN) = D(1)
661 : C
662 : MELVAL=IVAL(2)
663 : IGMN=MIN(IGAU,VELCHE(/1))
664 : IBMN=MIN(IB ,VELCHE(/2))
665 : VELCHE(IGMN,IBMN)= D(2)
666 : C
667 : DO 2050 ID = 1,3
668 : C
669 : MELVAL=IVAL(ID+2)
670 : IGMN=MIN(IGAU,VELCHE(/1))
671 : IBMN=MIN(IB ,VELCHE(/2))
672 : VELCHE(IGMN,IBMN)= A(ID,1)
673 : C
674 : MELVAL=IVAL(ID+5)
675 : IGMN=MIN(IGAU,VELCHE(/1))
676 : IBMN=MIN(IB ,VELCHE(/2))
677 : VELCHE(IGMN,IBMN)= A(ID,2)
678 : C
679 : 2050 CONTINUE
680 : 1050 CONTINUE
681 : C
682 : SEGDES MINTE1
683 : SEGSUP MWRK1,MWRK2
684 : C
685 : GOTO 110
686 : 90 CONTINUE
687 : C
688 : C CAS LINESPRING
689 : C
690 : C BOUCLE SUR LES ELEMENTS
691 : DO 1090 IB=1,NBELEM
692 : C
693 : C BOUCLE SUR LES POINTS DE GAUSS
694 : C
695 : DO 1090 IGAU=1,NBPGAU
696 :
697 : MPTVAL=IVACAR
698 : C
699 : MELVAL=IVAL(1)
700 : IGMN=MIN(IGAU,VELCHE(/1))
701 : IBMN=MIN(IB ,VELCHE(/2))
702 : EP = VELCHE(IGMN,IBMN)
703 : EP2 = EP*EP/6.D0
704 : C
705 : MPTVAL=IVACOM
706 : C
707 : MELVAL=IVAL(1)
708 : IGMN=MIN(IGAU,VELCHE(/1))
709 : IBMN=MIN(IB ,VELCHE(/2))
710 : AUX1 = VELCHE(IGMN,IBMN)
711 : C
712 : MELVAL=IVAL(4)
713 : IGMN=MIN(IGAU,VELCHE(/1))
714 : IBMN=MIN(IB ,VELCHE(/2))
715 : AUX2 = VELCHE(IGMN,IBMN)
716 : C
717 : MPTVAL=IVAPRI
718 : C
719 : MELVAL=IVAL(1)
720 : IGMN=MIN(IGAU,VELCHE(/1))
721 : IBMN=MIN(IB ,VELCHE(/2))
722 : VELCHE(IGMN,IBMN)=AUX1/EP + XFLOT * AUX2/EP2
723 : 1090 CONTINUE
724 : GOTO 110
725 : C
726 : C____________________________________________________________________
727 : C
728 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
729 : C____________________________________________________________________
730 : C
731 : 110 CONTINUE
732 : SEGDES MINTE
733 : SEGDES MELEME
734 : SEGDES IMODEL
735 : SEGDES MCHAML
736 : *
737 : IF(ISUP1.EQ.1)THEN
737 : CALL DTMVAL(IVACOM,3)
738 : ELSE
738 : CALL DTMVAL(IVACOM,1)
739 : ENDIF
740 : *
741 : IF(ISUP2.EQ.1)THEN
741 : CALL DTMVAL(IVACAR,3)
742 : ELSE
742 : CALL DTMVAL(IVACAR,1)
743 : ENDIF
744 : *
744 : CALL DTMVAL(IVAPRI,1)
745 : *
746 : NOMID=MOCARA
747 : IF (MOCARA.NE.0) SEGSUP NOMID
748 : NOMID=MOCOMP
749 : if(lsupno)SEGSUP NOMID
750 : NOMID=MOSPRI
751 : if(lsuppr)SEGSUP NOMID
752 : *
753 : 500 CONTINUE
754 : *
755 : SEGDES MMODEL
756 : MCHELM=IPCHE1
757 : ** write (6,*) ' mchelm desactive dans prinpo ',mchelm
758 : SEGDES MCHELM
759 : MCHELM=IPSTRS
760 : ** write (6,*) ' ipstrs desactive dans prinpo ',ipstrs
761 : SEGDES MCHELM
762 : IRET = 1
763 : RETURN
764 : *
765 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
766 : *
767 : 9990 CONTINUE
768 : IRET = 0
769 : *
770 : IF(ISUP1.EQ.1)THEN
770 : CALL DTMVAL(IVACOM,3)
771 : ELSE
771 : CALL DTMVAL(IVACOM,1)
772 : ENDIF
773 : *
774 : IF(ISUP2.EQ.1)THEN
774 : CALL DTMVAL(IVACAR,3)
775 : ELSE
775 : CALL DTMVAL(IVACAR,1)
776 : ENDIF
777 : *
777 : CALL DTMVAL(IVAPRI,3)
778 : *
779 : NOMID=MOCARA
780 : IF (MOCARA.NE.0) SEGSUP NOMID
781 : NOMID=MOCOMP
782 : if(lsupno)SEGSUP NOMID
783 : NOMID=MOSPRI
784 : if(lsuppr)SEGSUP NOMID
785 : *
786 : SEGDES MINTE
787 : SEGDES MELEME
788 : SEGDES IMODEL
789 : SEGSUP MCHAML
790 : *
791 : SEGDES MMODEL
792 : SEGSUP MCHELM
793 :
794 : RETURN
795 : END
796 :
797 :
798 :
799 :
© Cast3M 2003 - All rights reserved.
Disclaimer