1 : C SIGMA3 SOURCE AM 11/05/26 21:16:42 6982 2 : SUBROUTINE SIGMA3(IPMAIL,IVADEP,NDEP,IVACAR,NCARR,IPMINT, 3 : & IVECT,IVAMAT,MELE,IMAT,NELMAT,NBGMAT,LHOOK,CMATE,IREPS2, 4 : & NBPTEL,NSTRS,MFR,NMATT,NBPGAU,ISOUS,LRE,LW,IVASTR,UZDPG, 5 : & RYDPG,RXDPG,IIPDPG) 6 : *---------------------------------------------------------------------* 7 : * __________________________ * 8 : * | | * 9 : * | CALCUL DES CONTRAINTES| * 10 : * |________________________| * 11 : * * 12 : * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo,shb8 * 13 : * * 14 : * * 15 : *---------------------------------------------------------------------* 16 : * * 17 : * ENTREES : * 18 : * ________ * 19 : * * 20 : * IPMAIL Pointeur sur un segment MELEME * 21 : * IVADEP Pointeur sur le chamelem de deplacements * 22 : * NDEP Nombre de composantes de deplacements * 23 : * IVACAR Pointeur sur les chamelems de caracteristiques * 24 : * NCARR Nombre de caracteristiques geometriques * 25 : * IVECT Flag indiquant si on a entree les axes locaux * 26 : * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * 27 : * MELE Numero de l'element fini * 28 : * IMAT (2 il y a une matrice de HOOKE,1 non ) * 29 : * NELMAT Taille maxi des melval du materiau (No d'element) * 30 : * NBGMAT Taille maxi des melval du materiau (pt de gauss) * 31 : * LHOOK Dimension de la matrice de Hooke * 32 : * CMATE Nom du materiau * 33 : * IRESP2 Flag pour indiquer si on veut les contraintes * 34 : * de Piola-Kirchhoff * 35 : * NBPTEL Nombre de points par element * 36 : * NSTRS Nombre de composante de contraintes/deformations * 37 : * MFR Numero de formulation de l'element fini * 38 : * NMATT Nombre de composante de materiau (IMAT=1) * 39 : * pour une matrice de hooke * 40 : * NBPGAU Nombre de point d'integration pour la rigidite * 41 : * ISOUS NUMERO DE LA SOUS-ZONE * 42 : * LRE Nombre de ddl dans la matrice de rigidite * 43 : * LW Dimension du tableau de travail de l'element * 44 : * * 45 : * SORTIES : * 46 : * ________ * 47 : * * 48 : * IVASTR pointeur sur un segment MPTVAL contenant les * 49 : * les melvals de contraints * 50 : * * 51 : *---------------------------------------------------------------------* 52 : IMPLICIT INTEGER(I-N) 53 : IMPLICIT REAL*8(A-H,O-Z) 54 : * 55 : -INC CCOPTIO 56 : -INC CCHAMP 57 : -INC CCREEL 58 : -INC SMCHAML 59 : -INC SMINTE 60 : -INC SMELEME 61 : -INC SMCOORD 62 : -INC SMLREEL 63 : * 64 : SEGMENT WRK1 65 : REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS) 66 : REAL*8 XE(3,NBBB) ,DDHOMU(NSTRS,NSTRS) 67 : ENDSEGMENT 68 : * 69 : SEGMENT WRK2 70 : REAL*8 BPSS(3,3) ,BGENE(LHOOK,LRE) 71 : ENDSEGMENT 72 : * 73 : SEGMENT WRK3 74 : REAL*8 WORK(LW) 75 : ENDSEGMENT 76 : * 77 : SEGMENT WRK5 78 : REAL*8 XGENE(NSTN,LRN) 79 : ENDSEGMENT 80 : * 81 : SEGMENT WRK7 82 : REAL*8 PROPEL(45) 83 : REAL*8 OUT(30),rel(1,1),work1(24) 84 : ENDSEGMENT 85 : * 86 : SEGMENT,MVELCH 87 : REAL*8 VALMAT(NV1) 88 : ENDSEGMENT 89 : * 90 : SEGMENT MPTVAL 91 : INTEGER IPOS(NS) ,NSOF(NS) 92 : INTEGER IVAL(NCOSOU) 93 : CHARACTER*16 TYVAL(NCOSOU) 94 : ENDSEGMENT 95 : * 96 : DIMENSION CRIGI(12),CMASS(12) 97 : CHARACTER*4 CMOT 98 : CHARACTER*8 CMATE 99 : * 100 : * INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT 101 : * EN DEFORMATION PLANE GENERALISEE 102 : * 103 : IF (IFOUR.EQ.-3) THEN 104 : IP=IIPDPG 105 : SEGACT MCOORD 106 : IREF=(IP-1)*(IDIM+1) 107 : XDPGE=XCOOR(IREF+1) 108 : YDPGE=XCOOR(IREF+2) 109 : ELSE 110 : XDPGE=0.D0 111 : YDPGE=0.D0 112 : ENDIF 113 : * 114 : MELEME=IPMAIL 115 : NBNN=NUM(/1) 116 : NBELEM=NUM(/2) 117 : * 118 : NV1=NMATT 119 : SEGINI,MVELCH 120 : * 121 : NHRM=NIFOUR 122 : MINTE=IPMINT 123 : * 124 : IRTD=1 125 : NBBB=NBNN 126 : SEGINI WRK1 127 : C_______________________________________________________________________ 128 : C 129 : C NUMERO DES ETIQUETTES : 130 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 131 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 132 : C 5 CONTINUE 133 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 134 : C 44 CONTINUE 135 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 136 : C_______________________________________________________________________ 137 : C 138 : IF (MELE.LE.100) 139 : &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 140 : 1 99,99,99,99,99,99,99,99,29,30,99,99,99,99,99,99,99,99,99,99, 141 : 2 99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99, 142 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 143 : 4 99,99,99,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99 144 : 5 ),MELE 145 : IF (MELE.LE.200) 146 : &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 147 : 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 148 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 149 : 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 150 : 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 151 : 5 34),MELE-100 152 : IF (MELE.LE.300) 153 : &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 154 : 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 155 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,258,34, 156 : 3 260,34,34,34,34,265),MELE-200 157 : C 158 : 34 CONTINUE 159 : C 160 : GOTO 99 161 : C_______________________________________________________________________ 162 : CC 163 : C____________________________________________________________________ 164 : C 165 : C ELEMENTS POUTRES TUYAUX 166 : C____________________________________________________________________ 167 : C 168 : 29 CONTINUE 169 : SEGINI WRK3 170 : C 171 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 172 : C 173 : DO 3029 IB=1,NBELEM 174 : C 175 : C ON CHERCHE LES DEPLACEMENTS 176 : C 177 : IE=1 178 : NCARR1=NCARR 179 : IF(IVECT.EQ.1) NCARR1=NCARR-1 179 : CALL ZERO(WORK,NCARR1,1) 180 : DO 4029 IGAU=1,NBNN 181 : MPTVAL=IVADEP 182 : DO 4039 ICOMP=1,NDEP 183 : MELVAL=IVAL(ICOMP) 184 : IGMN=MIN(IGAU,VELCHE(/1)) 185 : IBMN=MIN(IB ,VELCHE(/2)) 186 : XDDL(IE)=VELCHE(IGMN,IBMN) 187 : IE=IE+1 188 : 4039 CONTINUE 189 : C 190 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 191 : C 191 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 192 : C 193 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 194 : C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION 195 : C 196 : MPTVAL=IVACAR 197 : DO 6029 IC=1,NCARR1 198 : IF (IVAL(IC).NE.0) THEN 199 : MELVAL=IVAL(IC) 200 : IBMN=MIN(IB,VELCHE(/2)) 201 : IGMN=MIN(IGAU,VELCHE(/1)) 202 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 203 : ELSE 204 : WORK(IC)=0.D0 205 : ENDIF 206 : C 207 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 208 : 6029 CONTINUE 209 : 4029 CONTINUE 210 : C 211 : C CAS OU ON A LU LE MOT VECTEUR 212 : C 213 : C 214 : IF ((IVECT.EQ.1).AND.(IFOUR.EQ.2)) THEN 215 : C 216 : IF (IVAL(NCARR).NE.0) THEN 217 : MELVAL=IVAL(NCARR) 218 : IBMN=MIN(IB,IELCHE(/2)) 219 : IP=IELCHE(1,IBMN) 220 : IREF=(IP-1)*(IDIM+1) 221 : DO 6129 IC=1,IDIM 222 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 223 : 6129 CONTINUE 224 : ELSE 225 : DO 6229 IC=1,IDIM 226 : WORK(NCARR+IC-1)=0.D0 227 : 6229 CONTINUE 228 : ENDIF 229 : ENDIF 230 : C 231 : C TRAITEMENT DU MATERIAU 232 : C 233 : MPTVAL=IVAMAT 234 : MELVAL=IVAL(1) 235 : * 236 : IF(CMATE.NE.'SECTION') THEN 237 : IBMN=MIN(IB,VELCHE(/2)) 238 : YOUNG=VELCHE(1,IBMN) 239 : C 240 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA 241 : C 242 : IF(MELE.EQ.42) THEN 243 : PRES=WORK(4) 244 : CISA=WORK(5) 245 : WORK(4)=WORK(6) 246 : WORK(5)=WORK(7) 247 : WORK(6)=WORK(8) 248 : WORK(7)=PRES 249 : WORK(8)=CISA 249 : CALL TUYKAR(WORK,KERRE,2,YOUNG) 250 : ENDIF 251 : IF (KERRE.EQ.77) THEN 251 : CALL ERREUR(77) 252 : GOTO 510 253 : ENDIF 254 : C 255 : C ON CHERCHE LES COEFF DES MAT DE HOOKE 256 : C 257 : MPTVAL=IVAMAT 258 : IF(IMAT.EQ.2) THEN 259 : MELVAL=IVAL(1) 260 : IBMN=MIN(IB ,IELCHE(/2)) 261 : MLREEL=IELCHE(1,IBMN) 262 : SEGACT MLREEL 263 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 263 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 264 : SEGDES MLREEL 265 : C------------- 266 : C PROVISOIRE 267 : C------------- 268 : * 269 : C 270 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 271 : C 272 : WORK(4)=DDHOOK(1,1)/WORK(1) 273 : WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1))) 274 : ELSE 275 : WORK(10)=DDHOOK(1,1)/WORK(4) 276 : WORK(11)=DDHOOK(4,4)/WORK(1) 277 : ENDIF 278 : ELSE IF (IMAT.EQ.1) THEN 279 : * 280 : DO 9029 IM=1,NMATT 281 : IF (IVAL(IM).NE.0) THEN 282 : MELVAL=IVAL(IM) 283 : IBMN=MIN(IB ,VELCHE(/2)) 284 : VALMAT(IM)=VELCHE(1,IBMN) 285 : ELSE 286 : VALMAT(IM)=0.D0 287 : ENDIF 288 : 9029 CONTINUE 289 : IF(MELE.EQ.84) THEN 290 : C 291 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 291 : CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 292 : ELSE 293 : C 293 : CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 294 : ENDIF 295 : ELSE 296 : C 297 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 297 : CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 298 : ELSE 299 : C 299 : CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 300 : ENDIF 301 : ENDIF 302 : C------------- 303 : C PROVISOIRE 304 : C------------- 305 : C 306 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 307 : WORK(4)=VALMAT(1) 308 : AUX=VALMAT(2) 309 : WORK(5)=WORK(4)*0.5D0/(1.D0+AUX) 310 : ELSE 311 : C 312 : WORK(10)=VALMAT(1) 313 : AUX=VALMAT(2) 314 : WORK(11)=WORK(10)*0.5D0/(1.D0+AUX) 315 : ENDIF 316 : C------------- 317 : ENDIF 318 : * 319 : * CAS DE LA FORMULATION SECTION 320 : * 321 : ELSE 322 : IF(IMAT.EQ.2) THEN 323 : MELVAL=IVAL(1) 324 : IBMN=MIN(IB ,IELCHE(/2)) 325 : MLREEL=IELCHE(1,IBMN) 326 : SEGACT MLREEL 327 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 327 : $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 328 : SEGDES MLREEL 329 : ELSE IF (IMAT.EQ.1) THEN 330 : * 331 : * ON REGARDE SI ON A LA COMPOSANTE MAHO 332 : * SI OUI, ON LA PREND 333 : * 334 : IF(IVAL(3).NE.0) THEN 335 : MELVAL=IVAL(3) 336 : IBMN=MIN(IB ,IELCHE(/2)) 337 : MLREEL=IELCHE(1,IBMN) 338 : SEGACT MLREEL 339 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 339 : $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 340 : SEGDES MLREEL 341 : ELSE 342 : IBMN=MIN(IB,IELCHE(/2)) 343 : IPMODL=IELCHE(1,IBMN) 344 : MELVAL=IVAL(2) 345 : IBMN=MIN(IB,IELCHE(/2)) 346 : IPMAT=IELCHE(1,IBMN) 346 : CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) 347 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 347 : $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 348 : ENDIF 349 : ENDIF 350 : ENDIF 351 : C 352 : C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS 353 : C 354 : IF(MELE.EQ.84) THEN 355 : IF(CMATE.NE.'SECTION') THEN 356 : C 357 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 357 : CALL TIMST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) 358 : ELSE 359 : C 359 : CALL TIMSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) 360 : ENDIF 361 : ELSE 362 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 362 : CALL TIFST2(XE,XDDL,LHOOK,DDHOOK, 363 : $ WORK(12),WORK(25),IREPS2) 364 : ELSE 364 : CALL TIFSTR(XE,XDDL,LHOOK,DDHOOK,WORK, 365 : $ WORK(12),WORK(25),IREPS2) 366 : ENDIF 367 : ENDIF 368 : ELSE 369 : C 370 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 370 : CALL POUST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) 371 : ELSE 372 : C 372 : CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) 373 : ENDIF 374 : ENDIF 375 : C 376 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 377 : C 378 : ID=12 379 : DO 7029 IGAU=1,NBPTEL 380 : MPTVAL=IVASTR 381 : DO 7029 ICOMP=1,NSTRS 382 : MELVAL=IVAL(ICOMP) 383 : IBMN=MIN(IB ,VELCHE(/2)) 384 : VELCHE(IGAU,IBMN)=WORK(ID) 385 : ID=ID+1 386 : 7029 CONTINUE 387 : C 388 : 3029 CONTINUE 389 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 390 : MOTERR(1:8)=CMATE 391 : MOTERR(9:12)=NOMFR(MFR/2+1) 392 : INTERR(1)=IFOUR 392 : CALL ERREUR(81) 393 : ENDIF 394 : SEGSUP MVELCH,WRK1,WRK3 395 : GOTO 510 396 : C____________________________________________________________________ 397 : C 398 : C ELEMENT LINESPRING LISP ET LISM 399 : C____________________________________________________________________ 400 : C 401 : 30 CONTINUE 402 : NSTR=NSTRS 403 : NSTRS=2 404 : C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1 405 : C 406 : SEGINI WRK3 407 : C 408 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELELEMTS 409 : C 410 : DO 3030 IB=1,NBELEM 411 : C 412 : C ON CHERCHE LES DEPLACEMENTS 413 : C 414 : IE=1 415 : DO 4030 IGAU=1,NBNN 416 : MPTVAL=IVADEP 417 : DO 4030 ICOMP=1,NDEP 418 : MELVAL=IVAL(ICOMP) 419 : IGMN=MIN(IGAU,VELCHE(/1)) 420 : IBMN=MIN(IB ,VELCHE(/2)) 421 : XDDL(IE)=VELCHE(IGMN,IBMN) 422 : IE=IE+1 423 : 4030 CONTINUE 424 : C 425 : C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE 426 : C 426 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 427 : C 428 : C ON CHERCHE LA MATRICE DE HOOKE 429 : C 430 : MPTVAL=IVAMAT 431 : IF(IMAT.EQ.2) THEN 432 : MELVAL=IVAL(1) 433 : IBMN=MIN(IB ,IELCHE(/2)) 434 : MLREEL=IELCHE(1,IBMN) 435 : SEGACT MLREEL 436 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 436 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 437 : SEGDES MLREEL 438 : ELSE IF (IMAT.EQ.1) THEN 439 : DO 9030 IM=1,NMATT 440 : IF (IVAL(IM).NE.0) THEN 441 : MELVAL=IVAL(IM) 442 : IBMN=MIN(IB ,VELCHE(/2)) 443 : VALMAT(IM)=VELCHE(1,IBMN) 444 : ELSE 445 : VALMAT(IM)=0.D0 446 : ENDIF 447 : 9030 CONTINUE 448 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 448 : 1 CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 449 : ENDIF 450 : C 451 : C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS 452 : C 453 : IE=1 454 : DO 7030 IC=1,3,2 455 : MPTVAL=IVACAR 456 : DO 7030 ICOMP=1,NCARR 457 : MELVAL=IVAL(ICOMP) 458 : IF (MELVAL.NE.0) THEN 459 : IGMN=MIN(IC,VELCHE(/1)) 460 : IBMN=MIN(IB,VELCHE(/2)) 461 : WORK(IE)=VELCHE(IGMN,IBMN) 462 : ELSE 463 : WORK(IE)=0.D0 464 : ENDIF 465 : IE=IE+1 466 : 7030 CONTINUE 467 : C 468 : C CALCUL DES CONTRAINTES 469 : C 469 : CALL LISPST(XE,WORK,DDHOOK,XDDL,WORK(11),NBPGAU,MELE,WORK(53), 470 : 1 I69,I70,I195,I157) 471 : C 472 : IF(I69.NE.0) THEN 472 : CALL ERREUR( 69) 473 : * RETURN 474 : ENDIF 475 : IF(I70.NE.0) THEN 475 : CALL ERREUR( 70) 476 : * RETURN 477 : ENDIF 478 : IF(I195.NE.0) THEN 478 : CALL ERREUR( 195) 479 : * RETURN 480 : ENDIF 481 : IF(I157.NE.0) THEN 481 : CALL ERREUR( 157) 482 : * RETURN 483 : ENDIF 484 : IE=1 485 : DO 8030 IGAU=1,NBPTEL 486 : MPTVAL=IVASTR 487 : DO 8030 ICOMP=1,NSTR 488 : MELVAL=IVAL(ICOMP) 489 : IBMN=MIN(IB ,VELCHE(/2)) 490 : VELCHE(IGAU,IBMN)=WORK(52+IE) 491 : IE=IE+1 492 : 8030 CONTINUE 493 : 3030 CONTINUE 494 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 495 : MOTERR(1:8)=CMATE 496 : MOTERR(9:12)=NOMFR(MFR/2+1) 497 : INTERR(1)=IFOUR 497 : CALL ERREUR(81) 498 : ENDIF 499 : SEGSUP MVELCH,WRK1,WRK3 500 : GOTO 510 501 : C____________________________________________________________________ 502 : C____________________________________________________________________ 503 : C 504 : C ELEMENT TUYAU FISSURE 505 : C____________________________________________________________________ 506 : C 507 : 43 CONTINUE 508 : C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1 509 : C 510 : SEGINI WRK3 511 : C 512 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 513 : C 514 : DO 3043 IB=1,NBELEM 515 : C 516 : C ON CHERCHE LES DEPLACEMENTS 517 : C 518 : IE=1 519 : DO 4043 IGAU=1,NBNN 520 : MPTVAL=IVADEP 521 : DO 4043 ICOMP=1,NDEP 522 : MELVAL=IVAL(ICOMP) 523 : IGMN=MIN(IGAU,VELCHE(/1)) 524 : IBMN=MIN(IB ,VELCHE(/2)) 525 : XDDL(IE)=VELCHE(IGMN,IBMN) 526 : IE=IE+1 527 : 4043 CONTINUE 528 : C 529 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 530 : C 530 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 531 : C 532 : C ON CHERCHE LES CARACTERISTIQUES 533 : C 534 : MPTVAL=IVACAR 535 : DO 7043 IC=1,9 536 : MELVAL=IVAL(IC) 537 : IF (MELVAL.NE.0) THEN 538 : IBMN=MIN(IB,VELCHE(/2)) 539 : WORK(IC)=VELCHE(1,IBMN) 540 : ELSE 541 : WORK(IC)=0.D0 542 : ENDIF 543 : 7043 CONTINUE 544 : C 545 : C ON CHERCHE LES COEFF DES MAT DE HOOKE 546 : C 547 : MPTVAL=IVAMAT 548 : IF(IMAT.EQ.2) THEN 549 : MELVAL=IVAL(1) 550 : IBMN=MIN(IB ,IELCHE(/2)) 551 : MLREEL=IELCHE(1,IBMN) 552 : SEGACT MLREEL 553 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 553 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 554 : SEGDES MLREEL 555 : ELSE IF (IMAT.EQ.1) THEN 556 : DO 9043 IM=1,NMATT 557 : IF (IVAL(IM).NE.0) THEN 558 : MELVAL=IVAL(IM) 559 : IBMN=MIN(IB ,VELCHE(/2)) 560 : VALMAT(IM)=VELCHE(1,IBMN) 561 : ELSE 562 : VALMAT(IM)=0.D0 563 : ENDIF 564 : 9043 CONTINUE 565 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 565 : 1 CALL DOHFIS1(VALMAT,WORK(1),CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 566 : ENDIF 567 : C 568 : C ON CALCULE LES CONTRAINTES 569 : C 569 : CALL TUFIST(VALMAT,XDDL,WORK(1),DDHOOK,WORK(10), 570 : 1 WORK(20),WORK(31),I137) 571 : IF(I137.NE.0) INTERR(1)=ISOUS 572 : IF(I137.NE.0) INTERR(2)=IB 573 : C 574 : MPTVAL=IVASTR 575 : DO 6043 ICOMP=1,8 576 : MELVAL=IVAL(ICOMP) 577 : IBMN=MIN(IB,VELCHE(/2)) 578 : VELCHE(1,IBMN)=WORK(30+ICOMP) 579 : 6043 CONTINUE 580 : C 581 : 3043 CONTINUE 581 : IF(I137.EQ.1) CALL ERREUR(137) 581 : IF(I137.EQ.2) CALL ERREUR(123) 581 : IF(I137.EQ.3) CALL ERREUR(266) 582 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 583 : MOTERR(1:8)=CMATE 584 : MOTERR(9:12)=NOMFR(MFR/2+1) 585 : INTERR(1)=IFOUR 585 : CALL ERREUR(81) 586 : ENDIF 587 : SEGSUP MVELCH,WRK1,WRK3 588 : GOTO 510 589 : C____________________________________________________________________ 590 : C 591 : C ELEMENT POINT (POI1) 592 : C____________________________________________________________________ 593 : C 594 : 45 CONTINUE 595 : * 596 : IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN 597 : GO TO 99 598 : ENDIF 599 : * 600 : SEGINI WRK3 601 : C 602 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 603 : C 604 : DO 3045 IB=1,NBELEM 605 : C 606 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 607 : C 607 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 608 : C 609 : C ON CALCULE LES DEFORMATIONS 610 : C 610 : CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK) 611 : C 612 : MPTVAL=IVACAR 613 : MELVAL=IVAL(1) 614 : IF (MELVAL.NE.0) THEN 615 : IBMN=MIN(IB,VELCHE(/2)) 616 : SECT=VELCHE(1,IBMN) 617 : ELSE 617 : CALL ERREUR(5) 618 : GO TO 3045 619 : ENDIF 620 : C 621 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 622 : C 623 : MPTVAL=IVADEP 624 : MPTVAL=IVAMAT 625 : IF(IMAT.EQ.2) THEN 626 : MELVAL=IVAL(1) 627 : IBMN=MIN(IB ,IELCHE(/2)) 628 : MLREEL=IELCHE(1,IBMN) 629 : SEGACT MLREEL 630 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 630 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 631 : SEGDES MLREEL 632 : ELSE IF (IMAT.EQ.1) THEN 633 : DO 9045 IM=1,NMATT 634 : IF (IVAL(IM).NE.0) THEN 635 : MELVAL=IVAL(IM) 636 : IBMN=MIN(IB ,VELCHE(/2)) 637 : VALMAT(IM)=VELCHE(1,IBMN) 638 : ELSE 639 : VALMAT(IM)=0.D0 640 : ENDIF 641 : 9045 CONTINUE 641 : CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) 642 : ENDIF 643 : MPTVAL=IVADEP 644 : C 645 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 646 : C 647 : ID=1 648 : DO 7045 IGAU=1,NBPTEL 649 : MPTVAL=IVASTR 650 : DO 7045 ICOMP=1,NSTRS 651 : MELVAL=IVAL(ICOMP) 652 : IBMN=MIN(IB ,VELCHE(/2)) 653 : VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1) 654 : ID=ID+1 655 : 7045 CONTINUE 656 : MPTVAL=IVADEP 657 : C 658 : 3045 CONTINUE 659 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 660 : MOTERR(1:8)=CMATE 661 : MOTERR(9:12)=NOMFR(MFR/2+1) 662 : INTERR(1)=IFOUR 662 : CALL ERREUR(81) 663 : ENDIF 664 : SEGSUP MVELCH,WRK1,WRK3 665 : GOTO 510 666 : C____________________________________________________________________ 667 : C 668 : C BARRE ET CERCE 669 : C____________________________________________________________________ 670 : C 671 : 46 CONTINUE 672 : * 673 : IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN 674 : GO TO 99 675 : ENDIF 676 : * 677 : SEGINI WRK3 678 : C 679 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 680 : C 681 : DO 3046 IB=1,NBELEM 682 : KERRE=0 683 : C 684 : C ON CHERCHE LES DEPLACEMENTS 685 : C 686 : NDDD=NDEP 687 : IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3 688 : IE=1 689 : DO 4046 IGAU=1,NBNN 690 : MPTVAL=IVADEP 691 : DO 4046 ICOMP=1,NDDD 692 : MELVAL=IVAL(ICOMP) 693 : IGMN=MIN(IGAU,VELCHE(/1)) 694 : IBMN=MIN(IB ,VELCHE(/2)) 695 : XDDL(IE)=VELCHE(IGMN,IBMN) 696 : IE=IE+1 697 : 4046 CONTINUE 698 : C 699 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 700 : C 700 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 701 : C 702 : C ON CALCULE LES DEFORMATIONS 703 : C 703 : IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2) 703 : IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE) 703 : IF(MELE.EQ.123)CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,NBPGAU,IB) 704 : IF(KERRE.NE.0) THEN 704 : CALL ERREUR(601) 705 : GO TO 3046 706 : ENDIF 707 : MPTVAL=IVACAR 708 : MELVAL=IVAL(1) 709 : IF (MELVAL.NE.0) THEN 710 : IBMN=MIN(IB,VELCHE(/2)) 711 : SECT=VELCHE(1,IBMN) 712 : ELSE 712 : CALL ERREUR(5) 713 : GO TO 3046 714 : ENDIF 715 : C 716 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 717 : C 718 : MPTVAL=IVADEP 719 : MPTVAL=IVAMAT 720 : IF(IMAT.EQ.2) THEN 721 : MELVAL=IVAL(1) 722 : IBMN=MIN(IB ,IELCHE(/2)) 723 : MLREEL=IELCHE(1,IBMN) 724 : SEGACT MLREEL 725 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 725 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 726 : SEGDES MLREEL 727 : ELSE IF (IMAT.EQ.1) THEN 728 : DO 9046 IM=1,NMATT 729 : IF (IVAL(IM).NE.0) THEN 730 : MELVAL=IVAL(IM) 731 : IBMN=MIN(IB ,VELCHE(/2)) 732 : VALMAT(IM)=VELCHE(1,IBMN) 733 : ELSE 734 : VALMAT(IM)=0.D0 735 : ENDIF 736 : 9046 CONTINUE 736 : CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) 737 : ENDIF 738 : MPTVAL=IVADEP 739 : C 740 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 741 : C 742 : ID=1 743 : DO 7046 IGAU=1,NBPTEL 744 : MPTVAL=IVASTR 745 : DO 7046 ICOMP=1,NSTRS 746 : MELVAL=IVAL(ICOMP) 747 : IBMN=MIN(IB ,VELCHE(/2)) 748 : VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1) 749 : ID=ID+1 750 : 7046 CONTINUE 751 : MPTVAL=IVADEP 752 : C 753 : 3046 CONTINUE 754 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 755 : MOTERR(1:8)=CMATE 756 : MOTERR(9:12)=NOMFR(MFR/2+1) 757 : INTERR(1)=IFOUR 757 : CALL ERREUR(81) 758 : ENDIF 758 : IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601) 759 : SEGSUP MVELCH,WRK1,WRK3 760 : GOTO 510 761 : C 762 : C____________________________________________________________________ 763 : C 764 : C ELEMENT BARRE 3D EXCENTRE (BAEX) 765 : C____________________________________________________________________ 766 : C 767 : 124 CONTINUE 768 : NBBB=NBNN 769 : NSTN=NBNN 770 : LRN =LRE 771 : SEGINI WRK1,WRK3,WRK5 772 : C 773 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 774 : C 775 : DO 3108 IB=1,NBELEM 776 : C 777 : C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON 778 : C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK 779 : C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ 780 : C 781 : MPTVAL=IVACAR 782 : DO IC=1,NCARR 783 : IF(IVAL(IC).NE.0) THEN 784 : MELVAL=IVAL(IC) 785 : IBMN=MIN(IB,VELCHE(/2)) 786 : WORK(IC)=VELCHE(1,IBMN) 787 : ELSE 788 : WORK(IC)=0.D0 789 : ENDIF 790 : END DO 791 : SECT=WORK(1) 792 : C 793 : C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE 794 : C 794 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 794 : CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE) 795 : IF(KERRE.NE.0) INTERR(1)=ISOUS 796 : IF(KERRE.NE.0) INTERR(2)=IB 796 : IF(KERRE.EQ.1) CALL ERREUR(128) 797 : C 798 : C ON CHERCHE LES DEPLACEMENTS 799 : C 800 : IE=1 801 : DO 4108 IGAU=1,NBNN 802 : MPTVAL=IVADEP 803 : DO 4108 ICOMP=1,NDEP 804 : MELVAL=IVAL(ICOMP) 805 : IGMN=MIN(IGAU,VELCHE(/1)) 806 : IBMN=MIN(IB ,VELCHE(/2)) 807 : XDDL(IE)=VELCHE(IGMN,IBMN) 808 : IE=IE+1 809 : 4108 CONTINUE 810 : C 811 : C ON CALCULE LES DEFORMATIONS 812 : C 812 : CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE) 813 : C 814 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 815 : C 816 : MPTVAL=IVAMAT 817 : IF(IMAT.EQ.2) THEN 818 : MELVAL=IVAL(1) 819 : IBMN=MIN(IB ,IELCHE(/2)) 820 : MLREEL=IELCHE(1,IBMN) 821 : SEGACT MLREEL 821 : IF(IB.LE.NELMAT.OR.NBGMAT.GT.1) CALL DOHOOO(PROG,LHOOK,DDHOOK) 822 : SEGDES MLREEL 823 : ELSE IF (IMAT.EQ.1) THEN 824 : DO 9124 IM=1,NMATT 825 : IF (IVAL(IM).NE.0) THEN 826 : MELVAL=IVAL(IM) 827 : IBMN=MIN(IB ,VELCHE(/2)) 828 : VALMAT(IM)=VELCHE(1,IBMN) 829 : ELSE 830 : VALMAT(IM)=0.D0 831 : ENDIF 832 : 9124 CONTINUE 832 : CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD) 833 : ENDIF 834 : C 835 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 836 : C 837 : ID=1 838 : DO 7108 IGAU=1,NBPTEL 839 : MPTVAL=IVASTR 840 : DO 7108 ICOMP=1,NSTRS 841 : MELVAL=IVAL(ICOMP) 842 : IBMN=MIN(IB ,VELCHE(/2)) 843 : VELCHE(IGAU,IBMN)=XSTRS(ID)*DDHOOK(1,1) 844 : ID=ID+1 845 : 7108 CONTINUE 846 : C 847 : 3108 CONTINUE 848 : SEGSUP WRK1,WRK3,WRK5,MVELCH 849 : GOTO 510 850 : C_______________________________________________________________________ 851 : C 852 : C LIA2 : element de liaison a 2 noeuds (6 ddl par 853 : C noeuds) 854 : C_______________________________________________________________________ 855 : C 856 : 125 CONTINUE 857 : NBBB=NBNN 858 : NSTN=3 859 : LRN =3 860 : SEGINI WRK1,WRK3,WRK5 861 : C 862 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 863 : C 864 : DO 3109 IB=1,NBELEM 865 : C 866 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 867 : C 868 : MPTVAL=IVACAR 869 : DO IC=1,NCARR 870 : IF(IVAL(IC).NE.0) THEN 871 : MELVAL=IVAL(IC) 872 : IBMN=MIN(IB,VELCHE(/2)) 873 : WORK(IC)=VELCHE(1,IBMN) 874 : ELSE 875 : WORK(IC)=0.D0 876 : ENDIF 877 : END DO 878 : C 878 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 878 : CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE) 879 : IF(KERRE.NE.0) INTERR(1)=ISOUS 880 : IF(KERRE.NE.0) INTERR(2)=IB 880 : IF(KERRE.EQ.1) CALL ERREUR(128) 881 : C 882 : C ON CHERCHE LES DEPLACEMENTS 883 : C 884 : IE=1 885 : DO 4109 IGAU=1,NBNN 886 : MPTVAL=IVADEP 887 : DO 4109 ICOMP=1,NDEP 888 : MELVAL=IVAL(ICOMP) 889 : IGMN=MIN(IGAU,VELCHE(/1)) 890 : IBMN=MIN(IB ,VELCHE(/2)) 891 : XDDL(IE)=VELCHE(IGMN,IBMN) 892 : IE=IE+1 893 : 4109 CONTINUE 894 : C 895 : C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U) 896 : C 896 : CALL SIGLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS) 897 : C 898 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 899 : C 900 : ID=1 901 : DO 7109 IGAU=1,NBPTEL 902 : MPTVAL=IVASTR 903 : DO 7109 ICOMP=1,NSTRS 904 : MELVAL=IVAL(ICOMP) 905 : IBMN=MIN(IB ,VELCHE(/2)) 906 : VELCHE(IGAU,IBMN)=XSTRS(ID) 907 : ID=ID+1 908 : 7109 CONTINUE 909 : C 910 : 3109 CONTINUE 911 : SEGSUP MVELCH,WRK1,WRK3,WRK5 912 : GOTO 510 913 : C_______________________________________________________________________ 914 : C 915 : C JOI1 : element de liaison a 2 noeuds (6 ddl par 916 : C noeuds) 917 : C_______________________________________________________________________ 918 : C 919 : 265 CONTINUE 920 : NBBB=NBNN 921 : NSTN=3 922 : LRN =3 923 : SEGINI WRK1,WRK3,WRK2 924 : C 925 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 926 : C 927 : DO 3110 IB=1,NBELEM 928 : C 929 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 930 : C 931 : MPTVAL=IVAMAT 932 : DO IC=1,NMATT 933 : IF(IVAL(IC).NE.0) THEN 934 : MELVAL=IVAL(IC) 935 : IBMN=MIN(IB,VELCHE(/2)) 936 : WORK(IC)=VELCHE(1,IBMN) 937 : ELSE 938 : WORK(IC)=0.D0 939 : ENDIF 940 : END DO 941 : C 941 : CALL MAPALU(NMATT,WORK,BPSS,IDIM) 942 : C 943 : C ON CHERCHE LES DEPLACEMENTS 944 : C 945 : IE=1 946 : DO 4110 IGAU=1,NBNN 947 : MPTVAL=IVADEP 948 : DO 4110 ICOMP=1,NDEP 949 : MELVAL=IVAL(ICOMP) 950 : IGMN=MIN(IGAU,VELCHE(/1)) 951 : IBMN=MIN(IB ,VELCHE(/2)) 952 : XDDL(IE)=VELCHE(IGMN,IBMN) 953 : IE=IE+1 954 : 4110 CONTINUE 955 : C 956 : C CALCUL DES DEPLACEMENTS LOCAUX 957 : C 958 : IAW1 = 101 959 : IAW2 = IAW1 + LRE 959 : CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) 960 : C 961 : C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U) 962 : C 962 : CALL ZERO(XSTRS,NSTRS,1) 963 : * 963 : CALL SIGJOI(NMATT,XDDL,WORK,LRE,XSTRS,IDIM,NSTRS,CMATE) 964 : C 965 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 966 : C 967 : ID=1 968 : DO 7110 IGAU=1,NBPTEL 969 : MPTVAL=IVASTR 970 : DO 7110 ICOMP=1,NSTRS 971 : MELVAL=IVAL(ICOMP) 972 : IBMN=MIN(IB ,VELCHE(/2)) 973 : VELCHE(IGAU,IBMN)=XSTRS(ID) 974 : ID=ID+1 975 : 7110 CONTINUE 976 : C 977 : 3110 CONTINUE 978 : SEGSUP MVELCH,WRK1,WRK3,WRK2 979 : GOTO 510 980 : C____________________________________________________________________ 981 : C 982 : C ELEMENT TUYO 983 : C____________________________________________________________________ 984 : C 985 : 96 CONTINUE 986 : SEGINI WRK3 987 : C 988 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 989 : C 990 : DO 3096 IB=1,NBELEM 991 : C 992 : C ON CHERCHE LES DEPLACEMENTS 993 : C 994 : IE=1 995 : DO 4096 IGAU=1,NBNN 996 : MPTVAL=IVADEP 997 : DO 4096 ICOMP=1,NDEP 998 : MELVAL=IVAL(ICOMP) 999 : IGMN=MIN(IGAU,VELCHE(/1)) 1000 : IBMN=MIN(IB ,VELCHE(/2)) 1001 : XDDL(IE)=VELCHE(IGMN,IBMN) 1002 : IE=IE+1 1003 : 4096 CONTINUE 1004 : C 1005 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1006 : C 1006 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1007 : C 1008 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 1009 : C 1010 : MPTVAL=IVACAR 1011 : DO 6096 IC=1,NCARR 1012 : IF (IVAL(IC).NE.0) THEN 1013 : MELVAL=IVAL(IC) 1014 : IBMN=MIN(IB,VELCHE(/2)) 1015 : WORK(IC)=VELCHE(1,IBMN) 1016 : ELSE 1017 : WORK(IC)=0.D0 1018 : ENDIF 1019 : 6096 CONTINUE 1020 : C 1021 : C CAS OU ON A LU LE MOT VECTEUR 1022 : C 1023 : C 1024 : IF (IVECT.EQ.1) THEN 1025 : IF (IVAL(NCARR).NE.0) THEN 1026 : MELVAL=IVAL(NCARR) 1027 : IBMN=MIN(IB,IELCHE(/2)) 1028 : IP=IELCHE(1,IBMN) 1029 : IREF=(IP-1)*(IDIM+1) 1030 : DO 6196 IC=1,IDIM 1031 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 1032 : 6196 CONTINUE 1033 : ELSE 1034 : DO 6296 IC=1,IDIM 1035 : WORK(NCARR+IC-1)=0.D0 1036 : 6296 CONTINUE 1037 : ENDIF 1038 : C 1039 : C CAS DU CHAMELEM COMVERTI 1040 : C 1041 : ELSE IF (IVECT.EQ.2) THEN 1042 : DO 6496 IC=1,IDIM 1043 : MELVAL=IVAL(NCARR+IC-3) 1044 : IF (MELVAL.NE.0) THEN 1045 : IBMN=MIN(IB,VELCHE(/2)) 1046 : WORK(NCARR+IC-3)=VELCHE(1,IBMN) 1047 : ELSE 1048 : WORK(NCARR+IC-3)=0.D0 1049 : ENDIF 1050 : 6496 CONTINUE 1051 : ENDIF 1052 : C 1053 : MPTVAL=IVAMAT 1054 : MELVAL=IVAL(1) 1055 : IBMN=MIN(IB,VELCHE(/2)) 1056 : YOUNG=VELCHE(1,IBMN) 1057 : C 1058 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA 1059 : C 1060 : IF(MELE.EQ.42) THEN 1061 : PRES=WORK(4) 1062 : WORK(4)=WORK(5) 1063 : WORK(5)=WORK(6) 1064 : WORK(6)=WORK(7) 1065 : WORK(7)=PRES 1065 : CALL TUYKAR(WORK,KERRE,2,YOUNG) 1066 : ENDIF 1067 : IF (KERRE.EQ.77) THEN 1067 : CALL ERREUR(77) 1068 : GOTO 510 1069 : ENDIF 1070 : C 1071 : C ON CHERCHE LES COEFF DES MAT DE HOOKE 1072 : C 1073 : MPTVAL=IVAMAT 1074 : IF(IMAT.EQ.2) THEN 1075 : MELVAL=IVAL(1) 1076 : IBMN=MIN(IB ,IELCHE(/2)) 1077 : MLREEL=IELCHE(1,IBMN) 1078 : SEGACT MLREEL 1079 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 1079 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1080 : SEGDES MLREEL 1081 : C------------- 1082 : C PROVISOIRE 1083 : C------------- 1084 : WORK(10)=DDHOOK(1,1)/WORK(4) 1085 : WORK(11)=DDHOOK(2,2)/WORK(5) 1086 : ELSE IF (IMAT.EQ.1) THEN 1087 : * 1088 : DO 9096 IM=1,NMATT 1089 : IF (IVAL(IM).NE.0) THEN 1090 : MELVAL=IVAL(IM) 1091 : IBMN=MIN(IB ,VELCHE(/2)) 1092 : VALMAT(IM)=VELCHE(1,IBMN) 1093 : ELSE 1094 : VALMAT(IM)=0.D0 1095 : ENDIF 1096 : 9096 CONTINUE 1096 : CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 1097 : C------------- 1098 : C PROVISOIRE 1099 : C------------- 1100 : WORK(10)=VALMAT(1) 1101 : AUX=VALMAT(2) 1102 : WORK(11)=WORK(10)*0.5D0/(1.D0+AUX) 1103 : C------------- 1104 : ENDIF 1105 : C 1106 : C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS 1107 : C 1107 : CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2) 1108 : C 1109 : C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES 1110 : C 1111 : ID=12 1112 : DO 7096 IGAU=1,NBPTEL 1113 : MPTVAL=IVASTR 1114 : DO 7096 ICOMP=1,NSTRS 1115 : MELVAL=IVAL(ICOMP) 1116 : IBMN=MIN(IB ,VELCHE(/2)) 1117 : VELCHE(IGAU,IBMN)=WORK(ID) 1118 : ID=ID+1 1119 : 7096 CONTINUE 1120 : C 1121 : 3096 CONTINUE 1122 : IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN 1123 : MOTERR(1:8)=CMATE 1124 : MOTERR(9:12)=NOMFR(MFR/2+1) 1125 : INTERR(1)=IFOUR 1125 : CALL ERREUR(81) 1126 : ENDIF 1127 : SEGSUP MVELCH,WRK1,WRK3 1128 : GOTO 510 1129 : 1130 : c_______________________________________________________________________ 1131 : c 1132 : c ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION 1133 : c____________________________________________________________________ 1134 : c 1135 : 258 CONTINUE 1136 : NBNO=NBNN 1137 : SEGINI WRK2,WRK3 1138 : c 1139 : DO IB=1,NBELEM 1140 : C 1141 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB 1142 : C 1142 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1143 : C 1144 : C ON CHERCHE LES DEPLACEMENTS (UX1,UY1,RZ1,UX2,UY2,RZ2,UM,RM) 1145 : C 1146 : MPTVAL=IVADEP 1147 : MELVAL=IVAL(1) 1148 : XDDL(1)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1149 : XDDL(4)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1150 : MELVAL=IVAL(2) 1151 : XDDL(2)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1152 : XDDL(5)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1153 : MELVAL=IVAL(3) 1154 : XDDL(3)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1155 : XDDL(6)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1156 : MELVAL=IVAL(4) 1157 : XDDL(7)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1158 : MELVAL=IVAL(5) 1159 : XDDL(8)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2))) 1160 : C 1161 : C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX 1162 : C 1162 : CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE) 1163 : c 1164 : c matrice de hooke 1165 : c 1166 : MPTVAL=IVAMAT 1167 : IF(IMAT.EQ.2) THEN 1168 : MELVAL=IVAL(1) 1169 : IBMN=MIN(IB ,IELCHE(/2)) 1170 : MLREEL=IELCHE(1,IBMN) 1171 : SEGACT MLREEL 1172 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1172 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1173 : SEGDES MLREEL 1174 : ELSE IF (IMAT.EQ.1) THEN 1175 : C 1176 : DO IM=1,NMATT 1177 : IF (IVAL(IM).NE.0) THEN 1178 : MELVAL=IVAL(IM) 1179 : IBMN=MIN(IB ,VELCHE(/2)) 1180 : VALMAT(IM)=VELCHE(1,IBMN) 1181 : ELSE 1182 : VALMAT(IM)=0.D0 1183 : ENDIF 1184 : ENDDO 1185 : C 1186 : MPTVAL=IVACAR 1187 : DO IC=1,NCARR 1188 : IF (IVAL(IC).NE.0) THEN 1189 : MELVAL=IVAL(IC) 1190 : IBMN=MIN(IB,VELCHE(/2)) 1191 : WORK(IC)=VELCHE(1,IBMN) 1192 : ELSE 1193 : WORK(IC)=0.D0 1194 : ENDIF 1195 : ENDDO 1196 : C 1196 : CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 1197 : ENDIF 1198 : c 1199 : DDHOOK(1,1)=DDHOOK(1,1)/(XH/2) 1200 : DDHOOK(2,2)=DDHOOK(2,2)/(XH/2) 1201 : DDHOOK(3,3)=DDHOOK(3,3)/ XH 1202 : DDHOOK(4,4)=DDHOOK(4,4)/(XH/2) 1203 : DDHOOK(5,5)=DDHOOK(5,5)/(XH/2) 1203 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1204 : c 1205 : c 1206 : c remplissage du segment contenant les contraintes 1207 : c 1208 : MPTVAL=IVASTR 1209 : DO ICOMP=1,NSTRS 1210 : MELVAL=IVAL(ICOMP) 1211 : IBMN=MIN(IB ,VELCHE(/2)) 1212 : VELCHE(1,IBMN)=XSTRS(ICOMP) 1213 : ENDDO 1214 : ENDDO 1215 : C 1216 : IF(IRTD.EQ.0) THEN 1217 : MOTERR(1:8)=CMATE 1218 : MOTERR(9:12)=NOMFR(MFR/2+1) 1219 : INTERR(1)=IFOUR 1219 : CALL ERREUR(81) 1220 : ENDIF 1221 : SEGSUP MVELCH,WRK1,WRK2,WRK3 1222 : GOTO 510 1223 : C_______________________________________________________________________ 1224 : C 1225 : C ELEMENT DE COQUE VOLUMIQUE SHB8 1226 : C_______________________________________________________________________ 1227 : C 1228 : 260 CONTINUE 1229 : NBNO=NBNN 1230 : NBBB=NBNN 1231 : SEGINI WRK1,WRK7,MVELCH 1232 : C 1233 : C BOUCLE POUR TOUS LES ELEMENTS 1234 : C 1235 : DO IB=1,NBELEM 1236 : C 1237 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1238 : C 1238 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1239 : C 1240 : C on cherche les deplacements 1241 : C 1242 : MPTVAL=IVADEP 1243 : IE=1 1244 : DO IGAU=1,NBNN 1245 : MPTVAL=IVADEP 1246 : DO ICOMP=1,3 1247 : MELVAL=IVAL(ICOMP) 1248 : IGMN=MIN(IGAU,VELCHE(/1)) 1249 : IBMN=MIN(IB ,VELCHE(/2)) 1250 : WORK1(IE)=VELCHE(IGMN,IBMN) 1251 : IE=IE+1 1252 : enddo 1253 : enddo 1254 : MPTVAL=IVAMAT 1255 : DO 9070 IM=1,NMATT 1256 : IF (IVAL(IM).NE.0) THEN 1257 : MELVAL=IVAL(IM) 1258 : IBMN=MIN(IB ,VELCHE(/2)) 1259 : VALMAT(IM)=VELCHE(1,IBMN) 1260 : 1261 : ELSE 1262 : VALMAT(IM)=0.D0 1263 : 1264 : ENDIF 1265 : 9070 CONTINUE 1266 : 1267 : PROPEL(1)=VALMAT(1) 1268 : PROPEL(2)=VALMAT(2) 1269 : DO IM=3,12 1270 : PROPEL(IM)=VALMAT(1) 1271 : ENDDO 1272 : PROPEL(3)=ireps2 1273 : PROPEL(14)=VALMAT(1) 1274 : 1275 : C 1276 : C CALCUL DES CONTRAINTES 1277 : C 1277 : call SHB8 (7,XE,DDHOOK,PROPEL,WORK1,REL,OUT) 1278 : MPTVAL=IVASTR 1279 : IE=1 1280 : DO ICOMP=1,NSTRS 1281 : MELVAL=IVAL(ICOMP) 1282 : DO IBG=1,5 1283 : MELVAL=IVAL(ICOMP) 1284 : IBMN=MIN(IB ,VELCHE(/2)) 1285 : VELCHE(IBG,IBMN)=out(ICOMP+ (IBG-1)*NSTRS) 1286 : ENDDO 1287 : ENDDO 1288 : ENDDO 1289 : SEGSUP WRK1,WRK7,MVELCH 1290 : GO TO 510 1291 : *____________________________________________________________________ 1292 : 99 CONTINUE 1293 : SEGSUP MVELCH,WRK1 1294 : MOTERR(1:4)=NOMTP(MELE) 1295 : MOTERR(9:12)='SIGM' 1295 : CALL ERREUR(86) 1296 : * 1297 : 510 CONTINUE 1298 : RETURN 1299 : END 1300 : 1301 : 1302 : 1303 : 1304 : 1305 : 1306 : 1307 : 1308 : 1309 : 1310 : 1311 : 1312 : 1313 : 1314 : 1315 : 1316 :
© Cast3M 2003 - All rights reserved.
Disclaimer