1 : C KPRES SOURCE BP208322 14/02/17 21:15:07 7960
2 : SUBROUTINE KPRES(IPMODL,IPCHPO,ICHA,ICONV,IFLAM,IASYM,IPRIG,IRET)
3 : C_______________________________________________________________________
4 : C
5 : C
6 : C 99
7 : C Entr{es:
8 : C ________
9 : C
10 : C IPMODL Pointeur sur un MMODEL
11 : C IPCHPO Pointeur sur un MCHAML ou CHPOINT de PRESSION
12 : C
13 : C ICHA Flag : =1 IPCHPO est un pointeur sur un MCHAML
14 : C =0 IPCHPO est un pointeur sur un CHPOINT
15 : C
16 : C ICONV Flag de conversion
17 : C IFLAM Flag de flambage
18 : C
19 : C Sorties:
20 : C ________
21 : C
22 : C IPRIG Pointeur sur un objet RIGIDITE
23 : C IRET Flag de retour
24 : C
25 : C CODE COMBESCURE JANV 87
26 : C
27 : C Passage aux nouveaux CHAMELEMs par P.DOWLATYARI le 5/04/91
28 : C
29 : C
30 : C_______________________________________________________________________
31 : C
32 : IMPLICIT INTEGER(I-N)
33 : IMPLICIT REAL*8(A-H,O-Z)
34 : *
35 : -INC CCHAMP
36 : -INC CCOPTIO
37 : -INC SMRIGID
38 : -INC SMCHAML
39 : -INC SMELEME
40 : -INC SMCOORD
41 : -INC SMINTE
42 : -INC SMMODEL
43 : -INC SMCHPOI
44 : C
45 : SEGMENT WRK1
46 : REAL*8 REL(LRE,LRE) ,XE(3,NBBB)
47 : ENDSEGMENT
48 : *
49 : SEGMENT WRK2
50 : REAL*8 SHPWRK(6,NBNO)
51 : ENDSEGMENT
52 : *
53 : SEGMENT WRK3
54 : REAL*8 WORK(LW)
55 : ENDSEGMENT
56 : *
57 : SEGMENT WRK4
58 : REAL*8 BPSS(3,3) ,XEL(3,NBBB)
59 : ENDSEGMENT
60 : segment wrk7
61 : real*8 propel(2),d(1),work1(1),out(1)
62 : endsegment
63 : segment icpr (xcoor(/1)/(idim+1))
64 : *
65 : SEGMENT MPTVAL
66 : INTEGER IPOS(NS) ,NSOF(NS)
67 : INTEGER IVAL(NCOSOU)
68 : CHARACTER*16 TYVAL(NCOSOU)
69 : ENDSEGMENT
70 : *
71 : PARAMETER ( NINF=3 )
72 : INTEGER INFOS(NINF)
73 : LOGICAL lsupfo,lsupdp
74 : *
75 : IRET=1
76 : IVAPR=0
77 : *
78 : * CHPOINT DE PRESSION ---> CHAMELEM AUX NOEUDS
79 : *
80 : IF(ICHA.EQ.0)THEN
80 : CALL CHAME1(0,IPMODL,IPCHPO,' ',IPCHE1,1)
81 : IF (IERR.NE.0) RETURN
82 : ELSE
83 : IPCHE1=IPCHPO
84 : ENDIF
85 : MCHEL1=IPCHE1
86 : SEGACT,MCHEL1
87 : NBMAIC=MCHEL1.IMACHE(/1)
88 : C_______________________________________________________________________
89 : C
90 : C ACTIVATION DU MODELE
91 : C_______________________________________________________________________
92 : C
93 : MMODEL=IPMODL
94 : SEGACT MMODEL
95 : NSOUS=KMODEL(/1)
96 : *
97 : * verif si element shb8 d'avoir recu un chpoint de pression
98 : *
99 : if(icha.eq.1) then
100 : nsous=kmodel(/1)
101 : do io=1,nsous
102 : imodel=kmodel(io)
103 : segact imodel
104 : if(nefmod.eq.260) then
104 : call erreur(1007)
105 : return
106 : endif
107 : enddo
108 : endif
109 : C
110 : C
111 : C INITIALISATION DU CHAPEAU DE L OBJET RIGIDITE
112 : C
113 : NRIGE=7
114 : NRIGEL=NSOUS
115 : SEGINI MRIGID
116 : IPRIG=MRIGID
117 : ICHOLE=0
118 : IMGEO1=0
119 : IMGEO2=0
120 : IFORIG=IFOMOD
121 : IF (IFLAM.NE.0) THEN
122 : MTYMAT='MASSE'
123 : ELSE
124 : MTYMAT='RIGIDITE'
125 : ENDIF
126 : C
127 : DO 140 ISOUS=1,NSOUS
128 : IRIGEL(4,ISOUS)=0
129 : COERIG(ISOUS)=1.D0
130 : 140 CONTINUE
131 : C_______________________________________________________________________
132 : C
133 : C BOUCLE SUR LES SOUS ZONES DU MAILLAGE
134 : C_______________________________________________________________________
135 : C
136 : DO 500 ISOUS=1,NSOUS
137 : C
138 : C TRAITEMENT DU MODELE
139 : C
140 : IMODEL=KMODEL(ISOUS)
141 : SEGACT IMODEL
142 : MELE=NEFMOD
143 : IPMAIL=IMAMOD
144 : C_______________________________________________________________________
145 : C
146 : * INFOS. ELEMENT FINI *
147 : C_______________________________________________________________________
148 : C
148 : * CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
149 : IF ( IERR.NE.0 ) THEN
150 : SEGDES IMODEL,MMODEL
151 : SEGDES MCHEL1
151 : IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
152 : SEGSUP MRIGID
153 : IRET=0
154 : RETURN
155 : ENDIF
156 : * INFO=IPINF
157 : LHOOK = INFELE(10)
158 : LHOO2 = LHOOK*LHOOK
159 : NSTRS = INFELE(16)
160 : MFR = INFELE(13)
161 : LW = INFELE(7)
162 : IF(MELE.EQ.28)LW=600
163 : NDDL = INFELE(15)
164 : LRE = INFELE(9)
165 : IPORE = INFELE(8)
166 : LVAL = (LRE*(LRE+1))/2
167 : NHRM = NIFOUR
168 : C
169 : C CREATION DU TABLEAU INFOS
170 : C
171 : INFOS(1)=0
172 : INFOS(2)=0
173 : INFOS(3)=NIFOUR
174 : C_______________________________________________________________________
175 : C
176 : * INFOS. MAILLAGE *
177 : C_______________________________________________________________________
178 : C
179 : MELEME=IPMAIL
180 : SEGACT MELEME
181 : NBNN=NUM(/1)
182 : NBELEM=NUM(/2)
183 : C_______________________________________________________________________
184 : C
185 : * SEGMENTS D'INTEGRATION *
186 : C_______________________________________________________________________
187 : C
188 : * Minte : 1er segment d'integration, il existe pour tous les e.f.
189 : * Minte1: 2eme segment d'integration, uniquement pour certains e.f.
190 : * en particulier pour Coq6 et Coq8
191 : * nbpg:nb de points de gauss = nbpgau du segment minte
192 : * iele:no d'element geometrique associe a l'e.f. mele
193 : * nbff:nb de fonctions de forme = nbno du segment minte
194 : *
195 : NBPGAU= INFELE( 6)
196 : IELE = INFELE( 14)
197 : ICARA = INFELE( 5)
198 : * MINTE = INFELE(11)
199 : MINTE=INFMOD(5)
200 : MINTE1= INFMOD(8)
201 : if(mele.ne.260)SEGACT MINTE
202 : *
203 : C_______________________________________________________________________
204 : C
205 : * INITIALISATION DU SEGMENT DESCR, SEGMENT DESCRIPTEUR DES *
206 : * DES INCONNUES RELATIVES A LA MATRICE DE RIGIDITE *
207 : C_______________________________________________________________________
208 : C
209 : NLIGRP = INFELE(9)
210 : NLIGRD = INFELE(9)
211 : SEGINI DESCR
212 : IPDESC=DESCR
213 : if(lnomid(1).ne.0) then
214 : nomid=lnomid(1)
215 : segact nomid
216 : modepl=nomid
217 : ndepl=lesobl(/2)
218 : ndum=lesfac(/2)
219 : lsupdp=.false.
220 : else
221 : lsupdp=.true.
221 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,NDUM)
222 : endif
223 : if(lnomid(2).ne.0) then
224 : nomid=lnomid(2)
225 : segact nomid
226 : moforc=nomid
227 : nforc=lesobl(/2)
228 : lsupfo=.false.
229 : else
230 : lsupfo=.true.
230 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM)
231 : endif
232 : *
233 : IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
233 : CALL ERREUR(5)
234 :
235 : SEGSUP DESCR,MRIGID
236 : SEGDES MCHEL1
236 : IF(ICHA.EQ.0)CALL DTCHAM(IPCHE1)
237 : SEGDES MMODEL,MELEME,MINTE
238 : SEGDES IMODEL
239 : IRET=0
240 : RETURN
241 : ENDIF
242 : *
243 : * REMPLISSAGE DU SEGMENT DESCRIPTEUR
244 : *
245 : IDDL=1
246 : NCOMP=NDEPL
247 : NBNNS=NBNN
248 : NOMID=MODEPL
249 : SEGACT NOMID
250 : NOMID=MOFORC
251 : SEGACT NOMID
252 : IF (MFR.EQ.33) NCOMP=NDEPL-1
253 : IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS=NBNN/2
254 : DO 1004 INOEUD=1,NBNNS
255 : DO 1005 ICOMP=1,NCOMP
256 : NOMID=MODEPL
257 : LISINC(IDDL)=LESOBL(ICOMP)
258 : NOMID=MOFORC
259 : LISDUA(IDDL)=LESOBL(ICOMP)
260 : NOELEP(IDDL)=INOEUD
261 : NOELED(IDDL)=INOEUD
262 : IDDL=IDDL+1
263 : 1005 CONTINUE
264 : 1004 CONTINUE
265 : NOMID=MODEPL
266 : if(lsupdp)SEGSUP NOMID
267 : NOMID=MOFORC
268 : if(lsupfo)SEGSUP NOMID
269 : *
270 : * CAS DES MILIEUX POREUX
271 : *
272 : * IF (MFR.EQ.33) THEN
273 : * DO 1104 INOEUD=1,NBSOM(IELE)
274 : * NOMID=MODEPL
275 : * LISINC(IDDL)=LESOBL(NDEPL)
276 : * NOMID=MOFORC
277 : * LISDUA(IDDL)=LESOBL(NDEPL)
278 : * NOELEP(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
279 : * NOELED(IDDL)=IBSOM(NSPOS(IELE)+INOEUD-1)
280 : * IDDL=IDDL+1
281 : *1104 CONTINUE
282 : * ENDIF
283 : *
284 : * CAS DES ELEMENT RACCORD
285 : *
286 : IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
286 : CALL IDDEPL(MFR+1000,IFOUR,MODEPL,NDEPL,NDUM)
286 : CALL IDFORC(MFR+1000,IFOUR,MOFORC,NFORC,NDUM)
287 : DO 1106 INOEUD=NBNNS+1,NBNN
288 :
289 : DO 1107 ICOMP=1,NDEPL
290 : NOMID=MODEPL
291 : LISINC(IDDL)=LESOBL(ICOMP)
292 : NOMID=MOFORC
293 : LISDUA(IDDL)=LESOBL(ICOMP)
294 : NOELEP(IDDL)=INOEUD
295 : NOELED(IDDL)=INOEUD
296 : IDDL=IDDL+1
297 : 1107 CONTINUE
298 : 1106 CONTINUE
299 : NOMID=MODEPL
300 : SEGSUP NOMID
301 : NOMID=MOFORC
302 : SEGSUP NOMID
303 : ENDIF
304 :
305 : SEGDES DESCR
306 : *
307 : C_______________________________________________________________________
308 : C
309 : * INITIALISATION DU SEGMENT IMATRI, *
310 : * CONTENANT LES MATRICES DE RIGIDITE ELEMENTAIRES *
311 : C_______________________________________________________________________
312 : C
313 : * NBELEM: NB D'ELEMENTS DANS LA SOUS ZONE
314 : NELRIG = NBELEM
315 : SEGINI xMATRI
316 : *
317 : C_______________________________________________________________________
318 : C
319 : * TRAITEMENT DU CHAPEAU DES RIGIDITES, SEGMENT MRIGID *
320 : C_______________________________________________________________________
321 : C
322 : *
323 : IRIGEL(1,ISOUS)=IPMAIL
324 : IRIGEL(2,ISOUS)=0
325 : IRIGEL(3,ISOUS)=IPDESC
326 : IRIGEL(4,ISOUS)=xMATRI
327 : IRIGEL(5,ISOUS)=NIFOUR
328 : IF (IASYM .EQ. 0) THEN
329 : IRIGEL(7, ISOUS) = 0
330 : ELSE
331 : IRIGEL(7, ISOUS) = 2
332 : ENDIF
333 : *
334 : C_______________________________________________________________________
335 : C
336 : * VALEURS DE PRESSION *
337 :
338 : C_______________________________________________________________________
339 : C
339 : CALL PLACE2(MCHEL1.IMACHE,NBMAIC,IM,IPMAIL)
340 : MCHAM1=MCHEL1.ICHAML(IM)
341 : SEGACT MCHAM1
342 : IVAPR=MCHAM1.IELVAL(1)
343 : SEGDES MCHAM1
344 : MELVAL=IVAPR
345 : IF(IVAPR.NE.0)SEGACT MELVAL
346 : *
347 : C=======================================================================
348 : C NUMERO DES ETIQUETTES :
349 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
350 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
351 : C 5 CONTINUE
352 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
353 : C 44 CONTINUE
354 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
355 : C=======================================================================
356 :
357 : GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
358 : 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99,
359 : 2 41,99,99,44,99,99,99,99,49,99,99,99,99,99,99,56,99,99,99,99,
360 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
361 : 4 99,99,99,99,99,99,99,99,99,99,99,99,28,99,99,99,99),MELE
362 : C
363 :
364 : if(mele.eq.260) go to 1260
365 : GOTO 99
366 : 27 CONTINUE
367 : C
368 : C ELEMENT COQ3
369 : C
370 : NBBB=NBNN
371 : SEGINI WRK1,WRK3,WRK4
372 : DO 3027 IB=1,NBELEM
373 : C
374 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
375 : C
375 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
375 : CALL ZERO(REL,LRE,LRE)
376 : C
377 : C ON CHERCHE LES PRESSIONS
378 : C
379 : PRESS=0.D0
380 : IF(MELVAL.NE.0)THEN
381 : IBMN=MIN(IB ,VELCHE(/2))
382 : DO 4027 IGAU=1,NBNN
383 : IGMN=MIN(IGAU,VELCHE(/1))
384 : PRESS=PRESS+VELCHE(IGMN,IBMN)
385 : 4027 CONTINUE
386 : PRESS=PRESS/NBNN
387 : ENDIF
388 : C
389 : C ON CALCULE K(P)
390 : C
391 : * SEGINI XMATRI
391 : CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
392 : * SEGINI XMATRI
393 : * IMATTT(IB)=XMATRI
394 : C
395 : C REMPLISSAGE DE XMATRI
396 : C
396 : * CALL REMPMC(REL,LRE,RE(1,1,ib))
397 : * SEGDES XMATRI
398 : 3027 CONTINUE
399 : SEGDES xMATRI
400 : SEGSUP WRK1,WRK3,WRK4
401 : GOTO 510
402 : C
403 : C ELEMENT DKT POUR L INSTANT = COQ3
404 : C
405 : 28 CONTINUE
406 : NBBB=NBNN
407 : SEGINI WRK1,WRK3,WRK4
408 : DO 3028 IB=1,NBELEM
409 : C
410 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
411 : C
411 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
412 : C
412 : CALL ZERO(REL,LRE,LRE)
413 : C
414 : C ON CHERCHE LES PRESSIONS
415 : C
416 : PRESS=0.D0
417 : IF(MELVAL.NE.0)THEN
418 : IBMN=MIN(IB ,VELCHE(/2))
419 : DO 4028 IGAU=1,NBNN
420 : IGMN=MIN(IGAU,VELCHE(/1))
421 : PRESS=PRESS+VELCHE(IGMN,IBMN)
422 : 4028 CONTINUE
423 : PRESS=PRESS/NBNN
424 : ENDIF
425 : C
426 : C ON CALCULE K(P)
427 : C
428 : * SEGINI XMATRI
428 : CALL KPCOQ3(XE,PRESS,RE(1,1,ib),IASYM)
429 : * SEGINI XMATRI
430 : * IMATTT(IB)=XMATRI
431 : C
432 : C REMPLISSAGE DE XMATRI
433 : C
433 : * CALL REMPMC(REL,LRE,RE)
434 : * SEGDES XMATRI
435 : 3028 CONTINUE
436 : SEGDES xMATRI
437 : SEGSUP WRK1,WRK3,WRK4
438 : GOTO 510
439 : C
440 : C ELEMENT COQ8 NON ENCORE BRANCHE
441 : C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
442 : C
443 : 41 CONTINUE
444 : NBBB=NBNN
445 : SEGINI WRK1,WRK3
446 : DO 3041 IB=1,NBELEM
447 : C
448 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
449 : C
449 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
450 : C
450 : CALL ZERO(REL,LRE,LRE)
451 : C
452 : C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
453 : C
454 : PRESS=0.D0
455 : IF(MELVAL.NE.0)THEN
456 : IBMN=MIN(IB ,VELCHE(/2))
457 : DO 4041 IGAU=1,NBNN
458 : IGMN=MIN(IGAU,VELCHE(/1))
459 : PRESS=PRESS+VELCHE(IGMN,IBMN)
460 : 4041 CONTINUE
461 : PRESS=PRESS/NBNN
462 : ENDIF
463 : * IE=0
464 : * DO 7041 IGAU=1,NBNN
465 : * IE=IE+1
466 : * IF (MELVAL.NE.0) THEN
467 : * IGMN=MIN(IGAU,VELCHE(/1))
468 : * IBMN=MIN(IB ,VELCHE(/2))
469 : * WORK(IE)=VELCHE(IGMN,IBMN)
470 : * ELSE
471 : * WORK(IE)=0.D0
472 : * ENDIF
473 : * 7041 CONTINUE
474 : C
475 : C ON CALCULE LA RIGIDITE GEOMETRIQUE
476 : C
477 : * SEGINI XMATRI
477 : CALL KPCOQ8(XE,PRESS,RE(1,1,ib),IASYM)
478 : C
479 : C REMPLISSAGE DE XMATRI
480 : C
481 : * SEGINI XMATRI
482 : * IMATTT(IB)=XMATRI
482 : * CALL REMPMC(REL,LRE,RE)
483 : * SEGDES XMATRI
484 : 3041 CONTINUE
485 : SEGDES xMATRI
486 : SEGSUP WRK1,WRK3
487 : GO TO 510
488 :
489 : C ELEMENT COQ2
490 : C
491 : 44 CONTINUE
492 : *
493 : * AM 01/09/94 PETIT TEST SUR IFOUR CAR NE FONCTIONNE
494 : * QU'EN SERIE DE FOURIER
495 : *
496 : IF(IFOUR.NE.1) GO TO 99
497 :
498 : * BP 17/02/2014 on teste aussi qu'on demande la partie symetrique seule
499 : IF(IASYM.NE.0) THEN
500 : write(ioimp,*) 'L option de calcul ASYMetrique ',
501 : & 'n est pas disponible avec les coq2 !'
501 : call ERREUR(19)
502 : goto 9990
503 : ENDIF
504 :
505 : NBBB=NBNN
506 : SEGINI WRK1,WRK3,WRK4
507 : DO 3044 IB=1,NBELEM
508 : C
509 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
510 : C
510 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
510 : CALL ZERO(REL,LRE,LRE)
511 : C
512 : C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
513 : C
514 : WORK(1)=0.D0
515 :
516 : IF(MELVAL.NE.0)THEN
517 : IBMN=MIN(IB ,VELCHE(/2))
518 : DO 1344 IGAU=1,NBNN
519 : IGMN=MIN(IGAU,VELCHE(/1))
520 : WORK(1)=WORK(1)+VELCHE(IGMN,IBMN)
521 : 1344 CONTINUE
522 : WORK(1)=WORK(1)/NBNN
523 : ENDIF
524 : C
525 : C APPEL A COQUE2 KP
526 : C
527 : AN=NHRM
527 : CALL CQ2KP(XE,WORK(1),AN,WORK(2),WORK(7),WORK(12),
528 : 1 WORK(19),WORK(26),REL,POIGAU,QSIGAU,NBPGAU,WORK(29),WORK(93),
529 : 2 WORK(157),WORK(221),WORK(285))
530 : C
531 : C REMPLISSAGE DE XMATRI
532 : C
533 : * SEGINI XMATRI
534 : * IMATTT(IB)=XMATRI
534 : CALL REMPMT(REL,LRE,RE(1,1,ib))
535 : * SEGDES XMATRI
536 : 3044 CONTINUE
537 : SEGDES xMATRI
538 : SEGSUP WRK1,WRK3,WRK4
539 : GOTO 510
540 : C
541 : C ELEMENT COQ4 NON ENCORE BRANCHE
542 : C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
543 : C
544 : 49 CONTINUE
545 : NBBB=NBNN
546 : SEGINI WRK1,WRK3,WRK4
547 : DO 3049 IB=1,NBELEM
548 : C
549 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
550 : C
550 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
551 : C
551 : CALL ZERO(REL,LRE,LRE)
552 : C
553 : C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
554 : C
555 : PRESS=0.D0
556 : IF(MELVAL.NE.0)THEN
557 : IBMN=MIN(IB ,VELCHE(/2))
558 : DO 4049 IGAU=1,NBNN
559 : IGMN=MIN(IGAU,VELCHE(/1))
560 : PRESS=PRESS+VELCHE(IGMN,IBMN)
561 : 4049 CONTINUE
562 : PRESS=PRESS/NBNN
563 : ENDIF
564 : * IE=0
565 : * DO 5049 IGAU=1,NBNN
566 : * IE=IE+1
567 : * IF (MELVAL.NE.0) THEN
568 : * IGMN=MIN(IGAU,VELCHE(/1))
569 : * IBMN=MIN(IB ,VELCHE(/2))
570 : * WORK(IE)=VELCHE(IGMN,IBMN)
571 : * ELSE
572 : * WORK(IE)=0.D0
573 : * ENDIF
574 : * 5049 CONTINUE
575 : C
576 : C APPEL A COQUE4 KSIGMA...
577 : C
578 : AN=NHRM
579 : * SEGINI XMATRI
579 : * CALL KPCOQ4(XE,PRESS,REL,IASYM)
579 : CALL KPCOQ4(XE,PRESS,RE(1,1,ib),IASYM)
580 : C
581 : C REMPLISSAGE DE XMATRI
582 : C
583 : * SEGINI XMATRI
584 : * IMATTT(IB)=XMATRI
584 : * CALL REMPMC(REL,LRE,RE)
585 : * SEGDES XMATRI
586 : 3049 CONTINUE
587 : SEGDES xMATRI
588 : SEGSUP WRK1,WRK3,WRK4
589 : GOTO 510
590 : *
591 : * element SHB8
592 : *
593 : 1260 continue
594 : *
595 : NBBB=NBNN
596 : SEGINI WRK1,wrk7
597 : * reperage du chpoint de pression
598 : segini icpr
599 : mchpoi=ipchpO
600 : segact mchpoi
601 : ino=0
602 : if(ipchp(/1).ne.1) then
602 : call erreur(19)
603 : return
604 : endif
605 : msoupo=ipchp(1)
606 : segact msoupo
607 : if(noharm(/1).ne.1)then
607 : call erreur(180)
608 : return
609 : endif
610 : meleme=igeoc
611 : segact meleme
612 : do ia=1,num(/2)
613 : ib=num(1,ia)
614 : if(icpr(ib).eq.0) then
615 : ino=ino+1
616 : icpr(ib)=ino
617 : endif
618 : enddo
619 : segdes meleme
620 : mpoval=ipoval
621 : segact mpoval
622 : * on cherche si surf interne ou externe
623 : meleme=ipmail
624 : if(lisref(/1).ne.2) then
624 : call erreur (1004)
625 : return
626 : endif
627 : isur=0
628 : do icas=1,2
629 : ipt3=lisref(icas)
630 : segact ipt3
631 : do ia=1,ipt3.num(/2)
632 : do ic=1,4
633 : ib=ipt3.num(ic,ia)
634 : if(icpr(ib).eq.0) go to 2260
635 : enddo
636 : enddo
637 : isur=icas
638 : go to 3260
639 : 2260 continue
640 : segdes ipt3
641 : enddo
641 : call erreur(286)
642 : return
643 : 3260 continue
644 : propel(2)=isur
645 :
646 : DO 4260 IB=1,NBELEM
647 : C
648 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
649 : C
649 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
649 : CALL ZERO(REL,LRE,LRE)
650 : C
651 : C ON CHERCHE LES PRESSIONS ON LES MET DANS WORK...
652 : C
653 : pre=0.d0
654 : do ia=1,4
655 : ibb=ipt3.num(ia,ib)
656 : pre=pre+vpocha(icpr(ibb),1)/4
657 : enddo
658 : propel(1)=pre
659 :
660 : C
661 : C APPEL A shb8 KP
662 : C
662 : call shb8(10,xe,D,propel,work1,rel,out)
663 : C
664 : C REMPLISSAGE DE XMATRI
665 : C
666 : * SEGINI XMATRI
667 : * IMATTT(IB)=XMATRI
667 : CALL REMPMT(REL,LRE,RE(1,1,ib))
668 : * SEGDES XMATRI
669 : 4260 CONTINUE
670 : SEGDES xMATRI
671 : SEGSUP WRK1,WRK7
672 : segsup icpr
673 : segdes mpoval
674 : GOTO 510
675 : C
676 : C ELEMENT COQ6 NON ENCORE BRANCHE
677 : C LES INSTRUCTIONS SUIVANTES SONT EN COMMENTAIRE
678 : C
679 : 56 CONTINUE
680 : NBBB=NBNN
681 : SEGINI WRK1,WRK3
682 : DO 3056 IB=1,NBELEM
683 : C
684 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENTIB
685 : C
685 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
686 : C
686 : CALL ZERO(REL,LRE,LRE)
687 : C
688 : C ON CHERCHE LES PRESSION - ON LES MET DANS WORK
689 : C
690 : PRESS=0.D0
691 : IF(MELVAL.NE.0)THEN
692 : IBMN=MIN(IB ,VELCHE(/2))
693 : DO 4056 IGAU=1,NBNN
694 : IGMN=MIN(IGAU,VELCHE(/1))
695 : PRESS=PRESS+VELCHE(IGMN,IBMN)
696 : 4056 CONTINUE
697 : PRESS=PRESS/NBNN
698 : ENDIF
699 : * IE= 0
700 : * DO 7056 IGAU=1,NBNN
701 : * IE=IE+1
702 : * IF (MELVAL.NE.0) THEN
703 : * IGMN=MIN(IGAU,VELCHE(/1))
704 : * IBMN=MIN(IB ,VELCHE(/2))
705 : * WORK(IE)=VELCHE(IGMN,IBMN)
706 : * ELSE
707 : * WORK(IE)=0.D0
708 : * ENDIF
709 : * 7056 CONTINUE
710 : C
711 : C ON CALCULE LA RIGIDITE GEOMETRIQUE
712 : C
713 : * SEGINI XMATRI
713 : CALL KPCOQ6(XE,PRESS,RE(1,1,ib),IASYM)
714 : C
715 : C REMPLISSAGE DE XMATRI
716 : C
717 : * SEGINI XMATRI
718 : * IMATTT(IB)=XMATRI
718 : * CALL REMPMC(REL,LRE,RE)
719 : * SEGDES XMATRI
720 : 3056 CONTINUE
721 : SEGDES xMATRI
722 : SEGSUP WRK1,WRK3
723 : GO TO 510
724 :
725 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
726 : C
727 : 510 CONTINUE
728 : SEGDES MELEME
729 : SEGDES IMODEL
730 :
731 : IF (IVAPR.NE.0) SEGDES MELVAL
732 : *
733 : *
734 : if(mele.ne.260)SEGDES MINTE
735 : * SEGSUP INFO
736 : 500 CONTINUE
737 : SEGDES MRIGID
738 : SEGDES MMODEL
739 : SEGDES MCHEL1
739 : IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
740 : RETURN
741 : *
742 : 99 CONTINUE
743 : MOTERR(1:4)=NOMTP(MELE)
744 : MOTERR(5:12)='KPRES '
744 : CALL ERREUR(86)
745 : *
746 : 9990 CONTINUE
747 : IRET=0
748 : C_______________________________________________________________________
749 : *
750 : * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
751 : C_______________________________________________________________________
752 : *
753 : IF(IVAPR.NE.0)SEGDES MELVAL
754 : *
755 : SEGDES MELEME
756 : SEGDES IMODEL
757 : SEGSUP DESCR
758 : SEGSUP xMATRI
759 : *
760 : SEGDES MMODEL
761 : SEGDES MCHEL1
761 : IF(ICHA.EQ.0) CALL DTCHAM(IPCHE1)
762 : SEGDES MINTE
763 : * SEGSUP INFO
764 : SEGSUP MRIGID
765 : RETURN
766 : END
767 :
768 :
769 :
770 :
771 :
© Cast3M 2003 - All rights reserved.
Disclaimer