1 : C SIGMA2 SOURCE AM 12/05/02 21:15:03 7364 2 : SUBROUTINE SIGMA2(IPMAIL,IVADEP,IVACAR,NELMAT,NBGMAT, 3 : & IVAMAT,LHOOK,IMAT,MATE,CMATE,NMATT,NSTRS,MFR,IPMINT, 4 : & IPMIN1,NDEP,NBPGAU,NBPTEL,MELE,LRE,LW,IREPS2,NPINT,IVASTR 5 : & ,UZDPG,RYDPG,RXDPG,IIPDPG) 6 : *---------------------------------------------------------------------* 7 : * __________________________ * 8 : * | | * 9 : * | calcul des contraintes| * 10 : * |________________________| * 11 : * * 12 : * coq3,dkt,coq4,coq8,coq2 ,dst,joint 3d,joints 2d * 13 : * * 14 : *---------------------------------------------------------------------* 15 : * * 16 : * entrees : * 17 : * ________ * 18 : * * 19 : * ipmail pointeur sur un segment meleme * 20 : * ivadep pointeur sur le chamelem de deplacements * 21 : * ivacar pointeur sur les chamelems de caracteristiques * 22 : * nelmat taille maxi des melval du materiau (no d'element) * 23 : * nbgmat taille maxi des melval du materiau (pt de gauss) * 24 : * ivamat pointeur sur un segment mptval pour le materiau ou * 25 : * lhook dimension de la matrice de hooke * 26 : * imat (2 il y a une matrice de hooke,1 non ) * 27 : * mate numero du materiau * 28 : * cmate nom du materiau * 29 : * nmatt nombre de composante de materiau (imat=1) * 30 : * nstrs nombre de composante de contraintes/deformations * 31 : * pour une matrice de hooke * 32 : * mfr numero de formulation de l'element fini * 33 : * ipmint pointeur sur un segment minte * 34 : * ipmin1 pointeur sur un segment minte (aux noeuds) * 35 : * ndep nombre de composantes de deplacements * 36 : * nbpgau nombre de point d'integration pour la rigidite * 37 : * nbptel nombre de points par element * 38 : * mele numero de l'element fini * 39 : * lre nombre de ddl dans la matrice de rigidite * 40 : * lw dimension du tableau de travail de l'element * 41 : * iresp2 flag pour indiquer si on veut les contraintes * 42 : * de piola-kirchhoff * 43 : * npint nombre de points d'integration dans l'epaisseur 44 : * dans le cas des elements de coque integres 45 : * * 46 : * sorties : * 47 : * ________ * 48 : * * 49 : * ivastr pointeur sur un segment mptval contenant les * 50 : * les melvals de contraints 51 : * * 52 : *---------------------------------------------------------------------* 53 : IMPLICIT INTEGER(I-N) 54 : IMPLICIT REAL*8(A-H,O-Z) 55 : * 56 : -INC CCOPTIO 57 : -INC CCHAMP 58 : -INC CCREEL 59 : -INC SMCHAML 60 : -INC SMINTE 61 : -INC SMELEME 62 : -INC SMCOORD 63 : -INC SMLREEL 64 : * 65 : SEGMENT WRK1 66 : REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS) 67 : REAL*8 XE(3,NBBB) ,DDHOMU(LHOOK,LHOOK) 68 : ENDSEGMENT 69 : * 70 : SEGMENT WRK2 71 : REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) 72 : ENDSEGMENT 73 : * 74 : SEGMENT WRK3 75 : REAL*8 WORK(LW) 76 : ENDSEGMENT 77 : * 78 : SEGMENT WRK4 79 : REAL*8 BPSS(3,3) ,XEL(3,NBBB) ,XDDLOC(LRE) 80 : ENDSEGMENT 81 : * 82 : SEGMENT WRK5 83 : REAL*8 XSTRS1(NSTRS1) 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 : CHARACTER*8 CMATE 97 : * 98 : * initialisation du point autour duquel se fait le mouvement 99 : * en deformation plane generalisee 100 : * 101 : IF (IFOUR.EQ.-3) THEN 102 : IP=IIPDPG 103 : SEGACT MCOORD 104 : IREF=(IP-1)*(IDIM+1) 105 : XDPGE=XCOOR(IREF+1) 106 : YDPGE=XCOOR(IREF+2) 107 : ELSE 108 : XDPGE=0.D0 109 : YDPGE=0.D0 110 : ENDIF 111 : * 112 : MELEME=IPMAIL 113 : NBNN=NUM(/1) 114 : NBELEM=NUM(/2) 115 : * 116 : NV1=NMATT 117 : SEGINI,MVELCH 118 : * 119 : NHRM=NIFOUR 120 : * 121 : MINTE=IPMINT 122 : IRTD=1 123 : * 124 : NBBB=NBNN 125 : SEGINI WRK1 126 : c_______________________________________________________________________ 127 : c 128 : c numero des etiquettes : 129 : c etiquettes de 1 a 98 pour traitement specifique a l element 130 : c dans la zone specifique a chaque element commencant par : 131 : c 5 continue 132 : c element 5 etiquettes 1005 2005 3005 4005 ... 133 : c 44 continue 134 : c element 44 etiquettes 1044 2044 3044 4044 ... 135 : c_______________________________________________________________________ 136 : c 137 : GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 138 : 1 99,99,99,99,99,99,27,28,99,99,99,99,99,99,99,99,99,99,99,99, 139 : 2 41,99,99,44,28,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99, 140 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 141 : 4 99,99,99,99,85,86,87,88,99,99,99,99,93,99,99,99,99),MELE 142 : * 143 : GOTO(168,169,170,171,172),MELE-167 144 : * 145 : GOTO 99 146 : c_______________________________________________________________________ 147 : c 148 : c element coq3 149 : c_______________________________________________________________________ 150 : c 151 : 27 CONTINUE 152 : SEGINI WRK3 153 : c 154 : c boucle de calcul pour les differents elements 155 : c 156 : DO 3027 IB=1,NBELEM 157 : c 158 : c on cherche les deplacements 159 : c 160 : MPTVAL=IVADEP 161 : IE=1 162 : DO 4027 IGAU=1,NBNN 163 : DO 4027 ICOMP=1,NDEP 164 : MELVAL=IVAL(ICOMP) 165 : IGMN=MIN(IGAU,VELCHE(/1)) 166 : IBMN=MIN(IB ,VELCHE(/2)) 167 : XDDL(IE)=VELCHE(IGMN,IBMN) 168 : IE=IE+1 169 : 4027 CONTINUE 170 : c 171 : c on cherche les coordonnees des noeuds de l element ib 172 : c 172 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 173 : c 174 : c on cherche les coeff des mat de hooke et l epaisseur 175 : c 176 : MPTVAL=IVACAR 177 : MELVAL=IVAL(1) 178 : IF (MELVAL.NE.0) THEN 179 : IBMN=MIN(IB,VELCHE(/2)) 180 : EPAIST=VELCHE(1,IBMN) 181 : ELSE 182 : EPAIST=0.D0 183 : ENDIF 184 : c 185 : MPTVAL=IVAMAT 186 : IF(IMAT.EQ.2) THEN 187 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) THEN 188 : MELVAL=IVAL(1) 189 : IBMN=MIN(IB ,IELCHE(/2)) 190 : MLREEL=IELCHE(1,IBMN) 191 : SEGACT MLREEL 191 : CALL DOHOOO(PROG,LHOOK,DDHOMU) 192 : SEGDES MLREEL 193 : ENDIF 194 : ELSE IF (IMAT.EQ.1) THEN 195 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) THEN 196 : DO 9027 IM=1,NMATT 197 : IF (IVAL(IM).NE.0) THEN 198 : MELVAL=IVAL(IM) 199 : IBMN=MIN(IB ,VELCHE(/2)) 200 : VALMAT(IM)=VELCHE(1,IBMN) 201 : ELSE 202 : VALMAT(IM)=0.D0 203 : ENDIF 204 : 9027 CONTINUE 204 : CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 205 : ENDIF 205 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 206 : ENDIF 206 : CALL COQ3ST(XE,XDDL,XSTRS,DDHOMU) 207 : c 208 : IF(IREPS2.EQ.1) 208 : 1 CALL DBCO32(XE,DDHOMU,XDDL,WORK,XSTRS) 209 : c 210 : MPTVAL=IVASTR 211 : DO 6027 ICOMP=1,NSTRS 212 : MELVAL=IVAL(ICOMP) 213 : IBMN=MIN(IB,VELCHE(/2)) 214 : VELCHE(1,IBMN)=XSTRS(ICOMP) 215 : 6027 CONTINUE 216 : c 217 : 3027 CONTINUE 218 : c 219 : IF(IRTD.EQ.0) THEN 220 : MOTERR(1:8)=CMATE 221 : MOTERR(9:12)=NOMFR(MFR/2+1) 222 : INTERR(1)=IFOUR 222 : CALL ERREUR(81) 223 : ENDIF 224 : 9927 CONTINUE 225 : SEGSUP WRK3 226 : GOTO 510 227 : c____________________________________________________________________ 228 : c 229 : c element dkt 230 : c____________________________________________________________________ 231 : c 232 : 28 CONTINUE 233 : NBNO=NBNN 234 : SEGINI WRK2,WRK4 235 : IF(NPINT.NE.0)THEN 236 : NSTRS1=6 237 : SEGINI WRK5 238 : ENDIF 239 : DO 3028 IB=1,NBELEM 240 : c 241 : c on cherche les deplacements 242 : c 243 : MPTVAL=IVADEP 244 : IE=1 245 : DO 4028 IGAU=1,NBNN 246 : DO 4028 ICOMP=1,NDEP 247 : MELVAL=IVAL(ICOMP) 248 : IGMN=MIN(IGAU,VELCHE(/1)) 249 : IBMN=MIN(IB ,VELCHE(/2)) 250 : XDDL(IE)=VELCHE(IGMN,IBMN) 251 : IE=IE+1 252 : 4028 CONTINUE 253 : c 254 : c on cherche les coordonnees des noeuds de l'element ib 255 : c 255 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 255 : CALL VPAST(XE,BPSS) 256 : c bpss stocke la matrice de passage 256 : CALL VCORLC (XE,XEL,BPSS) 256 : CALL MATVEC(XDDL,XDDLOC,BPSS,6) 257 : c 258 : c on cherche les epaiseurs et on les moyenne, 259 : c les excentrements et on les moyenne. 260 : c 261 : EPAIST=0.D0 262 : MPTVAL=IVACAR 263 : MELVAL=IVAL(1) 264 : IF (MELVAL.NE.0) THEN 265 : DO IGAU=1,NBPGAU 266 : IGMN=MIN(IGAU,VELCHE(/1)) 267 : IBMN=MIN(IB,VELCHE(/2)) 268 : EPAIST=EPAIST+VELCHE(IGMN,IBMN) 269 : ENDDO 270 : EPAIST=EPAIST/NBPGAU 271 : ENDIF 272 : * 273 : EXCEN=0.D0 274 : MELVAL=IVAL(2) 275 : IF (MELVAL.NE.0) THEN 276 : DO IGAU=1,NBPGAU 277 : IGMN=MIN(IGAU,VELCHE(/1)) 278 : IBMN=MIN(IB,VELCHE(/2)) 279 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 280 : ENDDO 281 : EXCEN=EXCEN/NBPGAU 282 : ENDIF 283 : c 284 : IF(NPINT.EQ.0)THEN 285 : c 286 : c coque global 287 : c 288 : c boucle sur les points de gauss 289 : c 290 : DO 5028 IGAU=1,NBPTEL 290 : CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 291 : & MELE,MFR,NBNO,LRE,IFOUR,NSTRS,0,1.D0,XEL, 292 : & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 293 : * 294 : * on modifie la matrice b en cas d'excentrement non nul 295 : * 296 : IF (EXCEN.NE.0.D0) THEN 297 : DO 1528 IJL=1,3 298 : DO 1528 IJC=1,LRE 299 : BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 300 : 1528 CONTINUE 301 : ENDIF 302 : c 303 : c on cherche la matrice de hooke 304 : c 305 : MPTVAL=IVAMAT 306 : IF(IMAT.EQ.2) THEN 307 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 308 : MELVAL=IVAL(1) 309 : IBMN=MIN(IB ,IELCHE(/2)) 310 : IGMN=MIN(IGAU,IELCHE(/1)) 311 : MLREEL=IELCHE(IGMN,IBMN) 312 : SEGACT MLREEL 312 : CALL DOHOOO(PROG,LHOOK,DDHOMU) 313 : SEGDES MLREEL 314 : ENDIF 315 : ELSE IF (IMAT.EQ.1) THEN 316 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 317 : DO 9128 IM=1,NMATT 318 : IF (IVAL(IM).NE.0) THEN 319 : MELVAL=IVAL(IM) 320 : IBMN=MIN(IB ,VELCHE(/2)) 321 : IGMN=MIN(IGAU,VELCHE(/1)) 322 : VALMAT(IM)=VELCHE(IGMN,IBMN) 323 : ELSE 324 : VALMAT(IM)=0.D0 325 : ENDIF 326 : 9128 CONTINUE 326 : CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 327 : ENDIF 327 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 328 : ENDIF 328 : CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) 329 : c 330 : c calcul des eps 2 331 : c 332 : IF(IREPS2.EQ.1) 332 : 1 CALL DBDKT2(XEL,DDHOMU,XDDLOC,IGAU,XSTRS,SHPWRK,SHPTOT, 333 : 1 BGENE,NBNO,LRE,NSTRS) 334 : c 335 : c remplissage du segment contenant les contraintes 336 : c 337 : MPTVAL=IVASTR 338 : DO 9028 ICOMP=1,NSTRS 339 : MELVAL=IVAL(ICOMP) 340 : IBMN=MIN(IB ,VELCHE(/2)) 341 : VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 342 : 9028 CONTINUE 343 : 5028 CONTINUE 344 : c 345 : ELSE 346 : c 347 : c coque integree 348 : c 349 : NBPGA1=NBPGAU/NPINT 350 : c 351 : c boucle sur les points de gauss de la surface 352 : c 353 : DO 5001 IGAU=1,NBPGA1 353 : CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU, 354 : & MELE,MFR,NBNO,LRE,IFOUR,NSTRS1,0,1.D0,XEL, 355 : & SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE) 356 : * 357 : * on modifie la matrice b en cas d'excentrement non nul 358 : * 359 : IF (EXCEN.NE.0.D0) THEN 360 : DO 1501 IJL=1,3 361 : DO 1501 IJC=1,LRE 362 : BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 363 : 1501 CONTINUE 364 : ENDIF 365 : c 366 : c boucle sur les nappes 367 : c 368 : DO 5002 INAP=1,NPINT 369 : IGAU1=(INAP-1)*NBPGA1+IGAU 370 : c 371 : c on cherche la matrice de hooke 372 : c 373 : MPTVAL=IVAMAT 374 : IF(IMAT.EQ.2) THEN 375 : IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 376 : MELVAL=IVAL(1) 377 : IBMN=MIN(IB ,IELCHE(/2)) 378 : IGMN=MIN(IGAU1,IELCHE(/1)) 379 : MLREEL=IELCHE(IGMN,IBMN) 380 : SEGACT MLREEL 380 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 381 : SEGDES MLREEL 382 : ENDIF 383 : ELSE IF (IMAT.EQ.1) THEN 384 : IF (IGAU1.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 385 : DO 9101 IM=1,NMATT 386 : IF (IVAL(IM).NE.0) THEN 387 : MELVAL=IVAL(IM) 388 : IBMN=MIN(IB ,VELCHE(/2)) 389 : IGMN=MIN(IGAU1,VELCHE(/1)) 390 : VALMAT(IM)=VELCHE(IGMN,IBMN) 391 : ELSE 392 : VALMAT(IM)=0.D0 393 : ENDIF 394 : 9101 CONTINUE 394 : CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 395 : ENDIF 396 : ENDIF 396 : CALL DBST(BGENE,DDHOOK,XDDLOC,LRE,NSTRS1,XSTRS1) 397 : c 398 : c calcul des eps 2 399 : c 400 : IF(IREPS2.EQ.1) 400 : 1 CALL DBDKT2(XEL,DDHOOK,XDDLOC,IGAU,XSTRS1,SHPWRK,SHPTOT, 401 : 1 BGENE,NBNO,LRE,NSTRS1) 402 : c 403 : ZZZ=DZEGAU(IGAU1)*(EPAIST/2.D0) 404 : XSTRS(1)=XSTRS1(1)+ZZZ*XSTRS1(4) 405 : XSTRS(2)=XSTRS1(2)+ZZZ*XSTRS1(5) 406 : XSTRS(3)=0.D0 407 : XSTRS(4)=XSTRS1(3)+ZZZ*XSTRS1(6) 408 : c 409 : c remplissage du segment contenant les contraintes 410 : c 411 : MPTVAL=IVASTR 412 : DO 9001 ICOMP=1,NSTRS 413 : MELVAL=IVAL(ICOMP) 414 : IBMN=MIN(IB ,VELCHE(/2)) 415 : VELCHE(IGAU1,IBMN)=XSTRS(ICOMP) 416 : 9001 CONTINUE 417 : c fin de boucle sur les nappes de points 418 : 5002 CONTINUE 419 : c fin de boucle sur les points dans chaque nappe 420 : 5001 CONTINUE 421 : c fin de boucle sur les points d'integration 422 : ENDIF 423 : c fin de boucle sur les elements 424 : 3028 CONTINUE 425 : * 426 : IF(IRTD.EQ.0) THEN 427 : MOTERR(1:8)=CMATE 428 : MOTERR(9:12)=NOMFR(MFR/2+1) 429 : INTERR(1)=IFOUR 429 : CALL ERREUR(81) 430 : ENDIF 431 : 9928 CONTINUE 432 : SEGSUP,WRK2,WRK4 433 : IF(NPINT.NE.0)SEGSUP WRK5 434 : * 435 : GOTO 510 436 : c____________________________________________________________________ 437 : c 438 : c elements coq6 et coq8 439 : c____________________________________________________________________ 440 : c 441 : 41 CONTINUE 442 : NBNO=NBNN 443 : SEGINI WRK2,WRK3 444 : MINTE1=IPMIN1 445 : SEGACT MINTE1 446 : NBPGA1=MINTE1.SHPTOT(/3) 447 : NBN1 =MINTE1.SHPTOT(/2) 448 : c 449 : c boucle de calcul pour les differents elements 450 : c 451 : DO 3041 IB=1,NBELEM 452 : c 453 : c on cherche les deplacements 454 : c 455 : MPTVAL=IVADEP 456 : IE=1 457 : DO 4041 IGAU=1,NBNN 458 : DO 4041 ICOMP=1,NDEP 459 : MELVAL=IVAL(ICOMP) 460 : IGMN=MIN(IGAU,VELCHE(/1)) 461 : IBMN=MIN(IB ,VELCHE(/2)) 462 : XDDL(IE)=VELCHE(IGMN,IBMN) 463 : IE=IE+1 464 : 4041 CONTINUE 465 : c 466 : c on cherche les coordonnees des noeuds de l'element ib 467 : c 467 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 468 : c 469 : c on cherche les epaisseurs et les excentrements, 470 : c 471 : MPTVAL=IVACAR 472 : MELVAL=IVAL(1) 473 : IF (MELVAL.NE.0) THEN 474 : DO IGAU=1,NBPGAU 475 : IGMN=MIN(IGAU,VELCHE(/1)) 476 : IBMN=MIN(IB,VELCHE(/2)) 477 : WORK(IGAU)=VELCHE(IGMN,IBMN) 478 : ENDDO 479 : ENDIF 480 : * 481 : MELVAL=IVAL(2) 482 : IF (MELVAL.NE.0) THEN 483 : DO IGAU=1,NBPGAU 484 : IGMN=MIN(IGAU,VELCHE(/1)) 485 : IBMN=MIN(IB,VELCHE(/2)) 486 : WORK(IGAU+10)=VELCHE(IGMN,IBMN) 487 : ENDDO 488 : ENDIF 489 : c 490 : c determination des axes locaux aux noeuds 491 : c 491 : CALL CQ8LOC(XE,NBNN,MINTE1.SHPTOT,WORK(21),IRR) 492 : c 493 : c boucle sur les points de gauss 494 : c 495 : DO 3042 IGAU=1,NBPTEL 496 : c 497 : c calcul de la matrice b 498 : c 499 : E3=DZEGAU(IGAU) 499 : CALL BCOQ8E(IGAU,XE,NBNN,WORK(1),WORK(11),BGENE,DJAC, 500 : 1 E3,SHPTOT,WORK(21),IRR) 501 : c 502 : IF (IRR.EQ.0) THEN 503 : INTERR(1)=IB 503 : CALL ERREUR(241) 504 : GOTO 9941 505 : ELSE IF (IRR.EQ.-1) THEN 506 : INTERR(1)=IB 506 : CALL ERREUR(240) 507 : GOTO 9941 508 : ENDIF 509 : c 510 : c on cherche les coeff des mat de hooke 511 : c 512 : MPTVAL=IVAMAT 513 : IF(IMAT.EQ.2) THEN 514 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 515 : MELVAL=IVAL(1) 516 : IBMN=MIN(IB ,IELCHE(/2)) 517 : IGMN=MIN(IGAU,IELCHE(/1)) 518 : MLREEL=IELCHE(IGMN,IBMN) 519 : SEGACT MLREEL 519 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 520 : SEGDES MLREEL 521 : ENDIF 522 : ELSE IF (IMAT.EQ.1) THEN 523 : DO 9041 IM=1,NMATT 524 : IF (IVAL(IM).NE.0) THEN 525 : MELVAL=IVAL(IM) 526 : IBMN=MIN(IB ,VELCHE(/2)) 527 : IGMN=MIN(IGAU,VELCHE(/1)) 528 : VALMAT(IM)=VELCHE(IGMN,IBMN) 529 : ELSE 530 : VALMAT(IM)=0.D0 531 : ENDIF 532 : 9041 CONTINUE 533 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 533 : 1 CALL DOHCOE(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 534 : ENDIF 535 : c 536 : c on calcule les contraintes pour le point de gauss 537 : c 537 : CALL DBST (BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS ) 538 : c 539 : c on remplit les contraintes 540 : c 541 : MPTVAL=IVASTR 542 : DO 6041 ICOMP=1,NSTRS 543 : MELVAL=IVAL(ICOMP) 544 : IBMN=MIN(IB ,VELCHE(/2)) 545 : VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 546 : 6041 CONTINUE 547 : c 548 : 3042 CONTINUE 549 : c 550 : 3041 CONTINUE 551 : 552 : IF (IRTD.EQ.0) THEN 553 : MOTERR(1:8)=CMATE 554 : MOTERR(9:12)=NOMFR(MFR/2+1) 555 : INTERR(1)=IFOUR 555 : CALL ERREUR(81) 556 : ENDIF 557 : 9941 CONTINUE 558 : SEGSUP,WRK2,WRK3 559 : SEGDES MINTE1 560 : GOTO 510 561 : c____________________________________________________________________ 562 : c 563 : c element coq2 564 : c____________________________________________________________________ 565 : c 566 : 44 CONTINUE 567 : NBNO=NBNN 568 : SEGINI WRK2 569 : 570 : NDDD=NDEP 571 : IF (IFOUR.EQ.-3) NDDD=NDEP-3 572 : 573 : DO 3044 IB=1,NBELEM 574 : c 575 : c on cherche les deplacements 576 : c 577 : MPTVAL=IVADEP 578 : IE=1 579 : DO 5044 IGAU=1,NBNN 580 : DO 5044 ICOMP=1,NDDD 581 : MELVAL=IVAL(ICOMP) 582 : IGMN=MIN(IGAU,VELCHE(/1)) 583 : IBMN=MIN(IB ,VELCHE(/2)) 584 : XDDL(IE)=VELCHE(IGMN,IBMN) 585 : IE=IE+1 586 : 5044 CONTINUE 587 : IF (IFOUR.EQ.-3) THEN 588 : XDDL(IE)=UZDPG 589 : XDDL(IE+1)=RYDPG 590 : XDDL(IE+2)=RXDPG 591 : ENDIF 592 : c 593 : c on cherche les coordonnees des noeuds de l'element ib 594 : c 594 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 595 : c 596 : c on cherche les epaisseurs et les excentrements, 597 : c on les moyenne sur l'element. 598 : c 599 : EPAIST=0.D0 600 : MPTVAL=IVACAR 601 : MELVAL=IVAL(1) 602 : IF (MELVAL.NE.0) THEN 603 : DO IGAU=1,NBPGAU 604 : IGMN=MIN(IGAU,VELCHE(/1)) 605 : IBMN=MIN(IB,VELCHE(/2)) 606 : EPAIST=EPAIST+VELCHE(IGMN,IBMN) 607 : ENDDO 608 : EPAIST=EPAIST/NBPGAU 609 : ENDIF 610 : * 611 : EXCEN=0.D0 612 : MELVAL=IVAL(2) 613 : IF (MELVAL.NE.0) THEN 614 : DO IGAU=1,NBPGAU 615 : IGMN=MIN(IGAU,VELCHE(/1)) 616 : IBMN=MIN(IB,VELCHE(/2)) 617 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 618 : ENDDO 619 : EXCEN=EXCEN/NBPGAU 620 : ENDIF 621 : c 622 : c boucle sur les points de gauss 623 : c 624 : DO 4044 IGAU=1,NBPGAU 625 : c 626 : c appel a bcoq2 627 : c 627 : CALL BCOQ2(BGENE,NSTRS,DJAC,IGAU,IFOUR,XE,NHRM,QSIGAU,POIGAU, 628 : . EXCEN,1.D0,IRR,XDPGE,YDPGE) 629 : c 630 : c gestion d'erreur 631 : c 632 : IF (IRR.EQ.1) THEN 633 : INTERR(1)=IB 633 : CALL ERREUR(255) 634 : GOTO 9944 635 : ELSE IF (IRR.EQ.2) THEN 636 : INTERR(1)=IB 636 : CALL ERREUR(256) 637 : GOTO 9944 638 : ENDIF 639 : c 640 : c matrice de hooke 641 : c 642 : MPTVAL=IVAMAT 643 : IF(IMAT.EQ.2) THEN 644 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 645 : MELVAL=IVAL(1) 646 : IBMN=MIN(IB ,IELCHE(/2)) 647 : MLREEL=IELCHE(1,IBMN) 648 : SEGACT MLREEL 648 : CALL DOHOOO(PROG,LHOOK,DDHOMU) 649 : SEGDES MLREEL 650 : ENDIF 651 : ELSE IF (IMAT.EQ.1) THEN 652 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 653 : DO 1044 IM=1,NMATT 654 : IF (IVAL(IM).NE.0) THEN 655 : MELVAL=IVAL(IM) 656 : IBMN=MIN(IB ,VELCHE(/2)) 657 : VALMAT(IM)=VELCHE(1,IBMN) 658 : ELSE 659 : VALMAT(IM)=0.D0 660 : ENDIF 661 : 1044 CONTINUE 661 : CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 662 : ENDIF 662 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 663 : ENDIF 664 : c 665 : c on va séparer l'appel à DBST en 3 parties : 666 : c - multiplication de B * DDL 667 : c - rajout éventuel de termes quadratiques 668 : c - multiplication des deformations par la matrice de Hooke 669 : c 669 : c CALL DBST(BGENE,DDHOMU,XDDL,LRE,NSTRS,XSTRS) 670 : c 670 : CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) 671 : 672 : IF(IREPS2.EQ.1) 672 : +call b2coq2(xstrs,nstrs,xddl,nbnn*ndep,xe,nbnn,QSIGAU,POIGAU,igau) 673 : 673 : call dxdefo(ddhomu,nstrs,xstrs) 674 : c 675 : c remplissage du segment contenant les contraintes 676 : c 677 : MPTVAL=IVASTR 678 : DO 9044 ICOMP=1,NSTRS 679 : MELVAL=IVAL(ICOMP) 680 : IGMN=MIN(IGAU,VELCHE(/1)) 681 : IBMN=MIN(IB ,VELCHE(/2)) 682 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 683 : 9044 CONTINUE 684 : 4044 CONTINUE 685 : 3044 CONTINUE 686 : c 687 : IF (IRTD.EQ.0) THEN 688 : MOTERR(1:8)=CMATE 689 : MOTERR(9:12)=NOMFR(MFR/2+1) 690 : INTERR(1)=IFOUR 690 : CALL ERREUR(81) 691 : ENDIF 692 : 9944 CONTINUE 693 : SEGSUP,WRK2 694 : GOTO 510 695 : c____________________________________________________________________ 696 : c 697 : c element coq4 698 : c____________________________________________________________________ 699 : c 700 : 49 CONTINUE 701 : NBNO=NBNN 702 : SEGINI WRK2,WRK4 703 : DO 3049 IB=1,NBELEM 704 : c 705 : c on cherche les deplacements 706 : c 707 : MPTVAL=IVADEP 708 : IE=1 709 : DO 5049 IGAU=1,NBNN 710 : DO 5049 ICOMP=1,NDEP 711 : MELVAL=IVAL(ICOMP) 712 : IGMN=MIN(IGAU,VELCHE(/1)) 713 : IBMN=MIN(IB ,VELCHE(/2)) 714 : XDDL(IE)=VELCHE(IGMN,IBMN) 715 : IE=IE+1 716 : 5049 CONTINUE 717 : c 718 : c on cherche les coordonnees des noeuds de l'element ib 719 : c 719 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 720 : c 720 : CALL CQ4LOC(XE,XEL,BPSS,IERT,1) 721 : c iert=1 nodi troppo vicini 722 : IF (IERT.EQ.1) THEN 723 : INTERR(1)=IB 723 : CALL ERREUR(323) 724 : GOTO 9949 725 : ELSE IF (IERT.EQ.3) THEN 726 : IERT = 0 727 : NOPLAN = 1 728 : ELSE 729 : NOPLAN = 0 730 : ENDIF 730 : CALL MATVEC(XDDL,XDDLOC,BPSS,8) 731 : c 732 : c on cherche les epaisseurs et les excentrements, 733 : c on les moyenne sur l'element. 734 : c 735 : MPTVAL=IVACAR 736 : EPAIST=0.D0 737 : MELVAL=IVAL(1) 738 : IF (MELVAL.NE.0) THEN 739 : DO IGAU=1,NBPGAU 740 : IGMN=MIN(IGAU,VELCHE(/1)) 741 : IBMN=MIN(IB,VELCHE(/2)) 742 : EPAIST=EPAIST+VELCHE(IGMN,IBMN) 743 : ENDDO 744 : EPAIST=EPAIST/NBPGAU 745 : ENDIF 746 : * 747 : EXCEN=0.D0 748 : MELVAL=IVAL(2) 749 : IF (MELVAL.NE.0) THEN 750 : DO IGAU=1,NBPGAU 751 : IGMN=MIN(IGAU,VELCHE(/1)) 752 : IBMN=MIN(IB,VELCHE(/2)) 753 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 754 : ENDDO 755 : EXCEN=EXCEN/NBPGAU 756 : ENDIF 757 : c 758 : c boucle sur les points de gauss 759 : c 760 : DO 4049 IGAU=1,NBPGAU 761 : c 762 : c appel a bcoq4 763 : c 764 : if(cmate.eq.'ISOTROPE') then 764 : CALL BCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1) 765 : else 765 : CALL BCOQ4O(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,EXCEN,NOPLAN,IERT,1) 766 : endif 767 : c iert=1 jacobiano <= 0 768 : IF (IERT.EQ.1) THEN 769 : INTERR(1)=IB 769 : CALL ERREUR(321) 770 : GOTO 9949 771 : ENDIF 772 : c 773 : c matrice de hooke 774 : c 775 : MPTVAL=IVAMAT 776 : IF(IMAT.EQ.2) THEN 777 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 778 : MELVAL=IVAL(1) 779 : IBMN=MIN(IB ,IELCHE(/2)) 780 : MLREEL=IELCHE(1,IBMN) 781 : SEGACT MLREEL 781 : CALL DOHOOO(PROG,LHOOK,DDHOMU) 782 : SEGDES MLREEL 783 : ENDIF 784 : ELSE IF (IMAT.EQ.1) THEN 785 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 786 : DO 1049 IM=1,NMATT 787 : IF (IVAL(IM).NE.0) THEN 788 : MELVAL=IVAL(IM) 789 : IBMN=MIN(IB ,VELCHE(/2)) 790 : VALMAT(IM)=VELCHE(1,IBMN) 791 : ELSE 792 : VALMAT(IM)=0.D0 793 : ENDIF 794 : 1049 CONTINUE 794 : CALL DOHCIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 795 : ENDIF 795 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 796 : ENDIF 797 : c 797 : CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) 798 : c 799 : c remplissage du segment contenant les contraintes 800 : c 801 : MPTVAL=IVASTR 802 : DO 9049 ICOMP=1,NSTRS 803 : MELVAL=IVAL(ICOMP) 804 : IGMN=MIN(IGAU,VELCHE(/1)) 805 : IBMN=MIN(IB ,VELCHE(/2)) 806 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 807 : 9049 CONTINUE 808 : 4049 CONTINUE 809 : 3049 CONTINUE 810 : c 811 : IF(IRTD.EQ.0) THEN 812 : MOTERR(1:8)=CMATE 813 : MOTERR(9:12)=NOMFR(MFR/2+1) 814 : INTERR(1)=IFOUR 814 : CALL ERREUR(81) 815 : ENDIF 816 : 9949 CONTINUE 817 : SEGSUP,WRK2,WRK4 818 : GOTO 510 819 : c____________________________________________________________________ 820 : c 821 : c element joint joi2 822 : c____________________________________________________________________ 823 : c 824 : 85 CONTINUE 825 : NBNO=NBNN 826 : SEGINI WRK2,WRK4 827 : c 828 : DO 3085 IB=1,NBELEM 829 : c 830 : c on cherche les deplacements 831 : c 832 : MPTVAL=IVADEP 833 : IE=1 834 : DO 5085 IGAU=1,NBNN 835 : DO 5085 ICOMP=1,NDEP 836 : MELVAL=IVAL(ICOMP) 837 : IGMN=MIN(IGAU,VELCHE(/1)) 838 : IBMN=MIN(IB ,VELCHE(/2)) 839 : XDDL(IE)=VELCHE(IGMN,IBMN) 840 : IE=IE+1 841 : 5085 CONTINUE 842 : c 843 : c on cherche les coordonnees des noeuds de l'element ib 844 : c 844 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 845 : c 845 : CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 846 : c 847 : c----------------------------------------------------------------- 848 : c je n'ai pas besoin de transformer les deplacements 849 : c dans le repere local car la matrice b est un operateur qui 850 : c s'applique sur une quantite globale, u, pour donner une 851 : c quantite locale, epsilon ; ceci, du fait de la presence 852 : c de la matrice teta dans l'expression de b. si cela est vrai, 853 : c alors il n'est pas necessaire d'appeler matvec. 854 : c il faudra simplement appeler dbst avec xddl et non pas avec 855 : c xddloc. 856 : c----------------------------------------------------------------- 856 : ccccccccc call matvec(xddl,xddloc,bpss,8) 857 : c 858 : c boucle sur les points de gauss 859 : c 860 : DO 4085 IGAU=1,NBPGAU 861 : c 862 : c appel a bjo2 pour le calcul de b 863 : c 863 : CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 864 : . BGENE,DJAC,IRRT) 865 : c irrt=1 jacobien <= 0 866 : IF (IRRT.NE.0) THEN 867 : INTERR(1)=IB 867 : CALL ERREUR(612) 868 : GOTO 9985 869 : ENDIF 870 : c 871 : c matrice de hooke 872 : c 873 : MPTVAL=IVAMAT 874 : IF(IMAT.EQ.2) THEN 875 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 876 : MELVAL=IVAL(1) 877 : IBMN=MIN(IB ,IELCHE(/2)) 878 : MLREEL=IELCHE(1,IBMN) 879 : SEGACT MLREEL 879 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 880 : SEGDES MLREEL 881 : ENDIF 882 : ELSE IF (IMAT.EQ.1) THEN 883 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 884 : DO 1085 IM=1,NMATT 885 : IF (IVAL(IM).NE.0) THEN 886 : MELVAL=IVAL(IM) 887 : IBMN=MIN(IB ,VELCHE(/2)) 888 : VALMAT(IM)=VELCHE(1,IBMN) 889 : ELSE 890 : VALMAT(IM)=0.D0 891 : ENDIF 892 : 1085 CONTINUE 892 : CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 893 : ENDIF 894 : ENDIF 895 : c 895 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 896 : c 897 : c remplissage du segment contenant les contraintes 898 : c 899 : MPTVAL=IVASTR 900 : DO 9085 ICOMP=1,NSTRS 901 : MELVAL=IVAL(ICOMP) 902 : IGMN=MIN(IGAU,VELCHE(/1)) 903 : IBMN=MIN(IB ,VELCHE(/2)) 904 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 905 : 9085 CONTINUE 906 : 4085 CONTINUE 907 : 3085 CONTINUE 908 : c 909 : IF(IRTD.EQ.0) THEN 910 : MOTERR(1:8)=CMATE 911 : MOTERR(9:12)=NOMFR(MFR/2+1) 912 : INTERR(1)=IFOUR 912 : CALL ERREUR(81) 913 : ENDIF 914 : 9985 CONTINUE 915 : SEGSUP,WRK2,WRK4 916 : GOTO 510 917 : c____________________________________________________________________ 918 : c 919 : c element joint jgi2 920 : c____________________________________________________________________ 921 : c 922 : 170 CONTINUE 923 : NBNO=NBNN 924 : SEGINI WRK2,WRK4 925 : 926 : NDDD=NDEP 927 : IF (IFOUR.EQ.-3) NDDD=NDEP-3 928 : 929 : EPAIST=0.D0 930 : 931 : DO IB=1,NBELEM 932 : c 933 : c on cherche les deplacements 934 : c 935 : MPTVAL=IVADEP 936 : IE=1 937 : DO IGAU=1,NBNN 938 : DO ICOMP=1,NDDD 939 : MELVAL=IVAL(ICOMP) 940 : IGMN=MIN(IGAU,VELCHE(/1)) 941 : IBMN=MIN(IB ,VELCHE(/2)) 942 : XDDL(IE)=VELCHE(IGMN,IBMN) 943 : IE=IE+1 944 : ENDDO 945 : ENDDO 946 : IF (IFOUR.EQ.-3) THEN 947 : XDDL(IE)=UZDPG 948 : XDDL(IE+1)=RYDPG 949 : XDDL(IE+2)=RXDPG 950 : ENDIF 951 : c 952 : c on cherche les coordonnees des noeuds de l'element ib 953 : c 953 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 954 : c 954 : CALL JO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 955 : c 956 : c boucle sur les points de gauss 957 : c 958 : DO IGAU=1,NBPGAU 959 : c 960 : c on cherche l'epaisseur du joint 961 : c 962 : MPTVAL=IVACAR 963 : MELVAL=IVAL(1) 964 : IF (MELVAL.NE.0) THEN 965 : IGMN=MIN(IGAU,VELCHE(/1)) 966 : IBMN=MIN(IB,VELCHE(/2)) 967 : EPAIST=VELCHE(IGMN,IBMN) 968 : ENDIF 969 : c 970 : c appel a bjo2 pour le calcul de b 971 : c 971 : CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 972 : CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) 972 : CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, 973 : . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) 974 : c irrt=1 jacobien <= 0 975 : IF(IRRT.NE.0) THEN 976 : INTERR(1)=IB 976 : CALL ERREUR(612) 977 : GOTO 9970 978 : ENDIF 979 : c 980 : c matrice de hooke 981 : c 982 : MPTVAL=IVAMAT 983 : IF(IMAT.EQ.2) THEN 984 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 985 : MELVAL=IVAL(1) 986 : IBMN=MIN(IB ,IELCHE(/2)) 987 : MLREEL=IELCHE(1,IBMN) 988 : SEGACT MLREEL 988 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 989 : SEGDES MLREEL 990 : ENDIF 991 : ELSE IF (IMAT.EQ.1) THEN 992 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 993 : DO IM=1,NMATT 994 : IF (IVAL(IM).NE.0) THEN 995 : MELVAL=IVAL(IM) 996 : IBMN=MIN(IB ,VELCHE(/2)) 997 : VALMAT(IM)=VELCHE(1,IBMN) 998 : ELSE 999 : VALMAT(IM)=0.D0 1000 : ENDIF 1001 : ENDDO 1001 : CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1002 : ENDIF 1003 : ENDIF 1004 : c 1004 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1005 : c 1006 : c remplissage du segment contenant les contraintes 1007 : c 1008 : MPTVAL=IVASTR 1009 : DO ICOMP=1,NSTRS 1010 : MELVAL=IVAL(ICOMP) 1011 : IGMN=MIN(IGAU,VELCHE(/1)) 1012 : IBMN=MIN(IB ,VELCHE(/2)) 1013 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1014 : ENDDO 1015 : ENDDO 1016 : ENDDO 1017 : c 1018 : IF(IRTD.EQ.0) THEN 1019 : MOTERR(1:8)=CMATE 1020 : MOTERR(9:12)=NOMFR(MFR/2+1) 1021 : INTERR(1)=IFOUR 1021 : CALL ERREUR(81) 1022 : ENDIF 1023 : 9970 CONTINUE 1024 : SEGSUP,WRK2,WRK4 1025 : GOTO 510 1026 : c____________________________________________________________________ 1027 : c 1028 : c element joint jct3 Pour le moment en 2D cisaillement 1029 : c____________________________________________________________________ 1030 : c 1031 : 168 CONTINUE 1032 : NBNO=NBNN 1033 : SEGINI WRK2,WRK4 1034 : IF(CMATE.NE.'ISOTROPE')THEN 1035 : MPTVAL=IVAMAT 1036 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1037 : MELVAL=IVAL(4) 1038 : ELSE 1039 : MELVAL=IVAL(2) 1040 : ENDIF 1041 : NBGCOS=VELCHE(/1) 1042 : ENDIF 1043 : 1044 : DO IB=1,NBELEM 1045 : c 1046 : c on cherche les deplacements 1047 : c 1048 : MPTVAL=IVADEP 1049 : IE=1 1050 : DO IGAU=1,NBNN 1051 : DO ICOMP=1,NDEP 1052 : MELVAL=IVAL(ICOMP) 1053 : IGMN=MIN(IGAU,VELCHE(/1)) 1054 : IBMN=MIN(IB ,VELCHE(/2)) 1055 : XDDL(IE)=VELCHE(IGMN,IBMN) 1056 : IE=IE+1 1057 : ENDDO 1058 : ENDDO 1059 : c 1060 : c on cherche les coordonnees des noeuds de l'element ib 1061 : c 1061 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1062 : c 1062 : CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1063 : c 1064 : c boucle sur les points de gauss 1065 : c 1066 : DO IGAU=1,NBPGAU 1067 : c 1068 : c appel a bjt3 pour le calcul de b 1069 : c 1069 : CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1070 : . BGENE,DJAC,IRRT) 1071 : c irrt=1 jacobien <= 0 1072 : IF(IRRT.NE.0) THEN 1073 : INTERR(1)=IB 1073 : CALL ERREUR(611) 1074 : GOTO 9968 1075 : ENDIF 1076 : c 1077 : c matrice de hooke 1078 : c 1079 : MPTVAL=IVAMAT 1080 : IF(IMAT.EQ.2) THEN 1081 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1082 : MELVAL=IVAL(1) 1083 : IBMN=MIN(IB ,IELCHE(/2)) 1084 : MLREEL=IELCHE(1,IBMN) 1085 : SEGACT MLREEL 1085 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1086 : SEGDES MLREEL 1087 : ENDIF 1088 : ELSE IF (IMAT.EQ.1) THEN 1089 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1090 : DO IM=1,NMATT 1091 : IF (IVAL(IM).NE.0) THEN 1092 : MELVAL=IVAL(IM) 1093 : IBMN=MIN(IB ,VELCHE(/2)) 1094 : VALMAT(IM)=VELCHE(1,IBMN) 1095 : ELSE 1096 : VALMAT(IM)=0.D0 1097 : ENDIF 1098 : ENDDO 1098 : CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1099 : ENDIF 1100 : ENDIF 1101 : c 1101 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1102 : c 1103 : c remplissage du segment contenant les contraintes 1104 : c 1105 : MPTVAL=IVASTR 1106 : DO ICOMP=1,NSTRS 1107 : MELVAL=IVAL(ICOMP) 1108 : IGMN=MIN(IGAU,VELCHE(/1)) 1109 : IBMN=MIN(IB ,VELCHE(/2)) 1110 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1111 : ENDDO 1112 : ENDDO 1113 : ENDDO 1114 : c 1115 : IF(IRTD.EQ.0) THEN 1116 : MOTERR(1:8)=CMATE 1117 : MOTERR(9:12)=NOMFR(MFR/2+1) 1118 : INTERR(1)=IFOUR 1118 : CALL ERREUR(81) 1119 : ENDIF 1120 : 9968 CONTINUE 1121 : SEGSUP,WRK2,WRK4 1122 : GOTO 510 1123 : c____________________________________________________________________ 1124 : c 1125 : c element de joint generalise jgt3 1126 : c____________________________________________________________________ 1127 : c 1128 : 171 CONTINUE 1129 : NBNO=NBNN 1130 : SEGINI WRK2,WRK4 1131 : IF(CMATE.NE.'ISOTROPE')THEN 1132 : MPTVAL=IVAMAT 1133 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1134 : MELVAL=IVAL(4) 1135 : ELSE 1136 : MELVAL=IVAL(2) 1137 : ENDIF 1138 : NBGCOS=VELCHE(/1) 1139 : ENDIF 1140 : 1141 : DO IB=1,NBELEM 1142 : c 1143 : c on cherche les deplacements 1144 : c 1145 : MPTVAL=IVADEP 1146 : IE=1 1147 : DO IGAU=1,NBNN 1148 : DO ICOMP=1,NDEP 1149 : MELVAL=IVAL(ICOMP) 1150 : IGMN=MIN(IGAU,VELCHE(/1)) 1151 : IBMN=MIN(IB ,VELCHE(/2)) 1152 : XDDL(IE)=VELCHE(IGMN,IBMN) 1153 : IE=IE+1 1154 : ENDDO 1155 : ENDDO 1156 : c 1157 : c on cherche les coordonnees des noeuds de l'element ib 1158 : c 1158 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1159 : c 1159 : CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1160 : c 1161 : c boucle sur les points de gauss 1162 : c 1163 : DO IGAU=1,NBPGAU 1164 : c 1165 : c on cherche l'epaissuer du joint 1166 : c 1167 : EPAIST=0.D0 1168 : MPTVAL=IVACAR 1169 : MELVAL=IVAL(1) 1170 : IF (MELVAL.NE.0) THEN 1171 : IGMN=MIN(IGAU,VELCHE(/1)) 1172 : IBMN=MIN(IB,VELCHE(/2)) 1173 : EPAIST=VELCHE(IGMN,IBMN) 1174 : ENDIF 1175 : c 1176 : c appel a bjt3 pour le calcul de b 1177 : c 1177 : CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1177 : CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, 1178 : . EPAIST,BGENE,DJAC,IRRT) 1179 : c irrt=1 jacobien <= 0 1180 : IF (IRRT.NE.0) THEN 1181 : INTERR(1)=IB 1181 : CALL ERREUR(611) 1182 : GOTO 9971 1183 : ENDIF 1184 : c 1185 : c matrice de hooke 1186 : c 1187 : MPTVAL=IVAMAT 1188 : IF(IMAT.EQ.2) THEN 1189 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1190 : MELVAL=IVAL(1) 1191 : IBMN=MIN(IB ,IELCHE(/2)) 1192 : MLREEL=IELCHE(1,IBMN) 1193 : SEGACT MLREEL 1193 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1194 : SEGDES MLREEL 1195 : ENDIF 1196 : ELSE IF (IMAT.EQ.1) THEN 1197 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1198 : DO IM=1,NMATT 1199 : IF (IVAL(IM).NE.0) THEN 1200 : MELVAL=IVAL(IM) 1201 : IBMN=MIN(IB ,VELCHE(/2)) 1202 : VALMAT(IM)=VELCHE(1,IBMN) 1203 : ELSE 1204 : VALMAT(IM)=0.D0 1205 : ENDIF 1206 : ENDDO 1206 : CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1207 : ENDIF 1208 : ENDIF 1209 : c 1209 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1210 : c 1211 : c remplissage du segment contenant les contraintes 1212 : c 1213 : MPTVAL=IVASTR 1214 : DO ICOMP=1,NSTRS 1215 : MELVAL=IVAL(ICOMP) 1216 : IGMN=MIN(IGAU,VELCHE(/1)) 1217 : IBMN=MIN(IB ,VELCHE(/2)) 1218 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1219 : ENDDO 1220 : ENDDO 1221 : ENDDO 1222 : c 1223 : IF(IRTD.EQ.0) THEN 1224 : MOTERR(1:8)=CMATE 1225 : MOTERR(9:12)=NOMFR(MFR/2+1) 1226 : INTERR(1)=IFOUR 1226 : CALL ERREUR(81) 1227 : ENDIF 1228 : 9971 CONTINUE 1229 : SEGSUP,WRK2,WRK4 1230 : GOTO 510 1231 : c____________________________________________________________________ 1232 : c 1233 : c element joint jgi4 Pour le moment en 2D cisaillement 1234 : c____________________________________________________________________ 1235 : c 1236 : 169 CONTINUE 1237 : NBNO=NBNN 1238 : SEGINI WRK2,WRK4 1239 : IF(CMATE.NE.'ISOTROPE')THEN 1240 : MPTVAL=IVAMAT 1241 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1242 : MELVAL=IVAL(4) 1243 : ELSE 1244 : MELVAL=IVAL(2) 1245 : ENDIF 1246 : NBGCOS=VELCHE(/1) 1247 : ENDIF 1248 : c 1249 : DO IB=1,NBELEM 1250 : c 1251 : c on cherche les deplacements 1252 : c 1253 : MPTVAL=IVADEP 1254 : IE=1 1255 : DO IGAU=1,NBNN 1256 : DO ICOMP=1,NDEP 1257 : MELVAL=IVAL(ICOMP) 1258 : IGMN=MIN(IGAU,VELCHE(/1)) 1259 : IBMN=MIN(IB ,VELCHE(/2)) 1260 : XDDL(IE)=VELCHE(IGMN,IBMN) 1261 : IE=IE+1 1262 : ENDDO 1263 : ENDDO 1264 : c 1265 : c on cherche les coordonnees des noeuds de l'element ib 1266 : c 1266 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1267 : c 1267 : CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1268 : c 1269 : c boucle sur les points de gauss 1270 : c 1271 : DO IGAU=1,NBPGAU 1272 : c 1273 : c appel a bjo4 pour le calcul de b 1274 : c 1274 : CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) 1275 : c irrt=1 jacobien <= 0 1276 : IF (IRRT.NE.0) THEN 1277 : INTERR(1)=IB 1277 : CALL ERREUR(611) 1278 : GOTO 9969 1279 : ENDIF 1280 : c 1281 : c matrice de hooke 1282 : c 1283 : MPTVAL=IVAMAT 1284 : IF(IMAT.EQ.2) THEN 1285 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1286 : MELVAL=IVAL(1) 1287 : IBMN=MIN(IB ,IELCHE(/2)) 1288 : MLREEL=IELCHE(1,IBMN) 1289 : SEGACT MLREEL 1289 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1290 : SEGDES MLREEL 1291 : ENDIF 1292 : ELSE IF (IMAT.EQ.1) THEN 1293 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1294 : DO IM=1,NMATT 1295 : IF (IVAL(IM).NE.0) THEN 1296 : MELVAL=IVAL(IM) 1297 : IBMN=MIN(IB ,VELCHE(/2)) 1298 : VALMAT(IM)=VELCHE(1,IBMN) 1299 : ELSE 1300 : VALMAT(IM)=0.D0 1301 : ENDIF 1302 : ENDDO 1302 : CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1303 : ENDIF 1304 : ENDIF 1305 : c 1305 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1306 : c 1307 : c remplissage du segment contenant les contraintes 1308 : c 1309 : MPTVAL=IVASTR 1310 : DO ICOMP=1,NSTRS 1311 : MELVAL=IVAL(ICOMP) 1312 : IGMN=MIN(IGAU,VELCHE(/1)) 1313 : IBMN=MIN(IB ,VELCHE(/2)) 1314 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1315 : ENDDO 1316 : ENDDO 1317 : ENDDO 1318 : c 1319 : IF(IRTD.EQ.0) THEN 1320 : MOTERR(1:8)=CMATE 1321 : MOTERR(9:12)=NOMFR(MFR/2+1) 1322 : INTERR(1)=IFOUR 1322 : CALL ERREUR(81) 1323 : ENDIF 1324 : 9969 CONTINUE 1325 : SEGSUP,WRK2,WRK4 1326 : GOTO 510 1327 : c____________________________________________________________________ 1328 : c 1329 : c element joint jgi4 Pour le moment en 2D cisaillement 1330 : c____________________________________________________________________ 1331 : c 1332 : 172 CONTINUE 1333 : NBNO=NBNN 1334 : SEGINI WRK2,WRK4 1335 : IF(CMATE.NE.'ISOTROPE')THEN 1336 : MPTVAL=IVAMAT 1337 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1338 : MELVAL=IVAL(4) 1339 : ELSE 1340 : MELVAL=IVAL(2) 1341 : ENDIF 1342 : NBGCOS=VELCHE(/1) 1343 : ENDIF 1344 : c 1345 : DO IB=1,NBELEM 1346 : c 1347 : c on cherche les deplacements 1348 : c 1349 : MPTVAL=IVADEP 1350 : IE=1 1351 : DO IGAU=1,NBNN 1352 : DO ICOMP=1,NDEP 1353 : MELVAL=IVAL(ICOMP) 1354 : IGMN=MIN(IGAU,VELCHE(/1)) 1355 : IBMN=MIN(IB ,VELCHE(/2)) 1356 : XDDL(IE)=VELCHE(IGMN,IBMN) 1357 : IE=IE+1 1358 : ENDDO 1359 : ENDDO 1360 : c 1361 : c on cherche les coordonnees des noeuds de l'element ib 1362 : c 1362 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1363 : c 1363 : CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1364 : c 1365 : c boucle sur les points de gauss 1366 : c 1367 : DO IGAU=1,NBPGAU 1368 : c 1369 : c on cherche l'epaissuer du joint 1370 : c 1371 : EPAIST=0.D0 1372 : MPTVAL=IVACAR 1373 : MELVAL=IVAL(1) 1374 : IF (MELVAL.NE.0) THEN 1375 : IGMN=MIN(IGAU,VELCHE(/1)) 1376 : IBMN=MIN(IB,VELCHE(/2)) 1377 : EPAIST=VELCHE(IGMN,IBMN) 1378 : ENDIF 1379 : c 1380 : c appel a bjo4 pour le calcul de b 1381 : c 1381 : CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT) 1381 : CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC, 1382 : . IRRT) 1383 : c irrt=1 jacobien <= 0 1384 : IF (IRRT.NE.0) THEN 1385 : INTERR(1)=IB 1385 : CALL ERREUR(611) 1386 : GOTO 9972 1387 : ENDIF 1388 : c 1389 : c matrice de hooke 1390 : c 1391 : MPTVAL=IVAMAT 1392 : IF(IMAT.EQ.2) THEN 1393 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1394 : MELVAL=IVAL(1) 1395 : IBMN=MIN(IB ,IELCHE(/2)) 1396 : MLREEL=IELCHE(1,IBMN) 1397 : SEGACT MLREEL 1397 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1398 : SEGDES MLREEL 1399 : ENDIF 1400 : ELSE IF (IMAT.EQ.1) THEN 1401 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1402 : DO IM=1,NMATT 1403 : IF (IVAL(IM).NE.0) THEN 1404 : MELVAL=IVAL(IM) 1405 : IBMN=MIN(IB ,VELCHE(/2)) 1406 : VALMAT(IM)=VELCHE(1,IBMN) 1407 : ELSE 1408 : VALMAT(IM)=0.D0 1409 : ENDIF 1410 : ENDDO 1410 : CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1411 : ENDIF 1412 : ENDIF 1413 : c 1413 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1414 : c 1415 : c remplissage du segment contenant les contraintes 1416 : c 1417 : MPTVAL=IVASTR 1418 : DO ICOMP=1,NSTRS 1419 : MELVAL=IVAL(ICOMP) 1420 : IGMN=MIN(IGAU,VELCHE(/1)) 1421 : IBMN=MIN(IB ,VELCHE(/2)) 1422 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1423 : ENDDO 1424 : ENDDO 1425 : ENDDO 1426 : c 1427 : IF(IRTD.EQ.0) THEN 1428 : MOTERR(1:8)=CMATE 1429 : MOTERR(9:12)=NOMFR(MFR/2+1) 1430 : INTERR(1)=IFOUR 1430 : CALL ERREUR(81) 1431 : ENDIF 1432 : 9972 CONTINUE 1433 : SEGSUP,WRK2,WRK4 1434 : GOTO 510 1435 : c____________________________________________________________________ 1436 : c 1437 : c element joint joi3 implementation sans test de planeite 1438 : c et sans repere local 1439 : c____________________________________________________________________ 1440 : c 1441 : 86 CONTINUE 1442 : NBNO=NBNN 1443 : SEGINI WRK2,WRK4 1444 : c 1445 : DO 3086 IB=1,NBELEM 1446 : c 1447 : c on cherche les deplacements 1448 : c 1449 : MPTVAL=IVADEP 1450 : IE=1 1451 : DO 5086 IGAU=1,NBNN 1452 : DO 5086 ICOMP=1,NDEP 1453 : MELVAL=IVAL(ICOMP) 1454 : IGMN=MIN(IGAU,VELCHE(/1)) 1455 : IBMN=MIN(IB ,VELCHE(/2)) 1456 : XDDL(IE)=VELCHE(IGMN,IBMN) 1457 : IE=IE+1 1458 : 5086 CONTINUE 1459 : c 1460 : c on cherche les coordonnees des noeuds de l'element ib 1461 : c 1461 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1462 : c 1463 : c boucle sur les points de gauss 1464 : c 1465 : DO 4086 IGAU=1,NBPGAU 1466 : c 1466 : CALL JO3LOC(XE,SHPTOT,IGAU,NBNN,BPSS) 1467 : c 1468 : c appel a bjo3 pour le calcul de b 1469 : c 1469 : CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, 1470 : . BGENE,DJAC,IRRT) 1471 : c irrt=1 jacobien <= 0 1472 : IF (IRRT.NE.0) THEN 1473 : INTERR(1)=IB 1473 : CALL ERREUR(612) 1474 : GOTO 9986 1475 : ENDIF 1476 : c 1477 : c matrice de hooke 1478 : c 1479 : MPTVAL=IVAMAT 1480 : IF(IMAT.EQ.2) THEN 1481 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1482 : MELVAL=IVAL(1) 1483 : IBMN=MIN(IB ,IELCHE(/2)) 1484 : MLREEL=IELCHE(1,IBMN) 1485 : SEGACT MLREEL 1485 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1486 : SEGDES MLREEL 1487 : ENDIF 1488 : ELSE IF (IMAT.EQ.1) THEN 1489 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1490 : DO 1086 IM=1,NMATT 1491 : IF (IVAL(IM).NE.0) THEN 1492 : MELVAL=IVAL(IM) 1493 : IBMN=MIN(IB ,VELCHE(/2)) 1494 : VALMAT(IM)=VELCHE(1,IBMN) 1495 : ELSE 1496 : VALMAT(IM)=0.D0 1497 : ENDIF 1498 : 1086 CONTINUE 1498 : CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1499 : ENDIF 1500 : ENDIF 1501 : c 1501 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1502 : c 1503 : c remplissage du segment contenant les contraintes 1504 : c 1505 : MPTVAL=IVASTR 1506 : DO 9086 ICOMP=1,NSTRS 1507 : MELVAL=IVAL(ICOMP) 1508 : IGMN=MIN(IGAU,VELCHE(/1)) 1509 : IBMN=MIN(IB ,VELCHE(/2)) 1510 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1511 : 9086 CONTINUE 1512 : 4086 CONTINUE 1513 : 3086 CONTINUE 1514 : c 1515 : c impression d'un eventuel message d'erreur 1516 : c 1517 : IF(IRTD.EQ.0) THEN 1518 : MOTERR(1:8)=CMATE 1519 : MOTERR(9:12)=NOMFR(MFR/2+1) 1520 : INTERR(1)=IFOUR 1520 : CALL ERREUR(81) 1521 : ENDIF 1522 : 9986 CONTINUE 1523 : SEGSUP,WRK2,WRK4 1524 : GOTO 510 1525 : c____________________________________________________________________ 1526 : c 1527 : c element joint jot3 1528 : c____________________________________________________________________ 1529 : c 1530 : 87 CONTINUE 1531 : NBNO=NBNN 1532 : SEGINI WRK2,WRK4 1533 : IF(CMATE.NE.'ISOTROPE')THEN 1534 : MPTVAL=IVAMAT 1535 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1536 : MELVAL=IVAL(4) 1537 : ELSE 1538 : MELVAL=IVAL(2) 1539 : ENDIF 1540 : NBGCOS=VELCHE(/1) 1541 : ENDIF 1542 : c 1543 : DO 3087 IB=1,NBELEM 1544 : c 1545 : c on cherche les deplacements 1546 : c 1547 : MPTVAL=IVADEP 1548 : IE=1 1549 : DO 5087 IGAU=1,NBNN 1550 : DO 5087 ICOMP=1,NDEP 1551 : MELVAL=IVAL(ICOMP) 1552 : IGMN=MIN(IGAU,VELCHE(/1)) 1553 : IBMN=MIN(IB ,VELCHE(/2)) 1554 : XDDL(IE)=VELCHE(IGMN,IBMN) 1555 : IE=IE+1 1556 : 5087 CONTINUE 1557 : c 1558 : c on cherche les coordonnees des noeuds de l'element ib 1559 : c 1559 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1560 : c 1560 : CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1561 : c 1562 : c----------------------------------------------------------------- 1563 : c je ne pense pas avoir besoin de transformer les deplacements 1564 : c dans le repere local car la matrice b est un operateur qui 1565 : c s'applique sur une quantite globale, u, pour donner une 1566 : c quantite locale, epsilon ; ceci, du fait de la presence 1567 : c de la matrice teta dans l'expression de b. si cela est vrai, 1568 : c alors il n'est pas necessaire d'appeler matvec. 1569 : c il faudra simplement appeler dbst avec xddl et non pas avec 1570 : c xddloc. 1571 : c----------------------------------------------------------------- 1571 : ccccccccc call matvec(xddl,xddloc,bpss,8) 1572 : c 1573 : c boucle sur les points de gauss 1574 : c 1575 : DO 4087 IGAU=1,NBPGAU 1576 : c 1577 : c appel a bjt3 pour le calcul de b 1578 : c 1578 : CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1579 : . BGENE,DJAC,IRRT) 1580 : c irrt=1 jacobien <= 0 1581 : IF (IRRT.NE.0) THEN 1582 : INTERR(1)=IB 1582 : CALL ERREUR(611) 1583 : GOTO 9987 1584 : ENDIF 1585 : c 1586 : c matrice de hooke 1587 : c 1588 : MPTVAL=IVAMAT 1589 : IF(IMAT.EQ.2) THEN 1590 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1591 : MELVAL=IVAL(1) 1592 : IBMN=MIN(IB ,IELCHE(/2)) 1593 : MLREEL=IELCHE(1,IBMN) 1594 : SEGACT MLREEL 1594 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1595 : SEGDES MLREEL 1596 : ENDIF 1597 : ELSE IF (IMAT.EQ.1) THEN 1598 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1599 : DO 1087 IM=1,NMATT 1600 : IF (IVAL(IM).NE.0) THEN 1601 : MELVAL=IVAL(IM) 1602 : IBMN=MIN(IB ,VELCHE(/2)) 1603 : VALMAT(IM)=VELCHE(1,IBMN) 1604 : ELSE 1605 : VALMAT(IM)=0.D0 1606 : ENDIF 1607 : 1087 CONTINUE 1607 : CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1608 : ENDIF 1609 : ENDIF 1610 : c 1610 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1611 : c 1612 : c remplissage du segment contenant les contraintes 1613 : c 1614 : MPTVAL=IVASTR 1615 : DO 9087 ICOMP=1,NSTRS 1616 : MELVAL=IVAL(ICOMP) 1617 : IGMN=MIN(IGAU,VELCHE(/1)) 1618 : IBMN=MIN(IB ,VELCHE(/2)) 1619 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1620 : 9087 CONTINUE 1621 : 4087 CONTINUE 1622 : 3087 CONTINUE 1623 : c 1624 : IF(IRTD.EQ.0) THEN 1625 : MOTERR(1:8)=CMATE 1626 : MOTERR(9:12)=NOMFR(MFR/2+1) 1627 : INTERR(1)=IFOUR 1627 : CALL ERREUR(81) 1628 : ENDIF 1629 : 9987 CONTINUE 1630 : SEGSUP,WRK2,WRK4 1631 : GOTO 510 1632 : c____________________________________________________________________ 1633 : c 1634 : c element joint joi4 1635 : c____________________________________________________________________ 1636 : c 1637 : 88 CONTINUE 1638 : NBNO=NBNN 1639 : SEGINI WRK2,WRK4 1640 : IF(CMATE.NE.'ISOTROPE')THEN 1641 : MPTVAL=IVAMAT 1642 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1643 : MELVAL=IVAL(4) 1644 : ELSE 1645 : MELVAL=IVAL(2) 1646 : ENDIF 1647 : NBGCOS=VELCHE(/1) 1648 : ENDIF 1649 : DO 3088 IB=1,NBELEM 1650 : c 1651 : c on cherche les deplacements 1652 : c 1653 : MPTVAL=IVADEP 1654 : IE=1 1655 : DO 5088 IGAU=1,NBNN 1656 : DO 5088 ICOMP=1,NDEP 1657 : MELVAL=IVAL(ICOMP) 1658 : IGMN=MIN(IGAU,VELCHE(/1)) 1659 : IBMN=MIN(IB ,VELCHE(/2)) 1660 : XDDL(IE)=VELCHE(IGMN,IBMN) 1661 : IE=IE+1 1662 : 5088 CONTINUE 1663 : c 1664 : c on cherche les coordonnees des noeuds de l'element ib 1665 : c 1665 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1666 : c 1666 : CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL) 1667 : c 1668 : c----------------------------------------------------------------- 1669 : c je ne pense pas avoir besoin de transformer les deplacements 1670 : c dans le repere local car la matrice b est un operateur qui 1671 : c s'applique sur une quantite globale, u, pour donner une 1672 : c quantite locale, epsilon ; ceci, du fait de la presence 1673 : c de la matrice teta dans l'expression de b. si cela est vrai, 1674 : c alors il n'est pas necessaire d'appeler matvec. 1675 : c il faudra simplement appeler dbst avec xddl et non pas avec 1676 : c xddloc. 1677 : c----------------------------------------------------------------- 1677 : ccccccccc call matvec(xddl,xddloc,bpss,8) 1678 : c 1679 : c boucle sur les points de gauss 1680 : c 1681 : DO 4088 IGAU=1,NBPGAU 1682 : c 1683 : c appel a bjo4 pour le calcul de b 1684 : c 1684 : CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) 1685 : c irrt=1 jacobien <= 0 1686 : IF (IRRT.NE.0) THEN 1687 : INTERR(1)=IB 1687 : CALL ERREUR(611) 1688 : GOTO 9988 1689 : ENDIF 1690 : c 1691 : c matrice de hooke 1692 : c 1693 : MPTVAL=IVAMAT 1694 : IF(IMAT.EQ.2) THEN 1695 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1696 : MELVAL=IVAL(1) 1697 : IBMN=MIN(IB ,IELCHE(/2)) 1698 : MLREEL=IELCHE(1,IBMN) 1699 : SEGACT MLREEL 1699 : CALL DOHOOO(PROG,LHOOK,DDHOOK) 1700 : SEGDES MLREEL 1701 : ENDIF 1702 : ELSE IF (IMAT.EQ.1) THEN 1703 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1704 : DO 1088 IM=1,NMATT 1705 : IF (IVAL(IM).NE.0) THEN 1706 : MELVAL=IVAL(IM) 1707 : IBMN=MIN(IB ,VELCHE(/2)) 1708 : VALMAT(IM)=VELCHE(1,IBMN) 1709 : ELSE 1710 : VALMAT(IM)=0.D0 1711 : ENDIF 1712 : 1088 CONTINUE 1712 : CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1713 : ENDIF 1714 : ENDIF 1715 : c 1715 : CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS) 1716 : c 1717 : c remplissage du segment contenant les contraintes 1718 : c 1719 : MPTVAL=IVASTR 1720 : DO 9088 ICOMP=1,NSTRS 1721 : MELVAL=IVAL(ICOMP) 1722 : IGMN=MIN(IGAU,VELCHE(/1)) 1723 : IBMN=MIN(IB ,VELCHE(/2)) 1724 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 1725 : 9088 CONTINUE 1726 : 4088 CONTINUE 1727 : 3088 CONTINUE 1728 : c 1729 : c impression d'un eventuel message d'erreur 1730 : IF(IRTD.EQ.0) THEN 1731 : MOTERR(1:8)=CMATE 1732 : MOTERR(9:12)=NOMFR(MFR/2+1) 1733 : INTERR(1)=IFOUR 1733 : CALL ERREUR(81) 1734 : ENDIF 1735 : 9988 CONTINUE 1736 : SEGSUP,WRK2,WRK4 1737 : GOTO 510 1738 : c____________________________________________________________________ 1739 : c 1740 : c element dst 1741 : c____________________________________________________________________ 1742 : c 1743 : 93 CONTINUE 1744 : NBNO=NBNN 1745 : SEGINI WRK2,WRK3,WRK4 1746 : IF(CMATE.NE.'ISOTROPE')THEN 1747 : MPTVAL=IVAMAT 1748 : IF(IMAT.EQ.1.AND.CMATE.EQ.'ORTHOTRO')THEN 1749 : MELVAL=IVAL(7) 1750 : ELSE 1751 : MELVAL=IVAL(2) 1752 : ENDIF 1753 : NBGCOS=VELCHE(/1) 1754 : ENDIF 1755 : c 1756 : DO 3093 IB=1,NBELEM 1757 : c 1758 : c on cherche les deplacements 1759 : c 1760 : MPTVAL=IVADEP 1761 : IE=1 1762 : DO 4093 IGAU=1,NBNN 1763 : DO 4093 ICOMP=1,NDEP 1764 : MELVAL=IVAL(ICOMP) 1765 : IGMN=MIN(IGAU,VELCHE(/1)) 1766 : IBMN=MIN(IB ,VELCHE(/2)) 1767 : XDDL(IE)=VELCHE(IGMN,IBMN) 1768 : IE=IE+1 1769 : 4093 CONTINUE 1770 : c 1771 : c on cherche les coordonnees des noeuds de l'element ib 1772 : c 1772 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1772 : CALL VPAST(XE,BPSS) 1773 : c bpss stocke la matrice de passage 1773 : CALL VCORLC (XE,XEL,BPSS) 1773 : CALL MATVEC(XDDL,XDDLOC,BPSS,6) 1774 : c 1775 : c on cherche les epaiseurs et on les moyenne, 1776 : c les excentrements et on les moyenne. 1777 : c 1778 : EPAIST=0.D0 1779 : MPTVAL=IVACAR 1780 : MELVAL=IVAL(1) 1781 : IF (MELVAL.NE.0) THEN 1782 : DO IGAU=1,NBPGAU 1783 : IGMN=MIN(IGAU,VELCHE(/1)) 1784 : IBMN=MIN(IB,VELCHE(/2)) 1785 : EPAIST=EPAIST+VELCHE(IGMN,IBMN) 1786 : ENDDO 1787 : EPAIST=EPAIST/NBPGAU 1788 : ENDIF 1789 : * 1790 : EXCEN=0.D0 1791 : MELVAL=IVAL(2) 1792 : IF (MELVAL.NE.0) THEN 1793 : DO IGAU=1,NBPGAU 1794 : IGMN=MIN(IGAU,VELCHE(/1)) 1795 : IBMN=MIN(IB,VELCHE(/2)) 1796 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 1797 : ENDDO 1798 : EXCEN=EXCEN/NBPGAU 1799 : ENDIF 1800 : c 1801 : c boucle sur les points de gauss 1802 : c 1803 : DO 5093 IGAU=1,NBPTEL 1804 : * 1805 : * dans le cas des matériaux orthotropes, les déformations sont d'abord 1806 : * calculées dans le repère d'orthotropie (les formules utilisées par les 1807 : * routines rcdst et bmfdst ne sont valables que dans ce repère); elles 1808 : * sont ensuite exprimées dans le repère local de l'élément. 1809 : * 1810 : IF(IMAT.EQ.2)THEN 1811 : IF(CMATE.NE.'ISOTROPE')THEN 1812 : IF(IGAU.LE.NBGCOS)THEN 1813 : MPTVAL=IVAMAT 1814 : MELVAL=IVAL(2) 1815 : IBMN=MIN(IB ,VELCHE(/2)) 1816 : IGMN=MIN(IGAU,VELCHE(/1)) 1817 : COSA=VELCHE(IGMN,IBMN) 1818 : MELVAL=IVAL(3) 1819 : IBMN=MIN(IB ,VELCHE(/2)) 1820 : IGMN=MIN(IGAU,VELCHE(/1)) 1821 : SINA=VELCHE(IGMN,IBMN) 1822 : ENDIF 1823 : ENDIF 1824 : ENDIF 1825 : c 1826 : c on cherche la matrice de hooke 1827 : c 1828 : MPTVAL=IVAMAT 1829 : IF(IMAT.EQ.2) THEN 1830 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1831 : MELVAL=IVAL(1) 1832 : IBMN=MIN(IB ,IELCHE(/2)) 1833 : IGMN=MIN(IGAU,IELCHE(/1)) 1834 : MLREEL=IELCHE(IGMN,IBMN) 1835 : SEGACT MLREEL 1835 : CALL DOHOOO(PROG,LHOOK,DDHOMU) 1836 : SEGDES MLREEL 1837 : IF(CMATE.EQ.'ORTHOTRO') 1837 : + CALL CHGREP1(COSA,SINA,DDHOMU,LHOOK) 1838 : ENDIF 1839 : ELSE IF (IMAT.EQ.1) THEN 1840 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN 1841 : DO 9193 IM=1,NMATT 1842 : IF (IVAL(IM).NE.0) THEN 1843 : MELVAL=IVAL(IM) 1844 : IBMN=MIN(IB ,VELCHE(/2)) 1845 : IGMN=MIN(IGAU,VELCHE(/1)) 1846 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1847 : ELSE 1848 : VALMAT(IM)=0.D0 1849 : ENDIF 1850 : 9193 CONTINUE 1850 : CALL DOHDST(VALMAT,CMATE,IFOUR,NSTRS,DDHOOK,IRTD) 1851 : ENDIF 1851 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 1852 : ENDIF 1852 : call zero(bgene,nstrs,lre) 1853 : IF(CMATE.NE.'ISOTROPE')THEN 1854 : IF(IGAU.LE.NBGCOS)THEN 1855 : IF(IMAT.EQ.1) THEN 1856 : COSA=VALMAT(7) 1857 : SINA=VALMAT(8) 1858 : ENDIF 1859 : DO 1393 INO=1,NBNN 1860 : XX=COSA*XEL(1,INO)+SINA*XEL(2,INO) 1861 : YY=(-SINA)*XEL(1,INO)+COSA*XEL(2,INO) 1862 : XE(1,INO)=XX 1863 : XE(2,INO)=YY 1864 : 1393 CONTINUE 1865 : ENDIF 1866 : c 1867 : c termes de la matrice de rigidite relatifs 1868 : c aux cisaillements transverses 1869 : c 1869 : CALL RCDST(XE,NSTRS,LRE,DDHOMU, 1870 : 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) 1871 : c 1872 : c termes de la matrice b relatifs aux effets 1873 : c de membrane et de flexion 1874 : c 1874 : CALL BMFDST(IGAU,XE,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1875 : 1 WORK(1),WORK(10),WORK(19),BGENE,DUM) 1876 : * 1876 : CALL ROTB(BGENE,NSTRS,COSA,SINA) 1877 : ELSE 1878 : c 1879 : c termes de la matrice b relatifs aux cisaillements transverses 1880 : c 1880 : CALL RCDST(XEL,NSTRS,LRE,DDHOMU, 1881 : 1 WORK(1),WORK(10),WORK(19),REL,BGENE,1) 1882 : c 1883 : c termes de la matrice b relatifs aux effets 1884 : c de membrane et de flexion 1885 : c 1885 : CALL BMFDST(IGAU,XEL,NSTRS,QSIGAU,ETAGAU,SHPTOT,SHPWRK, 1886 : 1 WORK(1),WORK(10),WORK(19),BGENE,DJAC) 1887 : ENDIF 1888 : * 1889 : * on modifie la matrice b en cas d'excentrement 1890 : * 1891 : IF (EXCEN.NE.0.D0) THEN 1892 : DO 1593 IJL=1,3 1893 : DO 1593 IJC=1,LRE 1894 : BGENE(IJL,IJC)=BGENE(IJL,IJC)+EXCEN*BGENE(IJL+3,IJC) 1895 : 1593 CONTINUE 1896 : ENDIF 1897 : * 1897 : CALL DBST(BGENE,DDHOMU,XDDLOC,LRE,NSTRS,XSTRS) 1898 : c 1899 : c calcul des eps 2 1900 : c 1901 : IF(IREPS2.EQ.1)THEN 1902 : IF(CMATE.EQ.'ORTHOTRO')THEN 1902 : CALL DBDST2(XE,DDHOMU,XDDLOC,IGAU,BGENE,CMATE, 1903 : 1 COSA,SINA,XSTRS) 1904 : ELSE 1904 : CALL DBDST2(XEL,DDHOMU,XDDLOC,IGAU,BGENE,CMATE, 1905 : 1 COSA,SINA,XSTRS) 1906 : ENDIF 1907 : ENDIF 1908 : * 1909 : * changement de repere: ortho -> local 1910 : * 1911 : IF(CMATE.EQ.'ORTHOTRO') 1911 : 1 CALL CHGREP2(COSA,SINA,XSTRS,0,1) 1912 : c 1913 : c remplissage du segment contenant les contraintes 1914 : c 1915 : MPTVAL=IVASTR 1916 : DO 9093 ICOMP=1,NSTRS 1917 : MELVAL=IVAL(ICOMP) 1918 : IBMN=MIN(IB ,VELCHE(/2)) 1919 : VELCHE(IGAU,IBMN)=XSTRS(ICOMP) 1920 : 9093 CONTINUE 1921 : 5093 CONTINUE 1922 : 3093 CONTINUE 1923 : c 1924 : IF (IRTD.EQ.0) THEN 1925 : MOTERR(1:8)=CMATE 1926 : MOTERR(9:12)=NOMFR(MFR/2+1) 1927 : INTERR(1)=IFOUR 1927 : CALL ERREUR(81) 1928 : ENDIF 1929 : 9993 CONTINUE 1930 : SEGSUP,WRK2,WRK3,WRK4 1931 : GOTO 510 1932 : c____________________________________________________________________ 1933 : c____________________________________________________________________ 1934 : 99 CONTINUE 1935 : MOTERR(1:4)=NOMTP(MELE) 1936 : MOTERR(9:12)='SIGM' 1936 : CALL ERREUR(86) 1937 : * 1938 : c- Fin du sous-programme 1939 : 510 CONTINUE 1940 : SEGSUP MVELCH,WRK1 1941 : 1942 : RETURN 1943 : END 1944 : 1945 : 1946 :
© Cast3M 2003 - All rights reserved.
Disclaimer