1 : C BSIGM3 SOURCE AM 13/12/16 21:15:04 7825 2 : SUBROUTINE BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,NCARR,IVECT, 3 : & MELE,CMATE,IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFOR,IVAFOR 4 : & ,ADPG,BDPG,CDPG,IIPDPG,IVAMAT,NMATT,MFR) 5 : *---------------------------------------------------------------------- 6 : * _______________________________ * 7 : * | | * 8 : * | calcul des forces aux noeuds| * 9 : * |______________________________| * 10 : * * 11 : * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo * 12 : * poutre de timoschenko,shb8,joi1,zone_cohesive 13 : * * 14 : *---------------------------------------------------------------------* 15 : * * 16 : * entrees : * 17 : * ________ * 18 : * * 19 : * ipmail pointeur sur un segment meleme * 20 : * lre nombre de ddl dans la matrice de rigidite * 21 : * nstrs nombre de composante de contraintes/deformations * 22 : * lw dimension du tableau de travail de l'element * 23 : * ivacar pointeur sur les chamelems de caracteristiques géo. * 24 : * ncarr nombre de caracteristiques geometriques * 25 : * ivamat pointeur sur les chamelems de caracteristiques mat. * 26 : * nmatt nombre de caracteristiques matériau * 27 : * ivect flag indiquant si on a entree les axes locaux * 28 : * mele numero de l'element fini * 29 : * ivastr pointeur sur un segment mptval contenant les * 30 : * les melvals de contraints * 31 : * isous numero de la sous-zone * 32 : * nbpgau nombre de points d'integration pour les contraintes * 33 : * nbptel nombre de points par element * 34 : * ipmint pointeur sur un segment minte * 35 : * nfor nombre de composantes de forces * 36 : * * 37 : * sorties : * 38 : * ________ * 39 : * * 40 : * ivafor pointeur sur un segment mptval contenant les * 41 : * les melvals de forces * 42 : 43 : * * 44 : *---------------------------------------------------------------------* 45 : IMPLICIT INTEGER(I-N) 46 : IMPLICIT REAL*8(A-H,O-Z) 47 : * 48 : * 49 : -INC CCOPTIO 50 : -INC CCHAMP 51 : -INC CCREEL 52 : -INC SMCHAML 53 : -INC SMCHPOI 54 : -INC SMELEME 55 : -INC SMCOORD 56 : -INC SMMODEL 57 : -INC SMINTE 58 : -INC SMLMOTS 59 : c 60 : 61 : SEGMENT WRK1 62 : REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB) 63 : ENDSEGMENT 64 : * 65 : SEGMENT WRK2 66 : REAL*8 SHPWRK(6,NBNN), BGENE(NSTRS,LRE) 67 : ENDSEGMENT 68 : * 69 : SEGMENT WRK3 70 : REAL*8 WORK(LW) 71 : ENDSEGMENT 72 : * 73 : SEGMENT WRK4 74 : REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE) 75 : ENDSEGMENT 76 : * 77 : SEGMENT WRK5 78 : REAL*8 XGENE(NSTN,LRN) 79 : ENDSEGMENT 80 : * segment pour shb8 81 : SEGMENT WRK7 82 : REAL*8 PROPEL(24),D(3) 83 : REAL*8 rel(24,24),work1(30) 84 : ENDSEGMENT 85 : * 86 : SEGMENT MPTVAL 87 : INTEGER IPOS(NS) ,NSOF(NS) 88 : INTEGER IVAL(NCOSOU) 89 : CHARACTER*16 TYVAL(NCOSOU) 90 : ENDSEGMENT 91 : POINTEUR MPTVA1.MPTVAL,MPTVA2.MPTVAL 92 : * 93 : CHARACTER*4 lesinc(7),lesdua(7) 94 : DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/ 95 : DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/ 96 : CHARACTER*8 CMATE 97 : logical dcmat2 98 : 99 : dcmat2 = .false. 100 : MELEME=IPMAIL 101 : SEGACT MELEME 102 : NBNN=NUM(/1) 103 : NBELEM=NUM(/2) 104 : * 105 : * introduction des coord du point autour duquel se fait le 106 : * mouvement de la section en defo plane generalisee 107 : * et initialisation des forces au noeud support de la defo 108 : * plane generalisee 109 : * 110 : ADPG=0.D0 111 : BDPG=0.D0 112 : CDPG=0.D0 113 : IF (IFOUR.EQ.-3)THEN 114 : IP=IIPDPG 115 : SEGACT MCOORD 116 : IREF=(IP-1)*(IDIM+1) 117 : XDPGE=XCOOR(IREF+1) 118 : YDPGE=XCOOR(IREF+2) 119 : ELSE 120 : XDPGE=0.D0 121 : YDPGE=0.D0 122 : ENDIF 123 : * 124 : NHRM=NIFOUR 125 : MINTE=IPMINT 126 : * 127 : if (CMATE.EQ.'IMPELAST'.OR.CMATE.EQ.'IMPVOIGT' 128 : &.OR.CMATE.EQ.'IMPMAXWE'.or.CMATE.EQ.'IMPCOMPL') goto 45 129 : 130 : c_______________________________________________________________________ 131 : c_______________________________________________________________________ 132 : c 133 : c numero des etiquettes : 134 : c etiquettes de 1 a 98 pour traitement specifique a l element 135 : c dans la zone specifique a chaque element commencant par : 136 : c 5 continue 137 : c element 5 etiquettes 1005 2005 3005 4005 ... 138 : c 44 continue 139 : c element 44 etiquettes 1044 2044 3044 4044 ... 140 : c_______________________________________________________________________ 141 : c 142 : IF (MELE.LE.100) 143 : &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 144 : 1 99,99,99,99,99,99,99,99,29,30,99,99,99,99,99,99,99,99,99,99, 145 : 2 99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99, 146 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 147 : 4 99,99,99,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99 148 : 5 ),MELE 149 : IF (MELE.LE.200) 150 : &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 151 : 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 152 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 153 : 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 154 : 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 155 : 5 34),MELE-100 156 : IF (MELE.LE.300) 157 : &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 158 : 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 159 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 160 : 3 260,34,34,34,34,265,266,266,266),MELE-200 161 : c 162 : 34 CONTINUE 163 : GOTO 99 164 : c_______________________________________________________________________ 165 : c_______________________________________________________________________ 166 : c 167 : c elements poutre et poutre de timoschenko 168 : c_______________________________________________________________________ 169 : c 170 : 29 CONTINUE 171 : NBBB=NBNN 172 : SEGINI WRK1,WRK3 173 : c 174 : DO 3029 IB=1,NBELEM 175 : c 176 : c on cherche les coordonnees des noeuds de l elementib 177 : c 177 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 178 : c 179 : c il faudrait aussi modifier le vecteur local de la poutre 180 : c 181 : c 182 : c rangement des caracteristiques dans work 183 : c 184 : NCARR1=NCARR 185 : C 186 : IF((IVECT.EQ.1).AND.(IFOUR.NE.-2)) NCARR1=NCARR-1 187 : C 187 : CALL ZERO(WORK,NCARR1,1) 188 : DO 4029 IGAU=1,NBNN 189 : MPTVAL=IVACAR 190 : DO 6029 IC=1,NCARR1 191 : IF (IVAL(IC).NE.0) THEN 192 : MELVAL=IVAL(IC) 193 : IBMN=MIN(IB,VELCHE(/2)) 194 : IGMN=MIN(IGAU,VELCHE(/1)) 195 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 196 : ELSE 197 : WORK(IC)=0.D0 198 : ENDIF 199 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 200 : 6029 CONTINUE 201 : 4029 CONTINUE 202 : c 203 : c cas ou on a lu le mot vecteur 204 : c 205 : C 206 : IF (IFOUR.NE.-2) THEN 207 : C 208 : IF (IVECT.EQ.1) THEN 209 : IF (IVAL(NCARR).NE.0) THEN 210 : MELVAL=IVAL(NCARR) 211 : IBMN=MIN(IB,IELCHE(/2)) 212 : IP=IELCHE(1,IBMN) 213 : IREF=(IP-1)*(IDIM+1) 214 : DO 6129 IC=1,IDIM 215 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 216 : 6129 CONTINUE 217 : ELSE 218 : DO 6229 IC=1,IDIM 219 : WORK(NCARR+IC-1)=0.D0 220 : 6229 CONTINUE 221 : ENDIF 222 : ENDIF 223 : C 224 : ENDIF 225 : C 226 : c 227 : c 228 : c cas des tuyaux - on calcule les caracteristiques de la poutre 229 : c equivalente 230 : c 231 : IF(MELE.EQ.42) THEN 232 : CISA=WORK(4) 233 : VX =WORK(5) 234 : VY =WORK(6) 235 : VZ =WORK(7) 235 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0) 236 : ENDIF 237 : IF (KERRE.EQ.77) THEN 237 : CALL ERREUR(77) 238 : GOTO 510 239 : ENDIF 240 : c 241 : c on cherche les contraintes - 242 : c 243 : MPTVAL=IVASTR 244 : IE=9 245 : DO 7029 IGAU=1,2 246 : DO 7029 ICOMP=1,NSTRS 247 : IE=IE+1 248 : MELVAL=IVAL(ICOMP) 249 : IBMN=MIN(IB ,VELCHE(/2)) 250 : IGMN=MIN(IGAU,VELCHE(/1)) 251 : WORK(IE)=VELCHE(IGMN,IBMN) 252 : 7029 CONTINUE 253 : c 254 : c on calcule les forces internes 255 : c 256 : IF(MELE.EQ.84) THEN 257 : IF(CMATE.NE.'SECTION') THEN 258 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 258 : CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE) 259 : ELSE 259 : CALL TIMBSG(XFORC,WORK(7),XE,WORK(10),WORK(22),KERRE) 260 : ENDIF 261 : ELSE 262 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 262 : CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE) 263 : ELSE 263 : CALL TIMBSG(XFORC,WORK(1),XE,WORK(10),WORK(22),KERRE) 264 : ENDIF 265 : ENDIF 266 : ELSE 267 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 267 : CALL POUBS2(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) 268 : ELSE 268 : CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) 269 : ENDIF 270 : ENDIF 271 : IF(KERRE.EQ.0) GO TO 5029 272 : INTERR(1)=ISOUS 273 : INTERR(2)=IB 274 : SEGSUP WRK1,WRK3 274 : CALL ERREUR(128) 275 : GO TO 510 276 : 5029 CONTINUE 277 : c 278 : c rangement dans melval 279 : c 280 : IE=0 281 : MPTVAL=IVAFOR 282 : DO 9029 IGAU=1,NBNN 283 : DO 9029 ICOMP=1,NFOR 284 : IE=IE+1 285 : MELVAL=IVAL(ICOMP) 286 : IBMN=MIN(IB ,VELCHE(/2)) 287 : VELCHE(IGAU,IBMN)=XFORC(IE) 288 : 9029 CONTINUE 289 : 3029 CONTINUE 290 : SEGSUP WRK1,WRK3 291 : GO TO 510 292 : c_______________________________________________________________________ 293 : c 294 : c elements lisp et lism 295 : c_______________________________________________________________________ 296 : c 297 : 30 CONTINUE 298 : NBBB=NBNN 299 : NBNO=SHPTOT(/2) 300 : SEGINI WRK1,WRK3,WRK4 301 : c 302 : DO 3030 IB=1,NBELEM 303 : c 304 : c on cherche les coordonnees des noeuds de l element ib 305 : c 305 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 306 : c 307 : c 308 : c on cherche les contraintes 309 : c 310 : IE=0 311 : MPTVAL=IVASTR 312 : DO 7030 IGAU=1,NBPGAU 313 : DO 7030 ICOMP=1,NSTRS 314 : IE=IE+1 315 : MELVAL=IVAL(ICOMP) 316 : IGMN=MIN(IGAU,VELCHE(/1)) 317 : IBMN=MIN(IB ,VELCHE(/2)) 318 : WORK(IE)=VELCHE(IGMN,IBMN) 319 : 7030 CONTINUE 320 : c 321 : c on cherche les caracteristiques 322 : c 323 : MPTVAL=IVACAR 324 : DO 6030 IGAU=1,NBPGAU 325 : DO 6030 ICOMP=1,NCARR 326 : IE=IE+1 327 : MELVAL=IVAL(ICOMP) 328 : IF (MELVAL.NE.0) THEN 329 : IGMN=MIN(IGAU,VELCHE(/1)) 330 : IBMN=MIN(IB ,VELCHE(/2)) 331 : WORK(IE)=VELCHE(IGMN,IBMN) 332 : ELSE 333 : WORK(IE)=0.D0 334 : ENDIF 335 : 6030 CONTINUE 336 : c 337 : c on calcule b*sigma 338 : c 339 : ICNT=NBPGAU*NSTRS+1 339 : CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT, 340 : 1 NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC) 341 : c 342 : c rangement dans melval 343 : c 344 : IE=0 345 : MPTVAL=IVAFOR 346 : DO 9030 IGAU=1,NBNN 347 : DO 9030 ICOMP=1,6 348 : IE=IE+1 349 : MELVAL=IVAL(ICOMP) 350 : IBMN=MIN(IB ,VELCHE(/2)) 351 : VELCHE(IGAU,IBMN)=XFORC(IE) 352 : 9030 CONTINUE 353 : 3030 CONTINUE 354 : SEGSUP WRK1,WRK3,WRK4 355 : GOTO 510 356 : c_______________________________________________________________________ 357 : c 358 : c element tuyau fissure 359 : c_______________________________________________________________________ 360 : c 361 : 43 CONTINUE 362 : NBBB=NBNN 363 : SEGINI WRK1,WRK3 364 : c 365 : DO 3043 IB=1,NBELEM 366 : c 367 : c on cherche les contraintes 368 : c 369 : IE=0 370 : MPTVAL=IVASTR 371 : DO 4043 IGAU=1,NBPTEL 372 : DO 4043 ICOMP=1,NSTRS 373 : IE=IE+1 374 : MELVAL=IVAL(ICOMP) 375 : IGMN=MIN(IGAU,VELCHE(/1)) 376 : IBMN=MIN(IB ,VELCHE(/2)) 377 : WORK(IE)=VELCHE(IGMN,IBMN) 378 : 4043 CONTINUE 379 : c 380 : c on cherche les caracteristiques 381 : c 382 : MPTVAL=IVACAR 383 : DO 5043 ICOMP=1,NCARR 384 : MELVAL=IVAL(ICOMP) 385 : IF (MELVAL.NE.0) THEN 386 : IBMN=MIN(IB ,VELCHE(/2)) 387 : WORK(ICOMP+8)=VELCHE(1,IBMN) 388 : ELSE 389 : WORK(ICOMP+8)=0.D0 390 : ENDIF 391 : 5043 CONTINUE 392 : c 393 : c on calcule les forces internes 394 : c 394 : CALL TUFIBS(XFORC,WORK,WORK(9),WORK(18),KERRE) 395 : c 396 : c rangement dans melval 397 : c 398 : IE=0 399 : MPTVAL=IVAFOR 400 : DO 6043 IGAU=1,NBNN 401 : DO 6043 ICOMP=1,NFOR 402 : IE=IE+1 403 : MELVAL=IVAL(ICOMP) 404 : IBMN=MIN(IB ,VELCHE(/2)) 405 : VELCHE(IGAU,IBMN)=XFORC(IE) 406 : 6043 CONTINUE 407 : 3043 CONTINUE 408 : SEGSUP WRK1,WRK3 409 : GO TO 510 410 : c_______________________________________________________________________ 411 : c 412 : c element point (poi1) defos planes generalisees/materiau IMPEDANCE 413 : c_______________________________________________________________________ 414 : c 415 : 45 CONTINUE 416 : NBBB=NBNN 417 : * 418 : * 419 : IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR. 420 : & (CMATE.EQ.'IMPMAXWE').OR .cmate.eq.'IMPCOMPL'.or. 421 : & cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') THEN 422 : mptva1 = ivastr 423 : mptval = ivafor 424 : segact mptva1,mptval 425 : * detection impedance "sur mesure" 426 : if (ival(/1).eq.mptva1.ival(/1)*2) dcmat2 = .true. 427 : numstr = mptva1.ival(/1) 428 : do iv = 1,ival(/1) 429 : if (dcmat2) then 430 : if(iv.le.numstr) then 431 : melva1 = mptva1.ival(iv) 432 : else 433 : melva1 = mptva1.ival(iv - numstr) 434 : endif 435 : else 436 : melva1 = mptva1.ival(iv) 437 : endif 438 : melval = ival(iv) 439 : segact melva1,melval*mod 440 : DO IB=1,NBELEM 441 : 442 : DO 4145 IGAU=1,NBNN 443 : IGMN=MIN(IGAU,MELVA1.VELCHE(/1)) 444 : IBMN=MIN(IB ,MELVA1.VELCHE(/2)) 445 : valstr = MELVA1.VELCHE(IGMN,IBMN) 446 : VELCHE(IGMN,IBMN) = valstr 447 : * write(6,*) 'bs3',cmate,iv,ib,valstr,mptva1.ival(/1),ival(/1) 448 : 4145 CONTINUE 449 : ENDDO 450 : 451 : enddo 452 : 453 : GOTO 510 454 : ENDIF 455 : 456 : * 457 : IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN 458 : GO TO 99 459 : ENDIF 460 : * 461 : SEGINI WRK1,WRK3 462 : c 463 : DO 3045 IB=1,NBELEM 464 : c 465 : c on cherche les coordonnees des noeuds de l element ib 466 : c 466 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 467 : c 468 : c 469 : c mise a zero des forces internes 470 : c 470 : CALL ZERO(XFORC,1,LRE) 471 : c 472 : c on cherche l'effort 473 : c 474 : MPTVAL=IVASTR 475 : MELVAL=IVAL(1) 476 : IBMN=MIN(IB ,VELCHE(/2)) 477 : EFFORT=VELCHE(1,IBMN) 478 : c 479 : c on calcule les forces internes 480 : c 480 : CALL PO1BSG(XE,LRE,XDPGE,YDPGE,EFFORT,XFORC) 481 : ADPG=ADPG+XFORC(3) 482 : BDPG=BDPG+XFORC(4) 483 : CDPG=CDPG+XFORC(5) 484 : c 485 : c rangement dans melval 486 : c 487 : IE=0 488 : MPTVAL=IVAFOR 489 : DO 9045 IGAU=1,NBNN 490 : DO 9045 ICOMP=1,NFOR-3 491 : IE=IE+1 492 : MELVAL=IVAL(ICOMP) 493 : IBMN=MIN(IB ,VELCHE(/2)) 494 : VELCHE(IGAU,IBMN)=XFORC(IE) 495 : 9045 CONTINUE 496 : 3045 CONTINUE 497 : c 498 : SEGSUP WRK1,WRK3 499 : GO TO 510 500 : c_______________________________________________________________________ 501 : c 502 : c elements barre et cerce 503 : c_______________________________________________________________________ 504 : c 505 : 46 CONTINUE 506 : NBBB=NBNN 507 : * 508 : IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN 509 : GO TO 99 510 : ENDIF 511 : * 512 : SEGINI WRK1,WRK3 513 : c 514 : DO 3046 IB=1,NBELEM 515 : c 516 : c on cherche les coordonnees des noeuds de l element ib 517 : c 517 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 518 : C 519 : IF(MELE.EQ.123) THEN 520 : c 521 : c on cherche l'effort 522 : c 523 : IE=0 524 : MPTVAL=IVASTR 525 : DO 4046 IGAU=1,NBPTEL 526 : DO 4046 ICOMP=1,NSTRS 527 : IE=IE+1 528 : MELVAL=IVAL(ICOMP) 529 : IGMN=MIN(IGAU,VELCHE(/1)) 530 : IBMN=MIN(IB ,VELCHE(/2)) 531 : WORK(IE)=VELCHE(IGMN,IBMN) 532 : 4046 CONTINUE 533 : c 534 : c on calcule les forces internes 535 : c 535 : CALL BARBS3(XFORC,XE,WORK,KERRE,QSIGAU,POIGAU,NBPGAU,IB) 536 : c 537 : ELSE 538 : c 539 : c on cherche l'effort 540 : c 541 : MPTVAL=IVASTR 542 : MELVAL=IVAL(1) 543 : NPPTEL=VELCHE(/1) 544 : IF(NPPTEL.EQ.1) THEN 545 : IBMN=MIN(IB ,VELCHE(/2)) 546 : EFFORT=VELCHE(1,IBMN) 547 : ENDIF 548 : IF(NPPTEL.EQ.2) THEN 549 : IBMN=MIN(IB ,VELCHE(/2)) 550 : EFFOR1=VELCHE(1,IBMN) 551 : EFFOR2=VELCHE(2,IBMN) 552 : EFFORT=0.5D0*(EFFOR1+EFFOR2) 553 : ENDIF 554 : c 555 : c on calcule les forces internes 556 : c 556 : IF(MELE.EQ.46) CALL BARBSG(XFORC,XE,EFFORT,KERRE) 556 : IF(MELE.EQ.95) CALL CERBSG(XFORC,XE,EFFORT,KERRE) 557 : ENDIF 558 : C 559 : IF(KERRE.EQ.0) GO TO 5046 560 : INTERR(1)=ISOUS 561 : INTERR(2)=IB 562 : SEGSUP WRK1,WRK3 562 : IF(MELE.EQ.46) CALL ERREUR(128) 562 : IF(MELE.EQ.95) CALL ERREUR(128) 563 : GO TO 510 564 : 5046 CONTINUE 565 : c 566 : c rangement dans melval 567 : c 568 : NFOD=NFOR 569 : IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NFOD=NFOR-3 570 : IE=0 571 : MPTVAL=IVAFOR 572 : DO 9046 IGAU=1,NBNN 573 : DO 9046 ICOMP=1,NFOD 574 : IE=IE+1 575 : MELVAL=IVAL(ICOMP) 576 : IBMN=MIN(IB ,VELCHE(/2)) 577 : VELCHE(IGAU,IBMN)=XFORC(IE) 578 : 9046 CONTINUE 579 : 3046 CONTINUE 580 : SEGSUP WRK1,WRK3 581 : GO TO 510 582 : C_______________________________________________________________________ 583 : C 584 : C ELEMENT BARRE 3D EXCENTRE (BAEX) 585 : C_______________________________________________________________________ 586 : C 587 : 124 CONTINUE 588 : NBBB=NBNN 589 : NSTN=NBNN 590 : LRN =LRE 591 : SEGINI WRK1,WRK3,WRK5 592 : C 593 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 594 : C 595 : KERRE=0 596 : DO 3124 IB=1,NBELEM 597 : C 598 : C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON 599 : C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK 600 : C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ 601 : C 602 : MPTVAL=IVACAR 603 : DO IC=1,NCARR 604 : IF(IVAL(IC).NE.0) THEN 605 : MELVAL=IVAL(IC) 606 : IBMN=MIN(IB,VELCHE(/2)) 607 : WORK(IC)=VELCHE(1,IBMN) 608 : ELSE 609 : WORK(IC)=0.D0 610 : ENDIF 611 : END DO 612 : SECT=WORK(1) 613 : C 614 : C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE 615 : C 615 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 615 : CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE) 616 : IF(KERRE.NE.0) INTERR(1)=ISOUS 617 : IF(KERRE.NE.0) INTERR(2)=IB 617 : IF(KERRE.EQ.1) CALL ERREUR(128) 618 : C 619 : C MISE A ZERO DES FORCES INTERNES 620 : C 620 : CALL ZERO(XFORC,1,LRE) 621 : C 622 : C ON CHERCHE L'EFFORT 623 : C 624 : MPTVAL=IVASTR 625 : MELVAL=IVAL(1) 626 : NPPTEL=VELCHE(/1) 627 : IF(NPPTEL.EQ.1) THEN 628 : IBMN=MIN(IB ,VELCHE(/2)) 629 : EFFORT=VELCHE(1,IBMN) 630 : ENDIF 631 : IF(NPPTEL.EQ.2) THEN 632 : IBMN=MIN(IB ,VELCHE(/2)) 633 : EFFOR1=VELCHE(1,IBMN) 634 : EFFOR2=VELCHE(2,IBMN) 635 : EFFORT=0.5D0*(EFFOR1+EFFOR2) 636 : ENDIF 637 : CC EFFORT=SECT*EFFORT 638 : C 639 : C ON CALCULE LES FORCES INTERNES 640 : C 640 : CALL BARINT(XFORC,XGENE,EFFORT,LRE) 641 : C 642 : C RANGEMENT DANS MELVAL 643 : C 644 : IE=0 645 : MPTVAL=IVAFOR 646 : DO 9199 IGAU=1,NBNN 647 : DO 9199 ICOMP=1,NFOR 648 : IE=IE+1 649 : MELVAL=IVAL(ICOMP) 650 : IBMN=MIN(IB ,VELCHE(/2)) 651 : VELCHE(IGAU,IBMN)=XFORC(IE) 652 : 9199 CONTINUE 653 : 3124 CONTINUE 654 : SEGSUP WRK1,WRK3,WRK5 655 : GO TO 510 656 : *----------------------------------------------- 657 : * element shb8 658 : *------------------------------------------------ 659 : 260 CONTINUE 660 : NBBB=NBNN 661 : SEGINI WRK1,WRK7 662 : DO 3260 IB=1,NBELEM 663 : c 664 : c on cherche les coordonnees des noeuds de l element ib 665 : c 665 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 666 : c 667 : c 668 : c on cherche les contraintes 669 : c 670 : IE=0 671 : MPTVAL=IVASTR 672 : DO 7260 IGAU=1,NBPGAU 673 : DO 7260 ICOMP=1,NSTRS 674 : IE=IE+1 675 : MELVAL=IVAL(ICOMP) 676 : IGMN=MIN(IGAU,VELCHE(/1)) 677 : IBMN=MIN(IB ,VELCHE(/2)) 678 : WORK1(IE)=VELCHE(IGMN,IBMN) 679 : 7260 CONTINUE 680 : c 681 : c on cherche les materiaux 682 : c 683 : yyo=0.d0 684 : ynu=0.d0 685 : MPTVAL=IVAMAT 686 : segact mptval 687 : DO 6260 IGAU=1,NBPGAU 688 : DO 6260 ICOMP=1,2 689 : MELVAL=IVAL(ICOMP) 690 : IF (MELVAL.NE.0) THEN 691 : IGMN=MIN(IGAU,VELCHE(/1)) 692 : IBMN=MIN(IB ,VELCHE(/2)) 693 : if(icomp.eq.1) yyo=yyo+VELCHE(IGMN,IBMN)/nbpgau 694 : if(icomp.eq.2)ynu=ynu+VELCHE(IGMN,IBMN)/nbpgau 695 : ENDIF 696 : 6260 CONTINUE 697 : c 698 : c on calcule b*sigma 699 : c 700 : d(1)=yyo 701 : d(2)=ynu 702 : d(3)=0 702 : CALL shb8(8,XE,D,propel,work1,rel,xforc) 703 : c 704 : c rangement dans melval 705 : c 706 : IE=0 707 : MPTVAL=IVAFOR 708 : DO 9260 IGAU=1,Nbnn 709 : DO 9260 ICOMP=1,3 710 : IE=IE+1 711 : MELVAL=IVAL(ICOMP) 712 : IBMN=MIN(IB ,VELCHE(/2)) 713 : VELCHE(IGAU,IBMN)=XFORC(IE) 714 : 9260 CONTINUE 715 : 3260 CONTINUE 716 : SEGSUP WRK1,WRk7 717 : GO TO 510 718 : C_______________________________________________________________________ 719 : C 720 : C LIA2 : element de liaison a 2 noeuds (6 ddl par 721 : C noeuds) 722 : C_______________________________________________________________________ 723 : C 724 : 125 CONTINUE 725 : NBBB=NBNN 726 : NSTN=3 727 : LRN =3 728 : SEGINI WRK1,WRK3,WRK5 729 : C 730 : KERRE=0 731 : DO 3109 IB=1,NBELEM 732 : C 733 : C MISE A ZERO DES FORCES INTERNES 734 : C 734 : CALL ZERO(XFORC,1,LRE) 735 : C 736 : MPTVAL=IVACAR 737 : DO IC=1,NCARR 738 : IF(IVAL(IC).NE.0) THEN 739 : MELVAL=IVAL(IC) 740 : IBMN=MIN(IB,VELCHE(/2)) 741 : WORK(IC)=VELCHE(1,IBMN) 742 : ELSE 743 : WORK(IC)=0.D0 744 : ENDIF 745 : END DO 746 : C 746 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 746 : CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE) 747 : IF(KERRE.NE.0) INTERR(1)=ISOUS 748 : IF(KERRE.NE.0) INTERR(2)=IB 748 : IF(KERRE.EQ.1) CALL ERREUR(128) 749 : C 750 : C ON CHERCHE LES CONTRAINTES - 751 : C 752 : MPTVAL=IVASTR 753 : IE=0 754 : DO 7109 IGAU=1,2 755 : DO 7109 ICOMP=1,NSTRS 756 : IE=IE+1 757 : MELVAL=IVAL(ICOMP) 758 : IBMN=MIN(IB ,VELCHE(/2)) 759 : IGMN=MIN(IGAU,VELCHE(/1)) 760 : XSTRS(IE)=VELCHE(IGMN,IBMN) 761 : 7109 CONTINUE 762 : C 763 : C ON CALCULE LES FORCES INTERNES !!!! a ameliorer 764 : C 764 : CALL LIAINT(XSTRS,XGENE,XFORC,LRE,NSTRS) 765 : C 766 : C RANGEMENT DANS MELVAL 767 : C 768 : IE=0 769 : MPTVAL=IVAFOR 770 : DO 9109 IGAU=1,NBNN 771 : DO 9109 ICOMP=1,NFOR 772 : IE=IE+1 773 : MELVAL=IVAL(ICOMP) 774 : IBMN=MIN(IB ,VELCHE(/2)) 775 : VELCHE(IGAU,IBMN)=XFORC(IE) 776 : 9109 CONTINUE 777 : 3109 CONTINUE 778 : SEGSUP WRK1,WRK3,WRK5 779 : GO TO 510 780 : C_______________________________________________________________________ 781 : C 782 : C JOI1 : element de liaison a 2 noeuds (6 ddl par 783 : C noeuds) 784 : C_______________________________________________________________________ 785 : C 786 : 265 CONTINUE 787 : NBBB=NBNN 788 : NSTN=3 789 : LRN =3 790 : SEGINI WRK1,WRK3,WRK4 791 : C 792 : KERRE=0 793 : DO 3110 IB=1,NBELEM 794 : C 795 : C MISE A ZERO DES FORCES INTERNES 796 : C 796 : CALL ZERO(XFORC,1,LRE) 797 : C 798 : MPTVAL=IVAMAT 799 : DO IC=1,NMATT 800 : IF(IVAL(IC).NE.0) THEN 801 : MELVAL=IVAL(IC) 802 : IBMN=MIN(IB,VELCHE(/2)) 803 : WORK(IC)=VELCHE(1,IBMN) 804 : ELSE 805 : WORK(IC)=0.D0 806 : ENDIF 807 : END DO 808 : C 808 : CALL MAPALU(NMATT,WORK,BPSS,IDIM) 809 : C 810 : C ON CHERCHE LES CONTRAINTES - 811 : C 812 : MPTVAL=IVASTR 813 : 814 : IE=0 815 : DO 7110 ICOMP=1,NSTRS 816 : IE=IE+1 817 : MELVAL=IVAL(ICOMP) 818 : IBMN=MIN(IB ,VELCHE(/2)) 819 : XSTRS(IE)=VELCHE(1,IBMN) 820 : 7110 CONTINUE 821 : C 822 : C ON CALCULE LES FORCES INTERNES 823 : C 823 : CALL INTJOI(XSTRS,XFORC,NSTRS) 824 : C 825 : C ON PASSE LES CONTRAINTES DANS LE REPERE GLOBAL 826 : C 827 : IAW1 = 101 828 : IAW2=IAW1+LRE 828 : CALL JOIGLV(XFORC,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) 829 : C 830 : C RANGEMENT DANS MELVAL 831 : C 832 : IE=0 833 : MPTVAL=IVAFOR 834 : DO 9110 IGAU=1,NBNN 835 : DO 9110 ICOMP=1,NFOR 836 : IE=IE+1 837 : MELVAL=IVAL(ICOMP) 838 : IBMN=MIN(IB ,VELCHE(/2)) 839 : VELCHE(IGAU,IBMN)=XFORC(IE) 840 : 9110 CONTINUE 841 : 3110 CONTINUE 842 : SEGSUP WRK1,WRK3,WRK4 843 : GO TO 510 844 : c_______________________________________________________________________ 845 : c 846 : c element tuyo 847 : c_______________________________________________________________________ 848 : c 849 : 96 CONTINUE 850 : NBBB=NBNN 851 : SEGINI WRK1,WRK3 852 : c 853 : DO 3096 IB=1,NBELEM 854 : c 855 : c on cherche les coordonnees des noeuds de l elementib 856 : c 856 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 857 : c 858 : c il faudrait aussi modifier le vecteur local de la poutre 859 : c 860 : c 861 : c mise a zero des forces internes 862 : c 862 : CALL ZERO(XFORC,1,LRE) 863 : c 864 : c rangement des caracteristiques dans work 865 : c 866 : MPTVAL=IVACAR 867 : DO 6096 IC=1,NCARR 868 : IF (IVAL(IC).NE.0) THEN 869 : MELVAL=IVAL(IC) 870 : IBMN=MIN(IB,VELCHE(/2)) 871 : WORK(IC)=VELCHE(1,IBMN) 872 : ELSE 873 : WORK(IC)=0.D0 874 : ENDIF 875 : 6096 CONTINUE 876 : c 877 : c cas ou on a lu le mot vecteur 878 : c 879 : IF (IVECT.EQ.1) THEN 880 : IF (IVAL(NCARR).NE.0) THEN 881 : MELVAL=IVAL(NCARR) 882 : IBMN=MIN(IB,IELCHE(/2)) 883 : IP=IELCHE(1,IBMN) 884 : IREF=(IP-1)*(IDIM+1) 885 : DO 6196 IC=1,IDIM 886 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 887 : 6196 CONTINUE 888 : ELSE 889 : DO 6296 IC=1,IDIM 890 : WORK(NCARR+IC-1)=0.D0 891 : 6296 CONTINUE 892 : ENDIF 893 : c 894 : c cas du chamelem comverti 895 : c 896 : ELSE IF (IVECT.EQ.2) THEN 897 : DO 6496 IC=1,IDIM 898 : MELVAL=IVAL(NCARR+IC-3) 899 : IF (MELVAL.NE.0) THEN 900 : IBMN=MIN(IB,VELCHE(/2)) 901 : WORK(NCARR+IC-3)=VELCHE(1,IBMN) 902 : ELSE 903 : WORK(NCARR+IC-3)=0.D0 904 : ENDIF 905 : 6496 CONTINUE 906 : ENDIF 907 : c 908 : c 909 : c cas des tuyaux - on calcule les caracteristiques de la poutre 910 : c equivalente 911 : c 912 : IF(MELE.EQ.42) THEN 913 : CISA=WORK(4) 914 : VX =WORK(5) 915 : VY =WORK(6) 916 : VZ =WORK(7) 916 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0) 917 : ENDIF 918 : IF (KERRE.EQ.77) THEN 918 : CALL ERREUR(77) 919 : GOTO 510 920 : ENDIF 921 : c 922 : c on cherche les contraintes - 923 : c 924 : MPTVAL=IVASTR 925 : IE=9 926 : DO 7096 IGAU=1,2 927 : DO 7096 ICOMP=1,NSTRS 928 : IE=IE+1 929 : MELVAL=IVAL(ICOMP) 930 : IBMN=MIN(IB ,VELCHE(/2)) 931 : IGMN=MIN(IGAU,VELCHE(/1)) 932 : WORK(IE)=VELCHE(IGMN,IBMN) 933 : 7096 CONTINUE 934 : c 935 : c on calcule les forces internes 936 : c 936 : CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE) 937 : IF(KERRE.EQ.0) GO TO 5096 938 : INTERR(1)=ISOUS 939 : INTERR(2)=IB 940 : SEGSUP WRK1,WRK3 940 : CALL ERREUR(128) 941 : GO TO 510 942 : 5096 CONTINUE 943 : c 944 : c rangement dans melval 945 : c 946 : IE=0 947 : MPTVAL=IVAFOR 948 : DO 9096 IGAU=1,NBNN 949 : DO 9096 ICOMP=1,NFOR 950 : IE=IE+1 951 : MELVAL=IVAL(ICOMP) 952 : IBMN=MIN(IB ,VELCHE(/2)) 953 : VELCHE(IGAU,IBMN)=XFORC(IE) 954 : 9096 CONTINUE 955 : 3096 CONTINUE 956 : SEGSUP WRK1,WRK3 957 : GO TO 510 958 : 959 : C_______________________________________________________________________ 960 : C 961 : C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4 962 : C_______________________________________________________________________ 963 : C 964 : 266 CONTINUE 965 : 966 : NDIM = 2 967 : IF(IFOUR.GT.0) NDIM = 3 968 : NBBB=NBNN 969 : SEGINI WRK1,WRK2,WRK4 970 : C 971 : DO 3266 IB=1,NBELEM 972 : C 973 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 974 : C 974 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 975 : C 976 : C MISE A ZERO DES FORCES INTERNES 977 : C 977 : CALL ZERO(XFORC,1,LRE) 978 : C 979 : C BOUCLE SUR LES POINTS DE GAUSS 980 : C 981 : DO 6266 IGAU=1,NBPGAU 982 : C 982 : CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) 983 : C 983 : CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, 984 : . NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT) 985 : IF (IERT.NE.0) THEN 986 : INTERR(1)=IB 986 : CALL ERREUR(612) 987 : GOTO 99266 988 : ENDIF 989 : C 990 : C ON CHERCHE LES CONTRAINTES - 991 : C 992 : MPTVAL=IVASTR 993 : DO 7266 ICOMP=1,NSTRS 994 : MELVAL=IVAL(ICOMP) 995 : IGMN=MIN(IGAU,VELCHE(/1)) 996 : IBMN=MIN(IB ,VELCHE(/2)) 997 : XSTRS(ICOMP)=VELCHE(IGMN,IBMN) 998 : 7266 CONTINUE 999 : C 1000 : C ON CALCULE B*EFFORTS 1001 : C 1002 : DJAC=DJAC*POIGAU(IGAU) 1002 : CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC) 1003 : 6266 CONTINUE 1004 : C 1005 : C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL 1006 : C 1007 : IE=0 1008 : MPTVAL=IVAFOR 1009 : C 1010 : DO 9266 NODE=1,NBNN 1011 : DO 9266 ICOMP=1,NDIM 1012 : IE=IE+1 1013 : MELVAL=IVAL(ICOMP) 1014 : IBMN=MIN(IB ,VELCHE(/2)) 1015 : VELCHE(NODE,IBMN)=XFORC(IE) 1016 : 9266 CONTINUE 1017 : 3266 CONTINUE 1018 : 1019 : 99266 CONTINUE 1020 : SEGSUP WRK1,WRK2,WRK4 1021 : GOTO 510 1022 : c_______________________________________________________________________ 1023 : 99 CONTINUE 1024 : MOTERR(1:4)=NOMTP(MELE) 1025 : MOTERR(5:12)='BSIGMA' 1025 : CALL ERREUR(86) 1026 : * 1027 : 510 CONTINUE 1028 : RETURN 1029 : END 1030 : 1031 : 1032 : 1033 : 1034 : 1035 : 1036 : 1037 : 1038 : 1039 : 1040 : 1041 : 1042 : 1043 : 1044 : 1045 : 1046 : 1047 : 1048 : 1049 : 1050 : 1051 : 1052 : 1053 : 1054 :
© Cast3M 2003 - All rights reserved.
Disclaimer