1 : C EPSI4 SOURCE AM 13/12/16 21:15:38 7825 2 : SUBROUTINE EPSI4(IPMAIL,IVADEP,NDEP,IVAMAT,NMATT,IVACAR,NCARR, 3 : & IPMINT,IVECT,MELE,LHOOK,IREPS2,NBPTEL,NSTRS,MFR, 4 : & NBPGAU,LRE,LW,IVAEPS,UZDPG,RYDPG,RXDPG,ISOUS,IIPDPG,CMATE) 5 : *---------------------------------------------------------------------* 6 : * * 7 : * CALCUL DES DEFORMATIONS * 8 : * * 9 : * linespring,tuyau fissure,barre,cerce,tuyo,poi1 * 10 : * * 11 : *---------------------------------------------------------------------* 12 : * * 13 : * ENTREES : * 14 : * ________ * 15 : * * 16 : * IPMAIL Pointeur sur un segment MELEME * 17 : * IVADEP Pointeur sur le chamelem de deplacements * 18 : * NDEP Nombre de composantes de deplacements * 19 : * IVACAR Pointeur sur les chamelems de caracteristiques * 20 : * NCARR Nombre de caracteristiques geometriques * 21 : * IVECT Flag indiquant si on a entre les axes locaux * 22 : * MELE Numero de l'element fini * 23 : * LHOOK Dimension de la matrice de Hooke * 24 : * IRESP2 Flag pour indiquer si on veut les contraintes * 25 : * de Piola-Kirchhoff * 26 : * NBPTEL Nombre de points par element * 27 : * NSTRS Nombre de composante de contraintes/deformations * 28 : * MFR Numero de formulation de l'element fini * 29 : * pour une matrice de hooke * 30 : * NBPGAU Nombre de point d'integration pour la rigidite * 31 : * LRE Nombre de ddl dans la matrice de rigidite * 32 : * LW Dimension du tableau de travail de l'element * 33 : * * 34 : * SORTIES : * 35 : * ________ * 36 : * * 37 : * IVAEPS pointeur sur un segment MPTVAL contenant les * 38 : * les melvals de deformations * 39 : * * 40 : *---------------------------------------------------------------------* 41 : IMPLICIT INTEGER(I-N) 42 : IMPLICIT REAL*8(A-H,O-Z) 43 : C 44 : -INC CCOPTIO 45 : -INC CCHAMP 46 : -INC SMCHAML 47 : -INC SMCHPOI 48 : -INC SMELEME 49 : -INC SMCOORD 50 : -INC SMMODEL 51 : -INC SMINTE 52 : -INC SMLREEL 53 : C 54 : C 55 : SEGMENT WRK1 56 : REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS) 57 : REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS) 58 : ENDSEGMENT 59 : * 60 : SEGMENT WRK2 61 : REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE) 62 : ENDSEGMENT 63 : * 64 : SEGMENT WRK4 65 : REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE) 66 : ENDSEGMENT 67 : * 68 : SEGMENT WRK5 69 : REAL*8 XGENE(NSTN,LRN) 70 : ENDSEGMENT 71 : * 72 : SEGMENT WRK3 73 : REAL*8 WORK(LW) 74 : ENDSEGMENT 75 : C 76 : SEGMENT NOTYPE 77 : CHARACTER*16 TYPE(NBTYPE) 78 : ENDSEGMENT 79 : C 80 : SEGMENT MPTVAL 81 : INTEGER IPOS(NS),NSOF(NS) 82 : INTEGER IVAL(NCOSOU) 83 : CHARACTER*16 TYVAL(NCOSOU) 84 : ENDSEGMENT 85 : POINTEUR MPTVA1.MPTVAL 86 : * 87 : CHARACTER*(NCONCH) CONM 88 : CHARACTER*8 CMATE 89 : PARAMETER (NINF=3) 90 : INTEGER INFOS(NINF) 91 : logical dcmat2 92 : C 93 : C INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT 94 : C DE LA SECTION EN DEFO PLANE GENERALISEE 95 : C 96 : IF (IFOUR.EQ.-3)THEN 97 : IP=IIPDPG 98 : SEGACT MCOORD 99 : IREF=(IP-1)*(IDIM+1) 100 : XDPGE=XCOOR(IREF+1) 101 : YDPGE=XCOOR(IREF+2) 102 : ELSE 103 : XDPGE=0.D0 104 : YDPGE=0.D0 105 : ENDIF 106 : * 107 : MELEME=IPMAIL 108 : NBNN=NUM(/1) 109 : NBELEM=NUM(/2) 110 : * 111 : NHRM=NIFOUR 112 : MINTE=IPMINT 113 : NBBB=NBNN 114 : dcmat2 = .false. 115 : 116 : if (CMATE.EQ.'IMPELAST'.OR.CMATE.EQ.'IMPVOIGT'.or. 117 : &cmate.eq.'IMPMAXWE'.OR.cmate.eq.'IMPCOMPL') goto 45 118 : C_______________________________________________________________________ 119 : C 120 : C NUMERO DES ETIQUETTES : 121 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 122 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 123 : C 5 CONTINUE 124 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 125 : C 44 CONTINUE 126 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 127 : C_______________________________________________________________________ 128 : C 129 : IF (MELE.LE.100) 130 : &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 131 : 1 99,99,99,99,99,99,99,99,99,30,99,99,99,99,99,99,99,99,99,99, 132 : 2 99,99,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99, 133 : 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 134 : 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99 135 : 5 ),MELE 136 : IF (MELE.LE.200) 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,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 139 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 140 : 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 141 : 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 142 : 5 34),MELE-100 143 : IF (MELE.LE.300) 144 : &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 145 : 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 146 : 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34, 147 : 3 34,34,34,34,265,266,266,266),MELE-200 148 : C 149 : 34 CONTINUE 150 : GOTO 99 151 : C 152 : C____________________________________________________________________ 153 : C 154 : C ELEMENT LINESPRING LISP ET LISM 155 : C____________________________________________________________________ 156 : C 157 : 30 CONTINUE 158 : NSTR=NSTRS 159 : NSTRS=2 160 : C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1 161 : C 162 : SEGINI WRK1,WRK3 163 : C 164 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 165 : C 166 : DO 3030 IB=1,NBELEM 167 : C 168 : C ON CHERCHE LES DEPLACEMENTS 169 : C 170 : IE=1 171 : DO 4030 IGAU=1,NBNN 172 : MPTVAL=IVADEP 173 : DO 4030 ICOMP=1,NDEP 174 : MELVAL=IVAL(ICOMP) 175 : IGMN=MIN(IGAU,VELCHE(/1)) 176 : IBMN=MIN(IB ,VELCHE(/2)) 177 : XDDL(IE)=VELCHE(IGMN,IBMN) 178 : IE=IE+1 179 : 4030 CONTINUE 180 : C 181 : C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE 182 : C 182 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 183 : C 184 : C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS 185 : C 186 : IE=1 187 : DO 7030 IC=1,3,2 188 : MPTVAL=IVACAR 189 : DO 7030 ICOMP=1,NCARR 190 : MELVAL=IVAL(ICOMP) 191 : IF (MELVAL.NE.0) THEN 192 : IGMN=MIN(IC,VELCHE(/1)) 193 : IBMN=MIN(IB,VELCHE(/2)) 194 : WORK(IE)=VELCHE(IGMN,IBMN) 195 : ELSE 196 : WORK(IE)=0.D0 197 : ENDIF 198 : IE=IE+1 199 : 7030 CONTINUE 200 : C 201 : C CALCUL DES DEFORMATIONS 202 : C 202 : CALL LISPEP(XE,WORK,XDDL,WORK(11),WORK(20), 203 : 1 WORK(29),NBPGAU,WORK(53)) 204 : C 205 : IE=1 206 : DO 8030 IGAU=1,NBPTEL 207 : MPTVAL=IVAEPS 208 : DO 8030 ICOMP=1,NSTR 209 : MELVAL=IVAL(ICOMP) 210 : IBMN=MIN(IB ,VELCHE(/2)) 211 : VELCHE(IGAU,IBMN)=WORK(52+IE) 212 : IE=IE+1 213 : 8030 CONTINUE 214 : 3030 CONTINUE 215 : SEGSUP WRK1,WRK3 216 : GOTO 510 217 : C_______________________________________________________________________ 218 : C 219 : C TUYAU FISSURE 220 : C_______________________________________________________________________ 221 : C 222 : 43 CONTINUE 223 : SEGINI WRK1,WRK3 224 : C 225 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 226 : C 227 : DO 3043 IB=1,NBELEM 228 : C 229 : C ON CHERCHE LES DEPLACEMENTS 230 : C 231 : IE=1 232 : DO 4043 IGAU=1,NBNN 233 : MPTVAL=IVADEP 234 : DO 4043 ICOMP=1,NDEP 235 : MELVAL=IVAL(ICOMP) 236 : IGMN=MIN(IGAU,VELCHE(/1)) 237 : IBMN=MIN(IB ,VELCHE(/2)) 238 : XDDL(IE)=VELCHE(IGMN,IBMN) 239 : IE=IE+1 240 : 4043 CONTINUE 241 : C 242 : C ON CHERCHE LES CARACTERISTIQUES 243 : C 244 : MPTVAL=IVACAR 245 : DO 7043 IC=1,9 246 : MELVAL=IVAL(IC) 247 : IF (MELVAL.NE.0) THEN 248 : IBMN=MIN(IB,VELCHE(/2)) 249 : WORK(IC)=VELCHE(1,IBMN) 250 : ELSE 251 : WORK(IC)=0 252 : ENDIF 253 : 7043 CONTINUE 254 : C 255 : C ON CALCULE LES DEFORMATIONS 256 : C 256 : CALL TUFEPS(XDDL,WORK,WORK(31),KERRE) 257 : IF(KERRE.NE.0) THEN 258 : INTERR(1)=IB 258 : IF(KERRE.EQ.1) CALL ERREUR(137) 258 : IF(KERRE.EQ.2) CALL ERREUR(123) 258 : IF(KERRE.EQ.3) CALL ERREUR(266) 259 : GOTO 5043 260 : ENDIF 261 : C 262 : C ON REMPLIT LES DEFORMATIONS 263 : C 264 : MPTVAL=IVAEPS 265 : DO 6043 ICOMP=1,NSTRS 266 : MELVAL=IVAL(ICOMP) 267 : IBMN=MIN(IB,VELCHE(/2)) 268 : VELCHE(1,IBMN)=WORK(30+ICOMP) 269 : 6043 CONTINUE 270 : C 271 : 3043 CONTINUE 272 : 5043 CONTINUE 273 : SEGSUP WRK1,WRK3 274 : GOTO 510 275 : C_______________________________________________________________________ 276 : C 277 : C ELEMENT POI1 / matériau IMPEDANCE 278 : C_______________________________________________________________________ 279 : C 280 : 45 CONTINUE 281 : IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR. 282 : & (CMATE.eq.'IMPMAXWE').OR.(CMATE.eq.'IMPCOMPL').OR. 283 : & (MFR.EQ.26.OR.MFR.EQ.28)) THEN 284 : mptva1 = ivadep 285 : mptval = ivaeps 286 : if (ival(/1).eq.mptva1.ival(/1)/2) dcmat2 = .true. 287 : numstr = ival(/1) 288 : do iv = 1,ival(/1) 289 : melva1 = mptva1.ival(iv) 290 : melval = ival(iv) 291 : 292 : * detecte impedance "sur mesure" 293 : *tc les lignes ci dessous sont pout le comilateur 294 : if( .not. dcmat2 ) then 295 : melva2=melva1 296 : inmbid=0 297 : ICC2=1 298 : else 299 : inmbid=numstr 300 : icc2=2 301 : endif 302 : do ib=1,nbnn 303 : C 304 : C ON CHERCHE LES DEPLACEMENTS 305 : C 306 : DO 4143 IGAU=1,NBNN 307 : IGMN=MIN(IGAU,MELVA1.VELCHE(/1)) 308 : IBMN=MIN(IB ,MELVA1.VELCHE(/2)) 309 : valalf = MELVA1.VELCHE(IGMN,IBMN) 310 : VELCHE(IGMN,IBMN) = valalf 311 : if (lre.eq.12) then 312 : * impedance segment 313 : * if(igau.eq.1) VELCHE(IGMN,IBMN) = valalf - MELVA1.VELCHE(2,IBMN) 314 : if(igau.eq.2) VELCHE(IGMN,IBMN) = valalf - MELVA1.VELCHE(1,IBMN) 315 : endif 316 : if(dcmat2) then 317 : * impedance segment composante mixte 318 : if (igau.eq.1) then 319 : melva2 = mptva1.ival(iv + inmbid) 320 : vala2 = MELVA2.VELCHE(ICC2,IBMN) 321 : VELCHE(IGMN,IBMN) = valalf - vala2 322 : endif 323 : if(igau.eq.2) VELCHE(IGMN,IBMN)= VELCHE(1,IBMN)*(-1) 324 : endif 325 : 4143 CONTINUE 326 : ENDDO 327 : 328 : enddo 329 : GOTO 510 330 : ENDIF 331 : 332 : IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN 333 : GO TO 99 334 : ENDIF 335 : C 336 : SEGINI WRK1,WRK3 337 : C 338 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 339 : C 340 : DO 3045 IB=1,NBELEM 341 : KERRE=0 342 : C 343 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 344 : C 344 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 345 : C 346 : C ON CALCULE LES DEFORMATIONS 347 : C 347 : CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK) 348 : C 349 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 350 : C 351 : ID=1 352 : DO 7045 IGAU=1,NBPTEL 353 : MPTVAL=IVAEPS 354 : DO 7045 ICOMP=1,NSTRS 355 : MELVAL=IVAL(ICOMP) 356 : IBMN=MIN(IB ,VELCHE(/2)) 357 : VELCHE(IGAU,IBMN)=WORK(ID) 358 : ID=ID+1 359 : 7045 CONTINUE 360 : 3045 CONTINUE 361 : SEGSUP WRK1,WRK3 362 : GOTO 510 363 : C_______________________________________________________________________ 364 : C 365 : C BARRE ET CERCE 366 : C_______________________________________________________________________ 367 : 368 : C 369 : 46 CONTINUE 370 : * 371 : IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN 372 : GO TO 99 373 : ENDIF 374 : * 375 : SEGINI WRK1,WRK3 376 : C 377 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 378 : C 379 : DO 3046 IB=1,NBELEM 380 : KERRE=0 381 : C 382 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 383 : C 383 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 384 : C 385 : C ON CHERCHE LES DEPLACEMENTS 386 : C 387 : NDDD=NDEP 388 : IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3 389 : IE=1 390 : DO 4046 IGAU=1,NBNN 391 : MPTVAL=IVADEP 392 : DO 4046 ICOMP=1,NDDD 393 : MELVAL=IVAL(ICOMP) 394 : IGMN=MIN(IGAU,VELCHE(/1)) 395 : IBMN=MIN(IB ,VELCHE(/2)) 396 : XDDL(IE)=VELCHE(IGMN,IBMN) 397 : IE=IE+1 398 : 4046 CONTINUE 399 : C 400 : C ON CALCULE LES DEFORMATIONS 401 : C 401 : IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2) 401 : IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE) 401 : IF(MELE.EQ.123) CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU, 402 : & NBPGAU,IB) 403 : IF(KERRE.EQ.1) THEN 403 : CALL ERREUR(601) 404 : GO TO 3046 405 : ENDIF 406 : C 407 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 408 : C 409 : ID=1 410 : DO 7046 IGAU=1,NBPTEL 411 : MPTVAL=IVAEPS 412 : DO 7046 ICOMP=1,NSTRS 413 : MELVAL=IVAL(ICOMP) 414 : IBMN=MIN(IB ,VELCHE(/2)) 415 : VELCHE(IGAU,IBMN)=WORK(ID) 416 : ID=ID+1 417 : 7046 CONTINUE 418 : C 419 : 3046 CONTINUE 420 : SEGSUP WRK1,WRK3 421 : GOTO 510 422 : C____________________________________________________________________ 423 : C 424 : C ELEMENT BARRE 3D EXCENTRE (BAEX) 425 : C____________________________________________________________________ 426 : C 427 : 124 CONTINUE 428 : NBBB=NBNN 429 : NSTN=NBNN 430 : LRN =LRE 431 : SEGINI WRK1,WRK3,WRK5 432 : C 433 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 434 : C 435 : DO 3108 IB=1,NBELEM 436 : C 437 : C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON 438 : C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK 439 : C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ 440 : C 441 : MPTVAL=IVACAR 442 : DO IC=1,NCARR 443 : IF(IVAL(IC).NE.0) THEN 444 : MELVAL=IVAL(IC) 445 : IBMN=MIN(IB,VELCHE(/2)) 446 : WORK(IC)=VELCHE(1,IBMN) 447 : ELSE 448 : WORK(IC)=0.D0 449 : ENDIF 450 : END DO 451 : SECT=WORK(1) 452 : C 453 : C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE 454 : C 454 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 454 : CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE) 455 : IF(KERRE.NE.0) INTERR(1)=ISOUS 456 : IF(KERRE.NE.0) INTERR(2)=IB 456 : IF(KERRE.EQ.1) CALL ERREUR(128) 457 : C 458 : C ON CHERCHE LES DEPLACEMENTS 459 : C 460 : IE=1 461 : DO 4108 IGAU=1,NBNN 462 : MPTVAL=IVADEP 463 : DO 4108 ICOMP=1,NDEP 464 : MELVAL=IVAL(ICOMP) 465 : IGMN=MIN(IGAU,VELCHE(/1)) 466 : IBMN=MIN(IB ,VELCHE(/2)) 467 : XDDL(IE)=VELCHE(IGMN,IBMN) 468 : IE=IE+1 469 : 4108 CONTINUE 470 : C 471 : C ON CALCULE LES DEFORMATIONS 472 : C 472 : CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE) 473 : C 474 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATION 475 : C 476 : ID=1 477 : DO 7108 IGAU=1,NBPTEL 478 : MPTVAL=IVAEPS 479 : DO 7108 ICOMP=1,NSTRS 480 : MELVAL=IVAL(ICOMP) 481 : IBMN=MIN(IB ,VELCHE(/2)) 482 : VELCHE(IGAU,IBMN)=XSTRS(ID) 483 : ID=ID+1 484 : 7108 CONTINUE 485 : C 486 : 3108 CONTINUE 487 : SEGSUP WRK1,WRK3,WRK5 488 : GOTO 510 489 : C_______________________________________________________________________ 490 : C 491 : C LIA2 : element de liaison a 2 noeuds (6 ddl par 492 : C noeuds) 493 : C_______________________________________________________________________ 494 : C 495 : 125 CONTINUE 496 : NBBB=NBNN 497 : NSTN=3 498 : LRN =3 499 : SEGINI WRK1,WRK3,WRK5 500 : C 501 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 502 : C 503 : DO 3109 IB=1,NBELEM 504 : C 505 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 506 : C 507 : MPTVAL=IVACAR 508 : DO IC=1,NCARR 509 : IF(IVAL(IC).NE.0) THEN 510 : MELVAL=IVAL(IC) 511 : IBMN=MIN(IB,VELCHE(/2)) 512 : WORK(IC)=VELCHE(1,IBMN) 513 : ELSE 514 : WORK(IC)=0.D0 515 : ENDIF 516 : END DO 517 : C 517 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 517 : CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE) 518 : IF(KERRE.NE.0) INTERR(1)=ISOUS 519 : IF(KERRE.NE.0) INTERR(2)=IB 519 : IF(KERRE.EQ.1) CALL ERREUR(128) 520 : C 521 : C ON CHERCHE LES DEPLACEMENTS 522 : C 523 : IE=1 524 : DO 4109 IGAU=1,NBNN 525 : MPTVAL=IVADEP 526 : DO 4109 ICOMP=1,NDEP 527 : MELVAL=IVAL(ICOMP) 528 : IGMN=MIN(IGAU,VELCHE(/1)) 529 : IBMN=MIN(IB ,VELCHE(/2)) 530 : XDDL(IE)=VELCHE(IGMN,IBMN) 531 : IE=IE+1 532 : 4109 CONTINUE 533 : C 533 : CALL ZERO(XSTRS,NSTRS,1) 534 : C 535 : C ON CALCULE LES DEFORMATIONS !!! a completer 536 : C pour le moment on ne met rien dans les deformations 537 : C 537 : CCC CALL DEFLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS) 538 : C 539 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 540 : C 541 : ID=1 542 : DO 7109 IGAU=1,NBPTEL 543 : MPTVAL=IVAEPS 544 : DO 7109 ICOMP=1,NSTRS 545 : MELVAL=IVAL(ICOMP) 546 : IBMN=MIN(IB ,VELCHE(/2)) 547 : VELCHE(IGAU,IBMN)=XSTRS(ID) 548 : ID=ID+1 549 : 7109 CONTINUE 550 : C 551 : 3109 CONTINUE 552 : SEGSUP WRK1,WRK3,WRK5 553 : GOTO 510 554 : C_______________________________________________________________________ 555 : C 556 : C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds) 557 : C_______________________________________________________________________ 558 : C 559 : 265 CONTINUE 560 : NBBB=NBNN 561 : NSTN=3 562 : LRN =3 563 : SEGINI WRK1,WRK3,WRK4 564 : C 565 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 566 : C 567 : DO 3110 IB=1,NBELEM 568 : C 569 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 570 : C 571 : MPTVAL=IVAMAT 572 : DO IC=1,NMATT 573 : IF(IVAL(IC).NE.0) THEN 574 : MELVAL=IVAL(IC) 575 : IBMN=MIN(IB,VELCHE(/2)) 576 : WORK(IC)=VELCHE(1,IBMN) 577 : ELSE 578 : WORK(IC)=0.D0 579 : ENDIF 580 : END DO 581 : C 581 : CALL MAPALU(NMATT,WORK,BPSS,IDIM) 582 : C 583 : C ON CHERCHE LES DEPLACEMENTS 584 : C 585 : IE=1 586 : DO 4110 IGAU=1,NBNN 587 : MPTVAL=IVADEP 588 : DO 4110 ICOMP=1,NDEP 589 : MELVAL=IVAL(ICOMP) 590 : IGMN=MIN(IGAU,VELCHE(/1)) 591 : IBMN=MIN(IB ,VELCHE(/2)) 592 : XDDL(IE)=VELCHE(IGMN,IBMN) 593 : IE=IE+1 594 : 4110 CONTINUE 595 : C 596 : C CALCUL DES DEPLACEMENTS LOCAUX 597 : C 598 : IAW1 = 101 599 : IAW2 = IAW1 + LRE 599 : CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM) 600 : * 600 : CALL ZERO(XSTRS,NSTRS,1) 601 : C 602 : C ON CALCULE LES DEFORMATIONS 603 : C 603 : CALL DEFJOI(XDDL,LRE,XSTRS,NDEP) 604 : C 605 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 606 : C 607 : ID=1 608 : DO 7110 IGAU=1,NBPTEL 609 : MPTVAL=IVAEPS 610 : DO 7110 ICOMP=1,NSTRS 611 : MELVAL=IVAL(ICOMP) 612 : IBMN=MIN(IB ,VELCHE(/2)) 613 : VELCHE(IGAU,IBMN)=XSTRS(ID) 614 : ID=ID+1 615 : 7110 CONTINUE 616 : C 617 : 3110 CONTINUE 618 : SEGSUP WRK1,WRK3,WRK4 619 : GOTO 510 620 : C_______________________________________________________________________ 621 : C 622 : C ELEMENT TUYO 623 : C_______________________________________________________________________ 624 : C 625 : 96 CONTINUE 626 : SEGINI WRK1,WRK3 627 : C 628 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 629 : C 630 : DO 3096 IB=1,NBELEM 631 : C 632 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 633 : C 633 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 634 : C 635 : C ON CHERCHE LES DEPLACEMENTS 636 : C 637 : IE=1 638 : DO 4096 IGAU=1,NBNN 639 : MPTVAL=IVADEP 640 : DO 4096 ICOMP=1,NDEP 641 : MELVAL=IVAL(ICOMP) 642 : IGMN=MIN(IGAU,VELCHE(/1)) 643 : IBMN=MIN(IB ,VELCHE(/2)) 644 : XDDL(IE)=VELCHE(IGMN,IBMN) 645 : IE=IE+1 646 : 4096 CONTINUE 647 : C 648 : C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB 649 : C 650 : MPTVAL=IVACAR 651 : DO 6096 IC=1,NCARR 652 : IF(IVAL(IC).NE.0) THEN 653 : MELVAL=IVAL(IC) 654 : IBMN=MIN(IB,VELCHE(/2)) 655 : WORK(IC)=VELCHE(1,IBMN) 656 : ELSE 657 : WORK(IC)=0 658 : ENDIF 659 : 6096 CONTINUE 660 : C 661 : C CAS OU ON A LU LE MOT VECTEUR 662 : C 663 : IF (IVECT.EQ.1) THEN 664 : IF (IVAL(NCARR).NE.0) THEN 665 : MELVAL=IVAL(NCARR) 666 : IBMN=MIN(IB,IELCHE(/2)) 667 : IP=IELCHE(1,IBMN) 668 : IREF=(IP-1)*(IDIM+1) 669 : DO 6196 IC=1,IDIM 670 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 671 : 6196 CONTINUE 672 : ELSE 673 : DO 6296 IC=1,IDIM 674 : WORK(NCARR+IC-1)=0. 675 : 6296 CONTINUE 676 : ENDIF 677 : ENDIF 678 : C 679 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 680 : C EQUIVALENTE 681 : IF(MELE.EQ.42) THEN 682 : CISA=WORK(4) 683 : VX=WORK(5) 684 : VY=WORK(6) 685 : VZ=WORK(7) 685 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2) 686 : ENDIF 687 : C 688 : C ON CALCULE LES DEFORMATIONS 689 : C 690 : youbib=0.d0 691 : xnubid=1. 691 : CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2,youbid 692 : $ , xnubid) 693 : C 694 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 695 : C 696 : ID=12 697 : MPTVAL=IVAEPS 698 : DO 7096 IGAU=1,NBPTEL 699 : DO 7096 ICOMP=1,NSTRS 700 : MELVAL=IVAL(ICOMP) 701 : IBMN=MIN(IB ,VELCHE(/2)) 702 : VELCHE(IGAU,IBMN)=WORK(ID) 703 : ID=ID+1 704 : 7096 CONTINUE 705 : C 706 : 3096 CONTINUE 707 : SEGSUP WRK1,WRK3 708 : GOTO 510 709 : C_______________________________________________________________________ 710 : C 711 : C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4 712 : C_______________________________________________________________________ 713 : C 714 : 266 CONTINUE 715 : 716 : NBNO=NBNN 717 : SEGINI WRK1,WRK2,WRK4 718 : C 719 : DO 3266 IB=1,NBELEM 720 : C 721 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB 722 : C 722 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 723 : C 724 : C 725 : C ON CHERCHE LES DEPLACEMENTS 726 : C 727 : MPTVAL=IVADEP 728 : IE=1 729 : DO 2266 IGAU=1,NBNN 730 : DO 2266 ICOMP=1,NDEP 731 : MELVAL=IVAL(ICOMP) 732 : IGMN=MIN(IGAU,VELCHE(/1)) 733 : IBMN=MIN(IB ,VELCHE(/2)) 734 : XDDL(IE)=VELCHE(IGMN,IBMN) 735 : IE=IE+1 736 : 2266 CONTINUE 737 : C 738 : C BOUCLE SUR LES POINTS DE GAUSS 739 : C 740 : DO 4266 IGAU=1,NBPGAU 741 : C 741 : CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) 742 : C 742 : CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, 743 : . NSTRS,NBNO,LRE,MELE,SHPWRK,BGENE,DJAC,IRRT) 744 : C IRRT.NE.0 JACOBIEN <= 0 745 : IF(IRRT.NE.0) THEN 746 : INTERR(1)=IB 746 : CALL ERREUR(612) 747 : GOTO 99266 748 : ENDIF 749 : C 749 : CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS) 750 : C 751 : C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS 752 : C 753 : MPTVAL=IVAEPS 754 : DO 9266 ICOMP=1,NSTRS 755 : MELVAL=IVAL(ICOMP) 756 : IGMN=MIN(IGAU,VELCHE(/1)) 757 : IBMN=MIN(IB ,VELCHE(/2)) 758 : VELCHE(IGMN,IBMN)=XSTRS(ICOMP) 759 : 9266 CONTINUE 760 : 4266 CONTINUE 761 : 3266 CONTINUE 762 : C 763 : 99266 CONTINUE 764 : SEGSUP WRK1,WRK2,WRK4 765 : GOTO 510 766 : *____________________________________________________________________ 767 : 99 CONTINUE 768 : MOTERR(1:4)=NOMTP(MELE) 769 : MOTERR(9:12)='EPSI' 769 : CALL ERREUR(86) 770 : * 771 : 510 CONTINUE 772 : RETURN 773 : END 774 : 775 : 776 : 777 : 778 : 779 : 780 : 781 : 782 : 783 : 784 : 785 : 786 : 787 : 788 : 789 : 790 : 791 : 792 : 793 : 794 : 795 : 796 : 797 :
© Cast3M 2003 - All rights reserved.
Disclaimer