1 : C RIGI4 SOURCE CHAT 12/10/25 21:15:04 7548 2 : SUBROUTINE RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, 3 : & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK, 4 : & NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG) 5 : *---------------------------------------------------------------------* 6 : * ________________________ * 7 : * | | * 8 : * | CALCUL DE LA RIGIDITE | * 9 : * |________________________| * 10 : * * 11 : * poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joint 3D, * 12 : * cerce, tuyo,joints 2D, litu,zone cohesives * 13 : * * 14 : *---------------------------------------------------------------------* 15 : * * 16 : * * 17 : * ENTREES : * 18 : * ________ * 19 : * * 20 : * MATE Numero du materiau * 21 : * MELE Numero de l'element fini * 22 : * IPMAIL Pointeur sur un segment MELEME * 23 : * IPMINT Pointeur sur un segment MINTE * 24 : * NBPGAU Nombre de point d'integration pour la rigidite * 25 : * LRE Nombre de ddl dans la matrice de rigidite * 26 : * NSTRS Nombre de composante de contraintes/deformations * 27 : * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou * 28 : * pour une matrice de hooke * 29 : * IVACAR Pointeur sur un segment MPTVAL pour les caracteri- * 30 : * stiques * 31 : * IVECT FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL * 32 : * CMATE Nom du materiau * 33 : * MFR Numero de la formulation element fini * 34 : * NBGMAT Taille maxi des melval du materiau (pt de gauss) * 35 : * NELMAT Taille maxi des melval du materiau (No d'element) * 36 : * IMAT (2 il y a une matrice de HOOKE,1 non ) * 37 : * NMATT Nombre de composantes de materiau (IMAT=1) * 38 : * NCARR Nombre de caracteristiques geometriques * 39 : * ISOUS NUMERO DE LA SOUS-ZONE * 40 : * LW Dimension du tableau de travail * 41 : * IPORE nombre de fonctions de forme 42 : * * 43 : * * 44 : * SORTIES : * 45 : * ________ * 46 : * * 47 : * IPMATR pointeur sur la rigidite de la sous-zone * 48 : * * 49 : * * 50 : *---------------------------------------------------------------------* 51 : IMPLICIT INTEGER(I-N) 52 : IMPLICIT REAL*8(A-H,O-Z) 53 : * 54 : -INC CCOPTIO 55 : -INC CCHAMP 56 : -INC CCREEL 57 : *- 58 : -INC SMCHAML 59 : -INC SMINTE 60 : -INC SMELEME 61 : -INC SMRIGID 62 : -INC SMMODEL 63 : -INC SMCOORD 64 : -INC SMLREEL 65 : -INC SMLMOTS 66 : * 67 : SEGMENT WRK1 68 : REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS) 69 : REAL*8 REL(LRE,LRE) , XE(3,NBBB) 70 : ENDSEGMENT 71 : * 72 : SEGMENT WRK2 73 : REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE) 74 : ENDSEGMENT 75 : * 76 : SEGMENT WRK3 77 : REAL*8 WORK(LW) 78 : ENDSEGMENT 79 : * 80 : SEGMENT WRK4 81 : REAL*8 BPSS(3,3),XEL(3,NBBB) 82 : ENDSEGMENT 83 : * 84 : SEGMENT WRK5 85 : REAL*8 XGENE(NSTN,LRN) 86 : ENDSEGMENT 87 : * 88 : SEGMENT WRK6 89 : REAL*8 PSS(3,3) 90 : ENDSEGMENT 91 : * 92 : SEGMENT WRK7 93 : REAL*8 PROPEL(14) 94 : REAL*8 OUT(5) 95 : REAL*8 WORK1(24*24) 96 : ENDSEGMENT 97 : * 98 : SEGMENT,MVELCH 99 : REAL*8 VALMAT(NV1) 100 : ENDSEGMENT 101 : * 102 : SEGMENT MPTVAL 103 : INTEGER IPOS(NS) ,NSOF(NS) 104 : INTEGER IVAL(NCOSOU) 105 : CHARACTER*16 TYVAL(NCOSOU) 106 : ENDSEGMENT 107 : * 108 : CHARACTER*4 lesinc(7),lesdua(7) 109 : DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/ 110 : DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/ 111 : DATA X577/.577350269189626D0/ 112 : DIMENSION CRIGI(12),CMASS(12) 113 : CHARACTER*4 CMOT 114 : CHARACTER*8 CMATE 115 : * 116 : MELEME=IPMAIL 117 : NBNN=NUM(/1) 118 : NBELEM=NUM(/2) 119 : * 120 : NV1=NMATT 121 : SEGINI,MVELCH 122 : * 123 : XMATRI=IPMATR 124 : * LVAL = (LRE*(LRE+1))/2 125 : NLIGRP=LRE 126 : NLIGRD=LRE 127 : * 128 : * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT 129 : * DE LA SECTION EN DEFO PLANE GENERALISEE 130 : * 131 : * PPJ IF (IFOUR.EQ.-3)THEN 132 : IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN 133 : IP=IIPDPG 134 : SEGACT MCOORD 135 : IREF=(IP-1)*(IDIM+1) 136 : XDPGE=XCOOR(IREF+1) 137 : YDPGE=XCOOR(IREF+2) 138 : ELSE 139 : XDPGE=0.D0 140 : YDPGE=0.D0 141 : ENDIF 142 : * 143 : NHRM=NIFOUR 144 : * 145 : MINTE=IPMINT 146 : IRTD=1 147 : * 148 : * 149 : * cas cmate 'STATIQUE' 150 : IF (mfr.eq.28) THEN 151 : jgn = 4 152 : if (ifour.eq.2) then 153 : jgm = 6 154 : segini mlmots 155 : iinc = mlmots 156 : do igm = 1,jgm 157 : mots(igm) = lesinc(igm) 158 : enddo 159 : segini mlmots 160 : idua = mlmots 161 : do igm= 1,jgm 162 : mots(igm) = lesdua(igm) 163 : enddo 164 : else if (ifour.lt.0) then 165 : jgm = 4 166 : segini mlmots 167 : iinc = mlmots 168 : mots(1) = lesinc(1) 169 : mots(2) = lesinc(2) 170 : mots(3) = lesinc(4) 171 : mots(4) = lesinc(5) 172 : segini mlmots 173 : idua = mlmots 174 : mots(1) = lesdua(1) 175 : mots(2) = lesdua(2) 176 : mots(3) = lesdua(4) 177 : mots(4) = lesdua(5) 178 : else if (ifour.eq.0) then 179 : jgm = 3 180 : segini mlmots 181 : iinc = mlmots 182 : mots(1) = lesinc(7) 183 : mots(2) = lesinc(3) 184 : mots(3) = lesinc(6) 185 : segini mlmots 186 : idua = mlmots 187 : mots(1) = lesdua(7) 188 : mots(2) = lesdua(3) 189 : mots(3) = lesdua(6) 190 : else if (ifour.eq.1) then 191 : * a faire 192 : endif 193 : ENDIF 194 : C 195 : C_______________________________________________________________________ 196 : C 197 : C NUMERO DES ETIQUETTES : 198 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 199 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 200 : C 5 CONTINUE 201 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 202 : C 44 CONTINUE 203 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 204 : C_______________________________________________________________________ 205 : C 206 : IF (MELE.LE.100) 207 : * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 208 : & GOTO ( 99, 29, 99, 99, 99, 99, 99, 99, 99, 99, 99 209 : * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT 210 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 211 : * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 212 : & , 99, 99, 99, 99, 99, 99, 29, 30, 99, 99, 99 213 : * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 214 : & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 43, 99 215 : * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO 216 : & , 45, 46, 99, 99, 99, 30, 99, 99, 99, 99, 99 217 : * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 218 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 219 : * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 220 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 221 : * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 222 : & , 99, 99, 99, 99, 99, 99, 29, 85, 86, 87, 88 223 : * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 224 : & , 99, 99, 99, 92, 99, 99, 46, 96, 29, 29, 99 225 : * HYQ4 226 : & , 99),MELE 227 : IF (MELE.LE.200) 228 : * HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 229 : & GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 230 : * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 231 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 232 : * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 233 : & , 99, 46, 124, 125, 126, 127, 99, 99, 99, 99, 99 234 : * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 235 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 236 : * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 237 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 238 : * TE56 PY91 TRH6 ???? ???? ???? ???? ???? ???? ???? ???? 239 : & , 99, 99, 92, 51, 51, 51, 51, 51, 51, 51, 51 240 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 241 : & , 51, 168, 169, 170, 171, 172, 51, 51, 51, 51, 51 242 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 243 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 244 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 245 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 246 : * ???? ???? 247 : & , 51, 51),MELE-100 248 : IF (MELE.LE.300) 249 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? 250 : & GOTO ( 51, 51, 51, 51, 51, 51, 51, 51, 51 251 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 252 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 253 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 254 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 255 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 256 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 257 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 258 : & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51 259 : * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? 260 : & , 51, 51, 51, 51, 258, 51, 260, 51, 51, 51, 51 261 : * JOI1 ZCO2 ZCO3 ZCO4 262 : & , 129, 266, 266, 266),MELE-200 263 : 51 CONTINUE 264 : GOTO 99 265 : C_______________________________________________________________________ 266 : C 267 : C ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO 268 : C_______________________________________________________________________ 269 : C 270 : 29 CONTINUE 271 : if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or. 272 : &cmate.eq.'IMPMAXWE'.or.cmate.eq.'IMPCOMPL') then 273 : MPTVAL=IVAMAT 274 : MELVAL=IVAL(1) 275 : * MPTVAL = IVACAR 276 : if (ival(/1).ge.1) then 277 : melva1 = ival(2) 278 : else 279 : melva1 = 0 280 : endif 281 : jddl = LRE/NBPGAU 282 : DO IB = 1,NBELEM 283 : * kich 1 pgau inutile 284 : IGAU = 1 285 : JDIAG = 0 286 : IBMN=MIN(IB,VELCHE(/2)) 287 : IGMN=MIN(IGAU,VELCHE(/1)) 288 : if (cmate.eq.'IMPCOMPL') then 289 : MLREEL=IELCHE(IGMN,IBMN) 290 : SEGACT MLREEL 291 : XRAID = prog(1) 292 : else 293 : XRAID = VELCHE(IGMN,IBMN) 294 : XTORS = XRAID 295 : if (melva1.gt.0) then 296 : XTORS = melva1.VELCHE(IGMN,IBMN) 297 : endif 298 : endif 299 : if (mfr.eq.27) then 300 : * cas point 301 : do j=1,jddl 302 : JDIAG = JDIAG + 1 303 : if (j.le.3) then 304 : RE(JDIAG,JDIAG,IB) = XRAID 305 : else 306 : RE(JDIAG,JDIAG,IB) = XTORS 307 : endif 308 : enddo 309 : else 310 : do j=1,jddl 311 : JDIAG = JDIAG + 1 312 : if (j.le.3) then 313 : RE(JDIAG,JDIAG,IB) = XRAID 314 : RE(JDIAG,JDIAG+jddl,IB) = XRAID*(-1.D0) 315 : else 316 : RE(JDIAG,JDIAG,IB) = XTORS 317 : RE(JDIAG,JDIAG+jddl,IB) = XTORS*(-1.D0) 318 : endif 319 : enddo 320 : do j=jddl+1,LRE 321 : JDIAG = JDIAG + 1 322 : if (j.le.jddl+3) then 323 : RE(JDIAG,JDIAG,IB) = XRAID 324 : RE(JDIAG,JDIAG-jddl,IB) = XRAID*(-1.D0) 325 : else 326 : RE(JDIAG,JDIAG,IB) = XTORS 327 : RE(JDIAG,JDIAG-jddl,IB) = XTORS*(-1.D0) 328 : endif 329 : enddo 330 : endif 331 : ENDDO 332 : SEGDES XMATRI 333 : goto 510 334 : endif 335 : if (mele.eq.2) goto 99 336 : 337 : NBBB=NBNN 338 : SEGINI WRK1,WRK3 339 : C 340 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 341 : C 342 : KERRE=0 343 : DO 3029 IB=1,NBELEM 344 : C 345 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 346 : C 346 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 347 : C 348 : C CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE 349 : C 350 : IF (MELE.EQ.98) THEN 350 : CALL ZERO(REL,LRE,LRE) 351 : GOTO 8029 352 : ENDIF 353 : C 354 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 355 : C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION 356 : C 357 : NCARR1=NCARR 358 : IF(IVECT.EQ.1) NCARR1=NCARR-1 358 : CALL ZERO(WORK,NCARR1,1) 359 : DO 4030 IGAU=1,NBNN 360 : MPTVAL=IVACAR 361 : DO 6029 IC=1,NCARR1 362 : IF (IVAL(IC).NE.0) THEN 363 : MELVAL=IVAL(IC) 364 : IBMN=MIN(IB,VELCHE(/2)) 365 : IGMN=MIN(IGAU,VELCHE(/1)) 366 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 367 : ELSE 368 : WORK(IC)=0.D0 369 : ENDIF 370 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 371 : 6029 CONTINUE 372 : 4030 CONTINUE 373 : C 374 : C CAS OU ON A LU LE MOT VECTEUR 375 : C 376 : IF (IVECT.EQ.1) THEN 377 : IF (IVAL(NCARR).NE.0) THEN 378 : MELVAL=IVAL(NCARR) 379 : IBMN=MIN(IB,IELCHE(/2)) 380 : IP=IELCHE(1,IBMN) 381 : IREF=(IP-1)*(IDIM+1) 382 : DO 6129 IC=1,IDIM 383 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 384 : 6129 CONTINUE 385 : ELSE 386 : DO 6229 IC=1,IDIM 387 : WORK(NCARR+IC-1)=0.D0 388 : 6229 CONTINUE 389 : ENDIF 390 : ENDIF 391 : C 392 : MPTVAL=IVAMAT 393 : C 394 : C CAS DE L'ACOUSTIQUE PURE 395 : C 396 : IF (MELE.EQ.97) THEN 397 : DO 7029 IM=1,NMATT 398 : IF (IVAL(IM).NE.0) THEN 399 : MELVAL=IVAL(IM) 400 : IBMN=MIN(IB,VELCHE(/2)) 401 : WORK(IM+9)=VELCHE(1,IBMN) 402 : ELSE 403 : WORK(IM+9)=0.D0 404 : ENDIF 405 : 7029 CONTINUE 406 : ELSE 407 : C 408 : C AUTRES CAS ...... 409 : C 410 : MELVAL=IVAL(1) 411 : * 412 : IF(CMATE.NE.'SECTION') THEN 413 : IBMN=MIN(IB,VELCHE(/2)) 414 : VALMAT(1)=VELCHE(1,IBMN) 415 : YOUNG=VALMAT(1) 416 : C 417 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 418 : C EQUIVALENTE 419 : IF(MELE.EQ.42) THEN 420 : PRES=WORK(4) 421 : CISA=WORK(5) 422 : WORK(4)=WORK(6) 423 : WORK(5)=WORK(7) 424 : WORK(6)=WORK(8) 425 : WORK(7)=PRES 426 : WORK(8)=CISA 426 : CALL TUYKAR(WORK,KERRE,2,YOUNG) 427 : ENDIF 428 : IF (KERRE.EQ.77) THEN 428 : CALL ERREUR(77) 429 : GOTO 510 430 : ENDIF 431 : C 432 : C ON CHERCHE LES COEFF DES MAT DE HOOKE 433 : C 434 : IF(IMAT.EQ.2) THEN 435 : MELVAL=IVAL(1) 436 : IBMN=MIN(IB,IELCHE(/2)) 437 : MLREEL=IELCHE(1,IBMN) 438 : SEGACT MLREEL 439 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 439 : $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 440 : SEGDES MLREEL 441 : C------------- 442 : C PROVISOIRE 443 : C------------- 444 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 445 : WORK(4)=DDHOOK(1,1)/WORK(1) 446 : WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1))) 447 : ELSE 448 : * 449 : *ZZZZ ATTENTION A LA DIVISION PAR 0. 450 : * 451 : WORK(10)=DDHOOK(1,1)/WORK(4) 452 : WORK(11)=DDHOOK(2,2)/WORK(5) 453 : ENDIF 454 : ELSE IF (IMAT.EQ.1) THEN 455 : * 456 : DO 9029 IM=1,NMATT 457 : IF (IVAL(IM).NE.0) THEN 458 : MELVAL=IVAL(IM) 459 : IBMN=MIN(IB,VELCHE(/2)) 460 : VALMAT(IM)=VELCHE(1,IBMN) 461 : ELSE 462 : VALMAT(IM)=0.D0 463 : ENDIF 464 : 9029 CONTINUE 465 : IF(MELE.EQ.84) THEN 466 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 466 : CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 467 : ELSE 468 : C 468 : CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 469 : ENDIF 470 : ELSE 471 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 471 : CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 472 : ELSE 472 : CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 473 : ENDIF 474 : ENDIF 475 : C------------- 476 : C PROVISOIRE 477 : C------------- 478 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 479 : WORK(4)=VALMAT(1) 480 : AUX=VALMAT(2) 481 : WORK(5)=WORK(4)*0.5D0/(1.D0+AUX) 482 : ELSE 483 : C 484 : WORK(10)=VALMAT(1) 485 : AUX=VALMAT(2) 486 : WORK(11)=WORK(10)*0.5D0/(1.D0+AUX) 487 : ENDIF 488 : C------------- 489 : ENDIF 490 : * 491 : * CAS DE LA FORMULATION SECTION 492 : * 493 : ELSE 494 : IF(IMAT.EQ.2) THEN 495 : MELVAL=IVAL(1) 496 : IBMN=MIN(IB,IELCHE(/2)) 497 : MLREEL=IELCHE(1,IBMN) 498 : SEGACT MLREEL 499 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 499 : $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 500 : SEGDES MLREEL 501 : C 502 : ELSE IF (IMAT.EQ.1) THEN 503 : * 504 : * ON REGARDE SI ON A LA COMPOSANTE MAHO 505 : * SI OUI, ON LA PREND 506 : * 507 : IF(IVAL(3).NE.0) THEN 508 : MELVAL=IVAL(3) 509 : IBMN=MIN(IB,IELCHE(/2)) 510 : MLREEL=IELCHE(1,IBMN) 511 : SEGACT MLREEL 512 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 512 : $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 513 : SEGDES MLREEL 514 : * 515 : ELSE 516 : IBMN=MIN(IB,IELCHE(/2)) 517 : IPMODL=IELCHE(1,IBMN) 518 : MELVAL=IVAL(2) 519 : IBMN=MIN(IB,IELCHE(/2)) 520 : IPMAT=IELCHE(1,IBMN) 520 : CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) 521 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 521 : $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 522 : ENDIF 523 : ENDIF 524 : ENDIF 525 : ENDIF 526 : C 527 : C FIN TRAITEMENT DES DONNEES MATERIAUX 528 : C 529 : IF(MELE.EQ.97) THEN 529 : CALL ACORIG(REL,LRE,WORK,XE,KERRE) 530 : ELSE IF(MELE.EQ.84) THEN 531 : IF(CMATE.NE.'SECTION') THEN 532 : 533 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 533 : CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE) 534 : ELSE 534 : CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE) 535 : ENDIF 536 : * 537 : ELSE 538 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 538 : CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK, 539 : $ DDHOOK,KERRE) 540 : ELSE 540 : CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK, 541 : $ DDHOOK,KERRE) 542 : ENDIF 543 : ENDIF 544 : ELSE 545 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 545 : CALL POURH2(REL,LRE,WORK,XE,WORK(12),IMAT, 546 : & LHOOK, DDHOOK, KERRE) 547 : ELSE 547 : CALL POURHG(REL,LRE,WORK,XE,WORK(12),IMAT, 548 : & LHOOK, DDHOOK, KERRE) 549 : ENDIF 550 : ENDIF 551 : C 552 : IF(KERRE.NE.0) INTERR(1)=ISOUS 553 : IF(KERRE.NE.0) INTERR(2)=IB 554 : C 555 : 4029 CONTINUE 556 : 8029 CONTINUE 557 : * SEGINI XMATRI 558 : * IMATTT(IB)=XMATRI 559 : C 560 : C REMPLISSAGE DE XMATRI 561 : C 561 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 562 : * SEGDES XMATRI 563 : 3029 CONTINUE 563 : IF(KERRE.EQ.1) CALL ERREUR(128) 563 : IF(KERRE.EQ.2) CALL ERREUR(138) 564 : IF(IRTD.EQ.0) THEN 565 : MOTERR(1:8)=CMATE 566 : MOTERR(9:16)=NOMFR(MFR/2+1) 567 : INTERR(1)=IFOUR 567 : CALL ERREUR(81) 568 : ENDIF 569 : SEGDES XMATRI 570 : SEGSUP WRK1,WRK3,MVELCH 571 : GOTO 510 572 : C_______________________________________________________________________ 573 : C 574 : C ELEMENTS LINESPRING LISP ET LISM 575 : C_______________________________________________________________________ 576 : C 577 : 30 CONTINUE 578 : NBBB=NBNN 579 : NSTRS=2 580 : SEGINI WRK1,WRK3 581 : C 582 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 583 : C 584 : DO 3030 IB=1,NBELEM 585 : C 586 : C ON CHRCHE LES COORDONNEES DES NOEUDS 587 : C 587 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 588 : C 589 : C ON CHERCHE LES COEFFS DE LA MATRICE DE HOOKE 590 : C 591 : MPTVAL=IVAMAT 592 : IF(IMAT.EQ.2) THEN 593 : MELVAL=IVAL(1) 594 : IBMN=MIN(IB ,IELCHE(/2)) 595 : MLREEL=IELCHE(1,IBMN) 596 : SEGACT MLREEL 597 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 597 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 598 : SEGDES MLREEL 599 : ELSE IF (IMAT.EQ.1) THEN 600 : * 601 : DO 9030 IM=1,NMATT 602 : IF (IVAL(IM).NE.0) THEN 603 : MELVAL=IVAL(IM) 604 : IBMN=MIN(IB ,VELCHE(/2)) 605 : VALMAT(IM)=VELCHE(1,IBMN) 606 : ELSE 607 : VALMAT(IM)=0.D0 608 : ENDIF 609 : 9030 CONTINUE 610 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 610 : 1 CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 611 : ENDIF 612 : C 613 : C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME POINT DEGAUS 614 : C 615 : IE=0 616 : MPTVAL=IVACAR 617 : DO 7030 IC=1,3,2 618 : DO 7030 ID=1,NCARR 619 : IE=IE+1 620 : MELVAL=IVAL(ID) 621 : IGMN=MIN(IC,VELCHE(/1)) 622 : IBMN=MIN(IB,VELCHE(/2)) 623 : WORK(IE)=VELCHE(IGMN,IBMN) 624 : 7030 CONTINUE 625 : C 626 : C CALCUL DE LA RIGIDITE 627 : C 627 : CALL LISPRI(XE,WORK,DDHOOK,WORK(11),MELE,REL,I70,I343,I157,I158) 628 : C IF(I70.EQ.1) INTERR(1)=IB 629 : IF(I158.EQ.1) INTERR(1)=IB 630 : IF(I343.EQ.1) INTERR(1)=IB 631 : * SEGINI XMATRI 632 : * IMATTT(IB)=XMATRI 633 : C 634 : C REMPLISSAGE DE XMATRI 635 : C 635 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 636 : * SEGDES XMATRI 637 : 3030 CONTINUE 637 : C IF(I70.EQ.1) CALL ERREUR(70) 637 : IF(I158.EQ.1) CALL ERREUR(158) 637 : IF(I343.EQ.1) CALL ERREUR(343) 638 : IF(IRTD.EQ.0) THEN 639 : MOTERR(1:8)=CMATE 640 : MOTERR(9:16)=NOMFR(MFR/2+1) 641 : INTERR(1)=IFOUR 641 : CALL ERREUR(81) 642 : ENDIF 643 : SEGDES XMATRI 644 : SEGSUP WRK1,WRK3,MVELCH 645 : GOTO 510 646 : C_______________________________________________________________________ 647 : C 648 : C ELEMENT TUYAU FISSURE 649 : C_______________________________________________________________________ 650 : C 651 : 43 CONTINUE 652 : NBBB=NBNN 653 : NSTRS=2 654 : SEGINI WRK1,WRK3 655 : C 656 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 657 : C 658 : DO 3043 IB=1,NBELEM 659 : C 660 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 661 : C 661 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 662 : C 663 : C 664 : C ON CHERCHE LES COEFF DES MAT DE HOOKE 665 : C 666 : MPTVAL=IVAMAT 667 : IF(IMAT.EQ.2) THEN 668 : MELVAL=IVAL(1) 669 : IBMN=MIN(IB ,IELCHE(/2)) 670 : MLREEL=IELCHE(1,IBMN) 671 : SEGACT MLREEL 672 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 672 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 673 : SEGDES MLREEL 674 : ELSE IF (IMAT.EQ.1) THEN 675 : * 676 : DO 9043 IM=1,NMATT 677 : IF (IVAL(IM).NE.0) THEN 678 : MELVAL=IVAL(IM) 679 : IBMN=MIN(IB ,VELCHE(/2)) 680 : VALMAT(IM)=VELCHE(1,IBMN) 681 : ELSE 682 : VALMAT(IM)=0.D0 683 : ENDIF 684 : 9043 CONTINUE 685 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 685 : 1 CALL DOHFIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 686 : ENDIF 687 : C 688 : C CHERCHER LES CARACTERISTIQUES 689 : C 690 : MPTVAL=IVACAR 691 : DO 4043 IC=1,NCARR 692 : MELVAL=IVAL(IC) 693 : IBMN=MIN(IB,VELCHE(/2)) 694 : WORK(IC)=VELCHE(1,IBMN) 695 : 4043 CONTINUE 696 : C 697 : C ON CALCULE SA RAIDEUR 698 : C 698 : CALL TUFIRI(REL,WORK(1),DDHOOK,I137) 699 : IF(I137.NE.0) INTERR(1)=ISOUS 700 : IF(I137.NE.0) INTERR(2)=IB 701 : C 702 : * SEGINI XMATRI 703 : * IMATTT(IB)=XMATRI 704 : C 705 : C REMPLISSAGE DE XMATRI 706 : C 706 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 707 : * SEGDES XMATRI 708 : 3043 CONTINUE 708 : IF(I137.EQ.1) CALL ERREUR(137) 708 : IF(I137.EQ.2) CALL ERREUR(123) 708 : IF(I137.EQ.3) CALL ERREUR(266) 709 : IF(IRTD.EQ.0) THEN 710 : MOTERR(1:8)=CMATE 711 : MOTERR(9:16)=NOMFR(MFR/2+1) 712 : INTERR(1)=IFOUR 712 : CALL ERREUR(81) 713 : ENDIF 714 : SEGDES XMATRI 715 : SEGSUP WRK1,WRK3,MVELCH 716 : GOTO 510 717 : C_______________________________________________________________________ 718 : C 719 : C ELEMENT POI1 720 : C_______________________________________________________________________ 721 : C 722 : 45 CONTINUE 723 : if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or. 724 : &cmate.eq.'IMPMAXWE'.or .cmate.eq.'IMPCOMPL') then 725 : 726 : MPTVAL=IVAMAT 727 : MELVAL=IVAL(1) 728 : jddl = LRE/NBPGAU 729 : DO IB = 1,NBELEM 730 : JDIAG = 0 731 : * SEGINI XMATRI 732 : * IMATTT(IB)=XMATRI 733 : IBMN=MIN(IB,VELCHE(/2)) 734 : do igau = 1,NBPGAU 735 : IGMN=MIN(IGAU,VELCHE(/1)) 736 : XRAID = VELCHE(IGMN,IBMN) 737 : do j =1,jddl 738 : JDIAG = JDIAG + 1 739 : RE(JDIAG,JDIAG,IB) = XRAID 740 : enddo 741 : enddo 742 : * SEGDES XMATRI 743 : ENDDO 744 : SEGDES XMATRI 745 : goto 510 746 : endif 747 : 748 : IF (CMATE.EQ.'MODAL') THEN 749 : * MODAL 750 : DO IB = 1,NBELEM 751 : * SEGINI XMATRI 752 : * IMATTT(IB)=XMATRI 753 : 754 : MPTVAL=IVAMAT 755 : MELVAL=IVAL(1) 756 : IBMN=MIN(IB,VELCHE(/2)) 757 : XFREQ=VELCHE(1,IBMN) 758 : MELVAL=IVAL(2) 759 : IBMN=MIN(IB,VELCHE(/2)) 760 : XMASS=VELCHE(1,IBMN) 761 : OMEG = 2. * XPI * XFREQ 762 : RE(1,1,IB) = XMASS * OMEG * OMEG 763 : if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.) 764 : * SEGDES XMATRI 765 : ENDDO 766 : SEGDES XMATRI 767 : GOTO 510 768 : * 769 : 770 : ELSE IF (CMATE.EQ.'STATIQUE') THEN 771 : * STATIQUE 772 : DO IB = 1,NBELEM 773 : * SEGINI XMATRI 774 : * IMATTT(IB)=XMATRI 775 : 776 : MPTVAL=IVAMAT 777 : MELVAL=IVAL(1) 778 : IBMN=MIN(IB,IELCHE(/2)) 779 : idepl=IELCHE(1,IBMN) 780 : MELVAL=IVAL(2) 781 : IBMN=MIN(IB,IELCHE(/2)) 782 : itreac=IELCHE(1,IBMN) 782 : CALL XTY1(idepl,itreac,iinc,idua,X1) 783 : if (ierr.ne.0) return 784 : re(1,1,IB) = x1 785 : * SEGDES XMATRI 786 : ENDDO 787 : SEGDES XMATRI 788 : GOTO 510 789 : ENDIF 790 : * 791 : IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN 792 : GOTO 99 793 : ENDIF 794 : NBBB=NBNN 795 : SEGINI WRK1,WRK3 796 : C 797 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 798 : C 799 : KERRE=0 800 : DO 3045 IB=1,NBELEM 801 : C 802 : C ON CHERCHE LES COORDONNEES DE L ELEMENT IB 803 : C 803 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 804 : C 805 : C 806 : C ON RECUPERE LA SECTION DE L'ELEMENT 807 : C 808 : MPTVAL=IVACAR 809 : MELVAL=IVAL(1) 810 : IBMN=MIN(IB,VELCHE(/2)) 811 : SECT=VELCHE(1,IBMN) 812 : C 813 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 814 : C 815 : MPTVAL=IVAMAT 816 : IF(IMAT.EQ.2) THEN 817 : MELVAL=IVAL(1) 818 : IBMN=MIN(IB ,IELCHE(/2)) 819 : MLREEL=IELCHE(1,IBMN) 820 : SEGACT MLREEL 821 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 821 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 822 : SEGDES MLREEL 823 : ELSE IF (IMAT.EQ.1) THEN 824 : * 825 : DO 9045 IM=1,NMATT 826 : IF (IVAL(IM).NE.0) THEN 827 : MELVAL=IVAL(IM) 828 : IBMN=MIN(IB ,VELCHE(/2)) 829 : VALMAT(IM)=VELCHE(1,IBMN) 830 : ELSE 831 : VALMAT(IM)=0.D0 832 : ENDIF 833 : 9045 CONTINUE 833 : CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) 834 : ENDIF 834 : CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE) 835 : C 836 : * SEGINI XMATRI 837 : * IMATTT(IB)=XMATRI 838 : C 839 : C REMPLISSAGE DE XMATRI 840 : C 840 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 841 : * SEGDES XMATRI 842 : 3045 CONTINUE 843 : IF(IRTD.EQ.0) THEN 844 : MOTERR(1:8)=CMATE 845 : MOTERR(9:16)=NOMFR(MFR/2+1) 846 : INTERR(1)=IFOUR 846 : CALL ERREUR(81) 847 : ENDIF 848 : SEGDES XMATRI 849 : SEGSUP WRK1,WRK3,MVELCH 850 : GOTO 510 851 : C_______________________________________________________________________ 852 : C 853 : C ELEMENTS BARRE ET CERCE 854 : C_______________________________________________________________________ 855 : C 856 : 46 CONTINUE 857 : * 858 : IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN 859 : GO TO 99 860 : ENDIF 861 : NBBB=NBNN 862 : SEGINI WRK1,WRK3 863 : IF(MELE.EQ.123) THEN 864 : NSTN=NBNN 865 : LRN =LRE 866 : SEGINI WRK5 867 : ENDIF 868 : C 869 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 870 : C 871 : KERRE=0 872 : DO 3046 IB=1,NBELEM 873 : C 874 : C ON CHERCHE LES COORDONNEES DE L ELEMENT IB 875 : C 875 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 876 : C 877 : C 878 : C ON RECUPERE LA SECTION DE L'ELEMENT 879 : C 880 : MPTVAL=IVACAR 881 : MELVAL=IVAL(1) 882 : IBMN=MIN(IB,VELCHE(/2)) 883 : SECT=VELCHE(1,IBMN) 884 : C 885 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 886 : C 887 : MPTVAL=IVAMAT 888 : IF(IMAT.EQ.2) THEN 889 : MELVAL=IVAL(1) 890 : IBMN=MIN(IB ,IELCHE(/2)) 891 : MLREEL=IELCHE(1,IBMN) 892 : SEGACT MLREEL 893 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 893 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 894 : SEGDES MLREEL 895 : ELSE IF (IMAT.EQ.1) THEN 896 : * 897 : DO 9046 IM=1,NMATT 898 : IF (IVAL(IM).NE.0) THEN 899 : MELVAL=IVAL(IM) 900 : IBMN=MIN(IB ,VELCHE(/2)) 901 : VALMAT(IM)=VELCHE(1,IBMN) 902 : ELSE 903 : VALMAT(IM)=0.D0 904 : ENDIF 905 : 9046 CONTINUE 905 : CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) 906 : ENDIF 906 : IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) 906 : IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) 906 : IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB) 907 : IF(KERRE.NE.0) INTERR(1)=ISOUS 908 : IF(KERRE.NE.0) INTERR(2)=IB 909 : C 910 : * SEGINI XMATRI 911 : * IMATTT(IB)=XMATRI 912 : C 913 : C REMPLISSAGE DE XMATRI 914 : C 914 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 915 : * SEGDES XMATRI 916 : 3046 CONTINUE 916 : IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128) 916 : IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601) 916 : IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128) 917 : IF(IRTD.EQ.0) THEN 918 : MOTERR(1:8)=CMATE 919 : MOTERR(9:16)=NOMFR(MFR/2+1) 920 : INTERR(1)=IFOUR 920 : CALL ERREUR(81) 921 : ENDIF 922 : SEGDES XMATRI 923 : SEGSUP WRK1,WRK3,MVELCH 924 : IF(MELE.EQ.123) SEGSUP WRK5 925 : GOTO 510 926 : C 927 : C_______________________________________________________________________ 928 : C 929 : C ELEMENT BARRE 3D EXCENTRE (BAEX) 930 : C_______________________________________________________________________ 931 : C 932 : 124 CONTINUE 933 : NBBB=NBNN 934 : NBNO=NBNN 935 : NSTRS1=NSTRS 936 : NSTRS=NBNN 937 : SEGINI WRK1,WRK2,WRK3 938 : C 939 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 940 : C 941 : KERRE=0 942 : DO 3108 IB=1,NBELEM 943 : C 944 : C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON 945 : C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK 946 : C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ 947 : C 948 : MPTVAL=IVACAR 949 : DO IC=1,NCARR 950 : IF(IVAL(IC).NE.0) THEN 951 : MELVAL=IVAL(IC) 952 : IBMN=MIN(IB,VELCHE(/2)) 953 : WORK(IC)=VELCHE(1,IBMN) 954 : ELSE 955 : WORK(IC)=0.D0 956 : ENDIF 957 : END DO 958 : SECT=WORK(1) 959 : C 960 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 961 : C 962 : MPTVAL=IVAMAT 963 : IF(IMAT.EQ.2) THEN 964 : MELVAL=IVAL(1) 965 : IBMN=MIN(IB ,IELCHE(/2)) 966 : MLREEL=IELCHE(1,IBMN) 967 : SEGACT MLREEL 968 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 968 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 969 : SEGDES MLREEL 970 : ELSE IF (IMAT.EQ.1) THEN 971 : DO 9108 IM=1,NMATT 972 : IF (IVAL(IM).NE.0) THEN 973 : MELVAL=IVAL(IM) 974 : IBMN=MIN(IB ,VELCHE(/2)) 975 : VALMAT(IM)=VELCHE(1,IBMN) 976 : ELSE 977 : VALMAT(IM)=0.D0 978 : ENDIF 979 : 9108 CONTINUE 980 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 980 : 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) 981 : ENDIF 982 : C 983 : C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE 984 : C 984 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 984 : CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE) 985 : IF(KERRE.NE.0) INTERR(1)=ISOUS 986 : IF(KERRE.NE.0) INTERR(2)=IB 986 : IF(KERRE.EQ.1) CALL ERREUR(128) 986 : CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE) 987 : C 988 : * SEGINI XMATRI 989 : * IMATTT(IB)=XMATRI 990 : C 991 : C REMPLISSAGE DE XMATRI 992 : C 992 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 993 : * SEGDES XMATRI 994 : 3108 CONTINUE 995 : NSTRS=NSTRS1 996 : SEGDES XMATRI 997 : SEGSUP WRK1,WRK2,WRK3,MVELCH 998 : GOTO 510 999 : C_______________________________________________________________________ 1000 : C 1001 : C LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds) 1002 : C_______________________________________________________________________ 1003 : C 1004 : 125 CONTINUE 1005 : NBBB=NBNN 1006 : NBNO=NBNN 1007 : SEGINI WRK1,WRK2,WRK3,WRK4 1008 : C 1009 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 1010 : C 1011 : KERRE=0 1012 : DO 3109 IB=1,NBELEM 1013 : C 1014 : MPTVAL=IVACAR 1015 : DO IC=1,NCARR 1016 : IF(IVAL(IC).NE.0) THEN 1017 : MELVAL=IVAL(IC) 1018 : IBMN=MIN(IB,VELCHE(/2)) 1019 : WORK(IC)=VELCHE(1,IBMN) 1020 : ELSE 1021 : WORK(IC)=0.D0 1022 : ENDIF 1023 : END DO 1024 : C 1024 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1024 : CALL MAPALI(XE,NBNN,WORK,BPSS,KERRE) 1025 : IF(KERRE.NE.0) INTERR(1)=ISOUS 1026 : IF(KERRE.NE.0) INTERR(2)=IB 1026 : IF(KERRE.EQ.1) CALL ERREUR(128) 1026 : CALL RIGLI2(REL,LRE,BPSS,WORK) 1027 : C 1028 : * SEGINI XMATRI 1029 : * IMATTT(IB)=XMATRI 1030 : C 1031 : C REMPLISSAGE DE XMATRI 1032 : C 1032 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1033 : * SEGDES XMATRI 1034 : 3109 CONTINUE 1035 : SEGDES XMATRI 1036 : SEGSUP WRK1,WRK2,WRK3,MVELCH 1037 : GOTO 510 1038 : *------------------------------------------------------------- 1039 : C_______________________________________________________________________ 1040 : C 1041 : C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds) 1042 : C_______________________________________________________________________ 1043 : C 1044 : 129 CONTINUE 1045 : NBBB=NBNN 1046 : NBNO=NBNN 1047 : SEGINI WRK1,WRK2,WRK3,WRK4 1048 : C 1049 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 1050 : C 1051 : KERRE=0 1052 : DO 3110 IB=1,NBELEM 1053 : C 1054 : MPTVAL=IVAMAT 1055 : DO IC=1,NMATT 1056 : IF(IVAL(IC).NE.0) THEN 1057 : MELVAL=IVAL(IC) 1058 : IBMN=MIN(IB,VELCHE(/2)) 1059 : WORK(IC)=VELCHE(1,IBMN) 1060 : ELSE 1061 : WORK(IC)=0.D0 1062 : ENDIF 1063 : END DO 1064 : C 1064 : CALL MAPALU(NMATT,WORK,BPSS,IDIM) 1065 : c 1066 : c on calcule la matrice de rigidité localement 1067 : c 1067 : CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE) 1068 : c 1069 : c on passe en repère global 1070 : c 1071 : IAW1=101 1072 : IAW2=IAW1+LRE*LRE 1073 : IAW3=IAW2+LRE*LRE 1074 : IAW4=IAW3+LRE*LRE 1074 : CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2), 1075 : & WORK(IAW3),WORK(IAW4),LRE,IDIM) 1076 : * 1077 : C 1078 : * SEGINI XMATRI 1079 : * IMATTT(IB)=XMATRI 1080 : C 1081 : C REMPLISSAGE DE XMATRI 1082 : C 1082 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1083 : * 1084 : * SEGDES XMATRI 1085 : 3110 CONTINUE 1086 : SEGDES XMATRI 1087 : SEGSUP WRK1,WRK2,WRK3,MVELCH 1088 : GOTO 510 1089 : *------------------------------------------------------------- 1090 : C_______________________________________________________________________ 1091 : C 1092 : C SECTEUR DE CALCUL POUR LE JOI2 1093 : C 1094 : C_______________________________________________________________________ 1095 : C 1096 : 85 CONTINUE 1097 : NBNO=NBNN 1098 : NBBB=NBNN 1099 : SEGINI WRK1,WRK2,WRK4 1100 : C 1101 : C BOUCLE POUR TOUS LES ELEMENTS 1102 : C 1103 : DO 3085 IB=1,NBELEM 1104 : C 1105 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1106 : C 1106 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1107 : C 1107 : CALL ZERO (REL,LRE,LRE) 1108 : C 1109 : C CALCUL DES AXES LOCAUX 1110 : C 1110 : CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1111 : C 1112 : CCC IF (NOQUAL.EQ.1) THEN 1113 : CCCC NOEUDS TROP VOISINS 1114 : CCC INTERR(1)=IB 1115 : CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS 1115 : CCC CALL ERREUR(323) 1116 : CCC ELSE IF ( NOQUAL.EQ.2 ) THEN 1117 : CCCC JOINT NON PLAN 1118 : CCC INTERR(1)=IB 1119 : CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS 1119 : CCC CALL ERREUR(323) 1120 : CCC RETURN 1121 : CCC ENDIF 1122 : C 1123 : C BOUCLE SUR LES POINTS DE GAUSS 1124 : C 1125 : * write(6,*) ' nbpgau ' , nbpgau 1126 : DO 4085 IGAU=1,NBPGAU 1127 : C 1128 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1129 : C 1129 : CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1130 : + BGENE,DJAC,IRRT) 1131 : DJAC=DJAC*POIGAU(IGAU) 1132 : * write(6,*)'djac poigau qsigau',djac,poigau(igau),qsigau(igau) 1133 : 1134 : * 1135 : IF (IFOUR.EQ.0) THEN 1136 : C 1137 : C EN AXISYMETRIE, ON MULTIPLIE PAR R 1138 : C (R=RAYON DE COURBURE DU POINT DE GAUSS) 1139 : C 1140 : RAYON=0.0D0 1141 : NUMSUP=NBNO/2 1142 : * 1143 : write(6,*) igau,SHPTOT(1,1,IGAU),SHPTOT(1,2,IGAU) 1144 : DO 5085 IRAY=1,NUMSUP 1145 : RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) 1146 : 5085 CONTINUE 1147 : * modif TC 1148 : * dr = XE(1,2)-xe(1,1) 1149 : * ra= XE(1,1) 1150 : * rb= XE(1,2) 1151 : * write(6,*) ' igau djac ra rb ',igau ,djac ,ra ,rb 1152 : * rayona = rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0 1153 : * rayona=rayona *2.d0 /dr / dr 1154 : * rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0 1155 : * rayonb=rayonb *2.d0 / dr / dr 1156 : * write(6,*) 'rayona rayonb', rayona , rayonb 1157 : 1158 : * rayon= rayona 1159 : * if(igau.eq.2) rayon=rayonb 1160 : * write(6,*) ' dr rayon ' , dr,rayon 1161 : DJAC=DJAC*RAYON 1162 : * write(6,*) ' djac rayon' , djac , rayon 1163 : ENDIF 1164 : C 1165 : C IRRT=1 JACOBIEN <= 0 1166 : IF(IRRT.NE.0) THEN 1167 : INTERR(1)=IB 1167 : CALL ERREUR(612) 1168 : ENDIF 1169 : C 1170 : C CALCUL DE LA MATRICE DE HOOK 1171 : C 1172 : MPTVAL=IVAMAT 1173 : IF(IMAT.EQ.2) THEN 1174 : MELVAL=IVAL(1) 1175 : IBMN=MIN(IB ,IELCHE(/2)) 1176 : IGMN=MIN(IGAU,IELCHE(/1)) 1177 : MLREEL=IELCHE(IGMN,IBMN) 1178 : SEGACT MLREEL 1179 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1179 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1180 : SEGDES MLREEL 1181 : ELSE IF (IMAT.EQ.1) THEN 1182 : DO 9085 IM=1,NMATT 1183 : IF (IVAL(IM).NE.0) THEN 1184 : MELVAL=IVAL(IM) 1185 : IBMN=MIN(IB ,VELCHE(/2)) 1186 : IGMN=MIN(IGAU,VELCHE(/1)) 1187 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1188 : ELSE 1189 : VALMAT(IM)=0.D0 1190 : ENDIF 1191 : 9085 CONTINUE 1192 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1192 : 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1193 : ENDIF 1194 : C 1195 : C CALCUL ET INTEGRATION DE BDB 1196 : C 1196 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1197 : 4085 CONTINUE 1198 : C 1199 : * SEGINI XMATRI 1200 : * IMATTT(IB)=XMATRI 1201 : C 1202 : C REMPLISSAGE DE XMATRI 1203 : C 1203 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1204 : * SEGDES XMATRI 1205 : 3085 CONTINUE 1206 : C 1207 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1208 : C 1209 : IF (IRTD.EQ.0) THEN 1210 : MOTERR(1:8) = CMATE 1211 : MOTERR(9:16) = NOMFR(MFR/2+1) 1212 : INTERR(1) = IFOUR 1212 : CALL ERREUR(81) 1213 : ENDIF 1214 : C 1215 : SEGDES XMATRI 1216 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1217 : GOTO 510 1218 : C_______________________________________________________________________ 1219 : C 1220 : C SECTEUR DE CALCUL POUR LE JGI2 1221 : C 1222 : C_______________________________________________________________________ 1223 : C 1224 : 170 CONTINUE 1225 : NBNO=NBNN 1226 : NBBB=NBNN 1227 : SEGINI WRK1,WRK2,WRK4 1228 : C 1229 : C BOUCLE POUR TOUS LES ELEMENTS 1230 : C 1231 : DO IB=1,NBELEM 1232 : C 1233 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1234 : C 1234 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1235 : C 1235 : CALL ZERO (REL,LRE,LRE) 1236 : C 1237 : C CALCUL DES AXES LOCAUX 1238 : C 1238 : CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1239 : C 1240 : C BOUCLE SUR LES POINTS DE GAUSS 1241 : C 1242 : DO IGAU=1,NBPGAU 1243 : C 1244 : C ON CHERCHE L EPAISSEUR DU JOINT 1245 : C 1246 : EPAIST=0.D0 1247 : MPTVAL=IVACAR 1248 : MELVAL=IVAL(1) 1249 : IF (MELVAL.NE.0) THEN 1250 : IGMN=MIN(IGAU,VELCHE(/1)) 1251 : IBMN=MIN(IB,VELCHE(/2)) 1252 : EPAIST=VELCHE(IGMN,IBMN) 1253 : ENDIF 1254 : C 1255 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1256 : C 1256 : CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1257 : CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) 1257 : CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, 1258 : . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT) 1259 : DJAC=DJAC*POIGAU(IGAU) 1260 : C 1261 : IF (IFOUR.EQ.0) THEN 1262 : C 1263 : C EN AXISYMETRIE, ON MULTIPLIE PAR R 1264 : C (R=RAYON DE COURBURE DU POINT DE GAUSS) 1265 : C 1266 : RAYON=0.0D0 1267 : NUMSUP=NBNO/2 1268 : DO IRAY=1,NUMSUP 1269 : RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) 1270 : ENDDO 1271 : DJAC=DJAC*RAYON 1272 : ENDIF 1273 : C 1274 : C IRRT=1 JACOBIEN <= 0 1275 : IF(IRRT.NE.0) THEN 1276 : INTERR(1)=IB 1276 : CALL ERREUR(612) 1277 : ENDIF 1278 : C 1279 : C CALCUL DE LA MATRICE DE HOOK 1280 : C 1281 : MPTVAL=IVAMAT 1282 : IF(IMAT.EQ.2) THEN 1283 : MELVAL=IVAL(1) 1284 : IBMN=MIN(IB ,IELCHE(/2)) 1285 : IGMN=MIN(IGAU,IELCHE(/1)) 1286 : MLREEL=IELCHE(IGMN,IBMN) 1287 : SEGACT MLREEL 1288 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1288 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1289 : SEGDES MLREEL 1290 : ELSE IF (IMAT.EQ.1) THEN 1291 : DO IM=1,NMATT 1292 : IF (IVAL(IM).NE.0) THEN 1293 : MELVAL=IVAL(IM) 1294 : IBMN=MIN(IB ,VELCHE(/2)) 1295 : IGMN=MIN(IGAU,VELCHE(/1)) 1296 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1297 : ELSE 1298 : VALMAT(IM)=0.D0 1299 : ENDIF 1300 : ENDDO 1301 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1301 : 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1302 : ENDIF 1303 : C 1304 : C CALCUL ET INTEGRATION DE BDB 1305 : C 1305 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1306 : ENDDO 1307 : C 1308 : * SEGINI XMATRI 1309 : * IMATTT(IB)=XMATRI 1310 : C 1311 : C REMPLISSAGE DE XMATRI 1312 : C 1312 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1313 : * SEGDES XMATRI 1314 : ENDDO 1315 : C 1316 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1317 : C 1318 : IF (IRTD.EQ.0) THEN 1319 : MOTERR(1:8) = CMATE 1320 : MOTERR(9:16) = NOMFR(MFR/2+1) 1321 : INTERR(1) = IFOUR 1321 : CALL ERREUR(81) 1322 : ENDIF 1323 : C 1324 : SEGDES XMATRI 1325 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1326 : GOTO 510 1327 : C_______________________________________________________________________ 1328 : C 1329 : C SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement 1330 : C 1331 : C_______________________________________________________________________ 1332 : C 1333 : 168 CONTINUE 1334 : NBNO=NBNN 1335 : NBBB=NBNN 1336 : SEGINI WRK1,WRK2,WRK4 1337 : C 1338 : C BOUCLE POUR TOUS LES ELEMENTS 1339 : C 1340 : DO IB=1,NBELEM 1341 : C 1342 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1343 : C 1343 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1344 : C 1344 : CALL ZERO (REL,LRE,LRE) 1345 : C 1346 : C CALCUL DES AXES LOCAUX 1347 : C 1347 : CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1348 : C 1349 : IF (NOQUAL.EQ.1) THEN 1350 : INTERR(1)=IB 1351 : MOTERR(1:4) = 'JGT3' 1351 : CALL ERREUR(765) 1352 : RETURN 1353 : ELSE IF ( NOQUAL.EQ.2) THEN 1354 : INTERR(1)=IB 1355 : MOTERR(1:4) = 'JGT3' 1355 : CALL ERREUR(766) 1356 : RETURN 1357 : ENDIF 1358 : C 1359 : C BOUCLE SUR LES POINTS DE GAUSS 1360 : C 1361 : DO IGAU=1,NBPGAU 1362 : C 4 1363 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1364 : C 1364 : CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1365 : + BGENE,DJAC,IRRT) 1366 : DJAC=DJAC*POIGAU(IGAU) 1367 : C IRRT=1 JACOBIEN <= 0 1368 : IF(IRRT.NE.0) THEN 1368 : CALL ERREUR(764) 1369 : ENDIF 1370 : C 1371 : C CALCUL DE LA MATRICE DE HOOK 1372 : C 1373 : MPTVAL=IVAMAT 1374 : IF(IMAT.EQ.2) THEN 1375 : MELVAL=IVAL(1) 1376 : IBMN=MIN(IB ,IELCHE(/2)) 1377 : IGMN=MIN(IGAU,IELCHE(/1)) 1378 : MLREEL=IELCHE(IGMN,IBMN) 1379 : SEGACT MLREEL 1380 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1380 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1381 : SEGDES MLREEL 1382 : ELSE IF (IMAT.EQ.1) THEN 1383 : DO IM=1,NMATT 1384 : IF (IVAL(IM).NE.0) THEN 1385 : MELVAL=IVAL(IM) 1386 : IBMN=MIN(IB ,VELCHE(/2)) 1387 : IGMN=MIN(IGAU,VELCHE(/1)) 1388 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1389 : ELSE 1390 : VALMAT(IM)=0.D0 1391 : ENDIF 1392 : ENDDO 1393 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1393 : 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1394 : ENDIF 1395 : C 1396 : C CALCUL ET INTEGRATION DE BDB 1397 : C 1397 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1398 : ENDDO 1399 : C 1400 : * SEGINI XMATRI 1401 : * IMATTT(IB)=XMATRI 1402 : C 1403 : C REMPLISSAGE DE XMATRI 1404 : C 1404 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1405 : * SEGDES XMATRI 1406 : ENDDO 1407 : C 1408 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1409 : C 1410 : IF (IRTD.EQ.0) THEN 1411 : MOTERR(1:8) = CMATE 1412 : MOTERR(9:16) = NOMFR(MFR/2+1) 1413 : INTERR(1) = IFOUR 1413 : CALL ERREUR(81) 1414 : ENDIF 1415 : C 1416 : SEGDES XMATRI 1417 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1418 : GOTO 510 1419 : C_______________________________________________________________________ 1420 : C 1421 : C SECTEUR DE CALCUL POUR LE JGT3 GENERALISE 1422 : C 1423 : C_______________________________________________________________________ 1424 : C 1425 : 171 CONTINUE 1426 : NBNO=NBNN 1427 : NBBB=NBNN 1428 : SEGINI WRK1,WRK2,WRK4 1429 : C 1430 : C BOUCLE POUR TOUS LES ELEMENTS 1431 : C 1432 : DO IB=1,NBELEM 1433 : C 1434 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1435 : C 1435 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1436 : C 1436 : CALL ZERO (REL,LRE,LRE) 1437 : C 1438 : C CALCUL DES AXES LOCAUX 1439 : C 1439 : CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1440 : C 1441 : IF (NOQUAL.EQ.1) THEN 1442 : INTERR(1)=IB 1443 : MOTERR(1:4) = 'JGT3' 1443 : CALL ERREUR(765) 1444 : RETURN 1445 : ELSE IF ( NOQUAL.EQ.2) THEN 1446 : INTERR(1)=IB 1447 : MOTERR(1:4) = 'JGT3' 1447 : CALL ERREUR(766) 1448 : RETURN 1449 : ENDIF 1450 : C 1451 : C BOUCLE SUR LES POINTS DE GAUSS 1452 : C 1453 : DO IGAU=1,NBPGAU 1454 : C 1455 : C ON CHERCHE L'EPAISSEUR DU JOINT 1456 : C 1457 : EPAIST=0.D0 1458 : MPTVAL=IVACAR 1459 : MELVAL=IVAL(1) 1460 : IF (MELVAL.NE.0) THEN 1461 : IGMN=MIN(IGAU,VELCHE(/1)) 1462 : IBMN=MIN(IB,VELCHE(/2)) 1463 : EPAIST=VELCHE(IGMN,IBMN) 1464 : ENDIF 1465 : C 4 1466 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1467 : C 1467 : CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1467 : CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK, 1468 : + EPAIST,BGENE,DJAC,IRRT) 1469 : DJAC=DJAC*POIGAU(IGAU) 1470 : C IRRT=1 JACOBIEN <= 0 1471 : IF(IRRT.NE.0) THEN 1471 : CALL ERREUR(764) 1472 : ENDIF 1473 : C 1474 : C CALCUL DE LA MATRICE DE HOOK 1475 : C 1476 : MPTVAL=IVAMAT 1477 : IF(IMAT.EQ.2) THEN 1478 : MELVAL=IVAL(1) 1479 : IBMN=MIN(IB ,IELCHE(/2)) 1480 : IGMN=MIN(IGAU,IELCHE(/1)) 1481 : MLREEL=IELCHE(IGMN,IBMN) 1482 : SEGACT MLREEL 1483 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1483 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1484 : SEGDES MLREEL 1485 : ELSE IF (IMAT.EQ.1) THEN 1486 : DO IM=1,NMATT 1487 : IF (IVAL(IM).NE.0) THEN 1488 : MELVAL=IVAL(IM) 1489 : IBMN=MIN(IB ,VELCHE(/2)) 1490 : IGMN=MIN(IGAU,VELCHE(/1)) 1491 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1492 : ELSE 1493 : VALMAT(IM)=0.D0 1494 : ENDIF 1495 : ENDDO 1496 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1496 : 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1497 : ENDIF 1498 : C 1499 : C CALCUL ET INTEGRATION DE BDB 1500 : C 1500 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1501 : ENDDO 1502 : C 1503 : * SEGINI XMATRI 1504 : * IMATTT(IB)=XMATRI 1505 : C 1506 : C REMPLISSAGE DE XMATRI 1507 : C 1507 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1508 : * SEGDES XMATRI 1509 : ENDDO 1510 : C 1511 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1512 : C 1513 : IF (IRTD.EQ.0) THEN 1514 : MOTERR(1:8) = CMATE 1515 : MOTERR(9:16) = NOMFR(MFR/2+1) 1516 : INTERR(1) = IFOUR 1516 : CALL ERREUR(81) 1517 : ENDIF 1518 : C 1519 : SEGDES XMATRI 1520 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1521 : GOTO 510 1522 : C_______________________________________________________________________ 1523 : C 1524 : C SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement 1525 : C 1526 : C_______________________________________________________________________ 1527 : C 1528 : 169 CONTINUE 1529 : NBNO=NBNN 1530 : NBBB=NBNN 1531 : SEGINI WRK1,WRK2,WRK4 1532 : C 1533 : C BOUCLE POUR TOUS LES ELEMENTS 1534 : C 1535 : DO IB=1,NBELEM 1536 : C 1537 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1538 : C 1538 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1539 : C 1539 : CALL ZERO (REL,LRE,LRE) 1540 : C 1541 : C CALCUL DES AXES LOCAUX 1542 : C 1542 : CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1543 : 1544 : IF (NOQUAL.EQ.1) THEN 1545 : INTERR(1)=IB 1546 : MOTERR(1:4) = 'JCI4' 1546 : CALL ERREUR(765) 1547 : RETURN 1548 : ELSE IF ( NOQUAL.EQ.2 ) THEN 1549 : INTERR(1)=IB 1550 : MOTERR(1:4) = 'JCI4' 1550 : CALL ERREUR(766) 1551 : RETURN 1552 : ENDIF 1553 : C 1554 : C BOUCLE SUR LES POINTS DE GAUSS 1555 : C 1556 : DO IGAU=1,NBPGAU 1557 : C 1558 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1559 : C 1559 : CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) 1560 : DJAC=DJAC*POIGAU(IGAU) 1561 : C IRRT=1 JACOBIEN <= 0 1562 : IF(IRRT.NE.0) THEN 1563 : INTERR(1)=IB 1563 : CALL ERREUR(611) 1564 : ENDIF 1565 : C 1566 : C CALCUL DE LA MATRICE DE HOOK 1567 : C 1568 : MPTVAL=IVAMAT 1569 : IF(IMAT.EQ.2) THEN 1570 : MELVAL=IVAL(1) 1571 : IBMN=MIN(IB ,IELCHE(/2)) 1572 : IGMN=MIN(IGAU,IELCHE(/1)) 1573 : MLREEL=IELCHE(IGMN,IBMN) 1574 : SEGACT MLREEL 1575 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1575 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1576 : SEGDES MLREEL 1577 : ELSE IF (IMAT.EQ.1) THEN 1578 : DO IM=1,NMATT 1579 : IF (IVAL(IM).NE.0) THEN 1580 : MELVAL=IVAL(IM) 1581 : IBMN=MIN(IB ,VELCHE(/2)) 1582 : IGMN=MIN(IGAU,VELCHE(/1)) 1583 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1584 : ELSE 1585 : VALMAT(IM)=0.D0 1586 : ENDIF 1587 : ENDDO 1588 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1588 : 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1589 : ENDIF 1590 : C 1591 : C CALCUL ET INTEGRATION DE BDB 1592 : C 1592 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1593 : ENDDO 1594 : C 1595 : * SEGINI XMATRI 1596 : * IMATTT(IB)=XMATRI 1597 : C 1598 : C REMPLISSAGE DE XMATRI 1599 : C 1599 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1600 : * SEGDES XMATRI 1601 : ENDDO 1602 : C 1603 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1604 : C 1605 : IF (IRTD.EQ.0) THEN 1606 : MOTERR(1:8) = CMATE 1607 : MOTERR(9:16) = NOMFR(MFR/2+1) 1608 : INTERR(1) = IFOUR 1608 : CALL ERREUR(81) 1609 : ENDIF 1610 : C 1611 : SEGDES XMATRI 1612 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1613 : GOTO 510 1614 : C_______________________________________________________________________ 1615 : C 1616 : C SECTEUR DE CALCUL POUR LE JGI4 GENERALISE 1617 : C 1618 : C_______________________________________________________________________ 1619 : C 1620 : 172 CONTINUE 1621 : NBNO=NBNN 1622 : NBBB=NBNN 1623 : SEGINI WRK1,WRK2,WRK4 1624 : C 1625 : C BOUCLE POUR TOUS LES ELEMENTS 1626 : C 1627 : DO IB=1,NBELEM 1628 : C 1629 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1630 : C 1630 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1631 : C 1631 : CALL ZERO (REL,LRE,LRE) 1632 : C 1633 : C CALCUL DES AXES LOCAUX 1634 : C 1634 : CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1635 : 1636 : IF (NOQUAL.EQ.1) THEN 1637 : INTERR(1)=IB 1638 : MOTERR(1:4) = 'JGI4' 1638 : CALL ERREUR(765) 1639 : RETURN 1640 : ELSE IF ( NOQUAL.EQ.2 ) THEN 1641 : CbPPj INTERR(1)=IB 1642 : CbPPj MOTERR(1:4) = 'JGI4' 1642 : CbPPj CALL ERREUR(766) 1643 : CbPPj RETURN 1644 : WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB, 1645 : . ' not planar' 1646 : ENDIF 1647 : C 1648 : C BOUCLE SUR LES POINTS DE GAUSS 1649 : C 1650 : DO IGAU=1,NBPGAU 1651 : C 1652 : C ON CHERCHE L'EPAISSEUR DU JOINT 1653 : C 1654 : EPAIST=0.D0 1655 : MPTVAL=IVACAR 1656 : MELVAL=IVAL(1) 1657 : IF (MELVAL.NE.0) THEN 1658 : IGMN=MIN(IGAU,VELCHE(/1)) 1659 : IBMN=MIN(IB,VELCHE(/2)) 1660 : EPAIST=VELCHE(IGMN,IBMN) 1661 : ENDIF 1662 : C 1663 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1664 : C 1664 : CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT) 1664 : CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC, 1665 : . IRRT) 1666 : DJAC=DJAC*POIGAU(IGAU) 1667 : C IRRT=1 JACOBIEN <= 0 1668 : IF(IRRT.NE.0) THEN 1669 : INTERR(1)=IB 1669 : CALL ERREUR(611) 1670 : ENDIF 1671 : C 1672 : C CALCUL DE LA MATRICE DE HOOK 1673 : C 1674 : MPTVAL=IVAMAT 1675 : IF(IMAT.EQ.2) THEN 1676 : MELVAL=IVAL(1) 1677 : IBMN=MIN(IB ,IELCHE(/2)) 1678 : IGMN=MIN(IGAU,IELCHE(/1)) 1679 : MLREEL=IELCHE(IGMN,IBMN) 1680 : SEGACT MLREEL 1681 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1681 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1682 : SEGDES MLREEL 1683 : ELSE IF (IMAT.EQ.1) THEN 1684 : DO IM=1,NMATT 1685 : IF (IVAL(IM).NE.0) THEN 1686 : MELVAL=IVAL(IM) 1687 : IBMN=MIN(IB ,VELCHE(/2)) 1688 : IGMN=MIN(IGAU,VELCHE(/1)) 1689 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1690 : ELSE 1691 : VALMAT(IM)=0.D0 1692 : ENDIF 1693 : ENDDO 1694 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1694 : 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD) 1695 : ENDIF 1696 : C 1697 : C CALCUL ET INTEGRATION DE BDB 1698 : C 1698 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1699 : ENDDO 1700 : C 1701 : * SEGINI XMATRI 1702 : * IMATTT(IB)=XMATRI 1703 : C 1704 : C REMPLISSAGE DE XMATRI 1705 : C 1705 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1706 : * SEGDES XMATRI 1707 : ENDDO 1708 : C 1709 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1710 : C 1711 : IF (IRTD.EQ.0) THEN 1712 : MOTERR(1:8) = CMATE 1713 : MOTERR(9:16) = NOMFR(MFR/2+1) 1714 : INTERR(1) = IFOUR 1714 : CALL ERREUR(81) 1715 : ENDIF 1716 : C 1717 : SEGDES XMATRI 1718 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1719 : GOTO 510 1720 : C 1721 : C_______________________________________________________________________ 1722 : C 1723 : C SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE 1724 : C ET SANS REPERE LOCAL 1725 : C 1726 : C_______________________________________________________________________ 1727 : C 1728 : 86 CONTINUE 1729 : NBNO=NBNN 1730 : NBBB=NBNN 1731 : SEGINI WRK1,WRK2,WRK4 1732 : C 1733 : C BOUCLE POUR TOUS LES ELEMENTS 1734 : C 1735 : DO 3086 IB=1,NBELEM 1736 : C 1737 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1738 : C 1738 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1739 : C 1739 : CALL ZERO (REL,LRE,LRE) 1740 : C 1741 : C BOUCLE SUR LES POINTS DE GAUSS 1742 : C 1743 : DO 4086 IGAU=1,NBPGAU 1744 : C 1745 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1746 : C 1747 : 1747 : CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS) 1747 : CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK, 1748 : + BGENE,DJAC,IRRT) 1749 : DJAC=DJAC*POIGAU(IGAU) 1750 : * 1751 : IF (IFOUR.EQ.0) THEN 1752 : C 1753 : C EN AXISYMETRIE, ON MULTIPLIE PAR R 1754 : C (R=RAYON DE COURBURE DU POINT DE GAUSS) 1755 : C 1756 : RAYON=0.0D0 1757 : NUMSUP=NBNO/2 1758 : DO 5086 IRAY=1,NUMSUP 1759 : RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) ) 1760 : 5086 CONTINUE 1761 : DJAC=DJAC*RAYON 1762 : ENDIF 1763 : C 1764 : C IRRT=1 JACOBIEN <= 0 1765 : IF(IRRT.NE.0) THEN 1766 : INTERR(1)=IB 1766 : CALL ERREUR(612) 1767 : ENDIF 1768 : C 1769 : C CALCUL DE LA MATRICE DE HOOK 1770 : C 1771 : MPTVAL=IVAMAT 1772 : IF(IMAT.EQ.2) THEN 1773 : MELVAL=IVAL(1) 1774 : IBMN=MIN(IB ,IELCHE(/2)) 1775 : IGMN=MIN(IGAU,IELCHE(/1)) 1776 : MLREEL=IELCHE(IGMN,IBMN) 1777 : SEGACT MLREEL 1778 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1778 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1779 : SEGDES MLREEL 1780 : ELSE IF (IMAT.EQ.1) THEN 1781 : DO 9086 IM=1,NMATT 1782 : IF (IVAL(IM).NE.0) THEN 1783 : MELVAL=IVAL(IM) 1784 : IBMN=MIN(IB ,VELCHE(/2)) 1785 : IGMN=MIN(IGAU,VELCHE(/1)) 1786 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1787 : ELSE 1788 : VALMAT(IM)=0.D0 1789 : ENDIF 1790 : 9086 CONTINUE 1791 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1791 : 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1792 : ENDIF 1793 : C 1794 : C CALCUL ET INTEGRATION DE BDB 1795 : C 1795 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1796 : 4086 CONTINUE 1797 : C 1798 : * SEGINI XMATRI 1799 : * IMATTT(IB)=XMATRI 1800 : C 1801 : C REMPLISSAGE DE XMATRI 1802 : C 1802 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1803 : * SEGDES XMATRI 1804 : 3086 CONTINUE 1805 : C 1806 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1807 : C 1808 : IF (IRTD.EQ.0) THEN 1809 : MOTERR(1:8) = CMATE 1810 : MOTERR(9:16) = NOMFR(MFR/2+1) 1811 : INTERR(1) = IFOUR 1811 : CALL ERREUR(81) 1812 : ENDIF 1813 : C 1814 : SEGDES XMATRI 1815 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1816 : GOTO 510 1817 : C_______________________________________________________________________ 1818 : C 1819 : C SECTEUR DE CALCUL POUR LE JOT3 1820 : C 1821 : C_______________________________________________________________________ 1822 : C 1823 : 87 CONTINUE 1824 : NBNO=NBNN 1825 : NBBB=NBNN 1826 : SEGINI WRK1,WRK2,WRK4 1827 : C 1828 : C BOUCLE POUR TOUS LES ELEMENTS 1829 : C 1830 : DO 3087 IB=1,NBELEM 1831 : C 1832 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1833 : C 1833 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1834 : C 1834 : CALL ZERO (REL,LRE,LRE) 1835 : C 1836 : C CALCUL DES AXES LOCAUX 1837 : C 1837 : CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1838 : C 1839 : IF (NOQUAL.EQ.1) THEN 1840 : INTERR(1)=IB 1841 : MOTERR(1:4) = 'JOT3' 1841 : CALL ERREUR(765) 1842 : RETURN 1843 : ELSE IF ( NOQUAL.EQ.2) THEN 1844 : INTERR(1)=IB 1845 : MOTERR(1:4) = 'JOT3' 1845 : CALL ERREUR(766) 1846 : RETURN 1847 : ENDIF 1848 : C 1849 : C BOUCLE SUR LES POINTS DE GAUSS 1850 : C 1851 : DO 4087 IGAU=1,NBPGAU 1852 : C 4 1853 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1854 : C 1854 : CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK, 1855 : + BGENE,DJAC,IRRT) 1856 : DJAC=DJAC*POIGAU(IGAU) 1857 : C IRRT=1 JACOBIEN <= 0 1858 : IF(IRRT.NE.0) THEN 1858 : CALL ERREUR(764) 1859 : ENDIF 1860 : C 1861 : C CALCUL DE LA MATRICE DE HOOK 1862 : C 1863 : MPTVAL=IVAMAT 1864 : IF(IMAT.EQ.2) THEN 1865 : MELVAL=IVAL(1) 1866 : IBMN=MIN(IB ,IELCHE(/2)) 1867 : IGMN=MIN(IGAU,IELCHE(/1)) 1868 : MLREEL=IELCHE(IGMN,IBMN) 1869 : SEGACT MLREEL 1870 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1870 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1871 : SEGDES MLREEL 1872 : ELSE IF (IMAT.EQ.1) THEN 1873 : DO 9087 IM=1,NMATT 1874 : IF (IVAL(IM).NE.0) THEN 1875 : MELVAL=IVAL(IM) 1876 : IBMN=MIN(IB ,VELCHE(/2)) 1877 : IGMN=MIN(IGAU,VELCHE(/1)) 1878 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1879 : ELSE 1880 : VALMAT(IM)=0.D0 1881 : ENDIF 1882 : 9087 CONTINUE 1883 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1883 : 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1884 : ENDIF 1885 : C 1886 : C CALCUL ET INTEGRATION DE BDB 1887 : C 1887 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1888 : 4087 CONTINUE 1889 : C 1890 : * SEGINI XMATRI 1891 : * IMATTT(IB)=XMATRI 1892 : C 1893 : C REMPLISSAGE DE XMATRI 1894 : C 1894 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1895 : * SEGDES XMATRI 1896 : 3087 CONTINUE 1897 : C 1898 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1899 : C 1900 : IF (IRTD.EQ.0) THEN 1901 : MOTERR(1:8) = CMATE 1902 : MOTERR(9:16) = NOMFR(MFR/2+1) 1903 : INTERR(1) = IFOUR 1903 : CALL ERREUR(81) 1904 : ENDIF 1905 : C 1906 : SEGDES XMATRI 1907 : SEGSUP WRK1,WRK2,WRK4,MVELCH 1908 : GOTO 510 1909 : C_______________________________________________________________________ 1910 : C 1911 : C SECTEUR DE CALCUL POUR LE JOI4 1912 : C 1913 : C_______________________________________________________________________ 1914 : C 1915 : 88 CONTINUE 1916 : NBNO=NBNN 1917 : NBBB=NBNN 1918 : SEGINI WRK1,WRK2,WRK4 1919 : C 1920 : C BOUCLE POUR TOUS LES ELEMENTS 1921 : C 1922 : DO 3088 IB=1,NBELEM 1923 : C 1924 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 1925 : C 1925 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 1926 : C 1926 : CALL ZERO (REL,LRE,LRE) 1927 : C 1928 : C CALCUL DES AXES LOCAUX 1929 : C 1929 : CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL) 1930 : 1931 : IF (NOQUAL.EQ.1) THEN 1932 : INTERR(1)=IB 1933 : MOTERR(1:4) = 'JOI4' 1933 : CALL ERREUR(765) 1934 : RETURN 1935 : ELSE IF ( NOQUAL.EQ.2 ) THEN 1936 : INTERR(1)=IB 1937 : MOTERR(1:4) = 'JOI4' 1937 : CALL ERREUR(766) 1938 : RETURN 1939 : ENDIF 1940 : C 1941 : C BOUCLE SUR LES POINTS DE GAUSS 1942 : C 1943 : DO 4088 IGAU=1,NBPGAU 1944 : C 1945 : C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU 1946 : C 1946 : CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT) 1947 : DJAC=DJAC*POIGAU(IGAU) 1948 : C IRRT=1 JACOBIEN <= 0 1949 : IF(IRRT.NE.0) THEN 1950 : INTERR(1)=IB 1950 : CALL ERREUR(611) 1951 : ENDIF 1952 : C 1953 : C CALCUL DE LA MATRICE DE HOOK 1954 : C 1955 : MPTVAL=IVAMAT 1956 : IF(IMAT.EQ.2) THEN 1957 : MELVAL=IVAL(1) 1958 : IBMN=MIN(IB ,IELCHE(/2)) 1959 : IGMN=MIN(IGAU,IELCHE(/1)) 1960 : MLREEL=IELCHE(IGMN,IBMN) 1961 : SEGACT MLREEL 1962 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1962 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 1963 : SEGDES MLREEL 1964 : ELSE IF (IMAT.EQ.1) THEN 1965 : DO 9088 IM=1,NMATT 1966 : IF (IVAL(IM).NE.0) THEN 1967 : MELVAL=IVAL(IM) 1968 : IBMN=MIN(IB ,VELCHE(/2)) 1969 : IGMN=MIN(IGAU,VELCHE(/1)) 1970 : VALMAT(IM)=VELCHE(IGMN,IBMN) 1971 : ELSE 1972 : VALMAT(IM)=0.D0 1973 : ENDIF 1974 : 9088 CONTINUE 1975 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 1975 : 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 1976 : ENDIF 1977 : C 1978 : C CALCUL ET INTEGRATION DE BDB 1979 : C 1979 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 1980 : 4088 CONTINUE 1981 : C 1982 : * SEGINI XMATRI 1983 : * IMATTT(IB)=XMATRI 1984 : C 1985 : C REMPLISSAGE DE XMATRI 1986 : C 1986 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 1987 : * SEGDES XMATRI 1988 : 3088 CONTINUE 1989 : C 1990 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 1991 : C 1992 : IF (IRTD.EQ.0) THEN 1993 : MOTERR(1:8) = CMATE 1994 : MOTERR(9:16) = NOMFR(MFR/2+1) 1995 : INTERR(1) = IFOUR 1995 : CALL ERREUR(81) 1996 : ENDIF 1997 : C 1998 : SEGDES XMATRI 1999 : SEGSUP WRK1,WRK2,WRK4,MVELCH 2000 : GOTO 510 2001 : C_______________________________________________________________________ 2002 : C 2003 : C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE TRIH 2004 : C_______________________________________________________________________ 2005 : C 2006 : 92 CONTINUE 2007 : NBNO=NBNN 2008 : NBBB=NBNN 2009 : LRN =NBNN 2010 : NSTN=3 2011 : SEGINI WRK1,WRK2 ,WRK5 2012 : I195=0 2013 : DO 3092 IB=1,NBELEM 2014 : C 2015 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2016 : C 2016 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2016 : CALL ZERO (REL,LRE,LRE) 2017 : * 2018 : MPTVAL=IVAMAT 2019 : DO 9092 IM=1,10 2020 : IF (IVAL(IM).NE.0) THEN 2021 : MELVAL=IVAL(IM) 2022 : IBMN=MIN(IB ,VELCHE(/2)) 2023 : VALMAT(IM)=VELCHE(1,IBMN) 2024 : ELSE 2025 : VALMAT(IM)=0.D0 2026 : 2027 : ENDIF 2028 : 9092 CONTINUE 2029 : C 2030 : C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB 2031 : C 2032 : RHOF =VALMAT(4) 2033 : E =VALMAT(6) 2034 : C =VALMAT(7) 2035 : RHOREF=VALMAT(8) 2036 : CREF =VALMAT(9) 2037 : RLCAR =VALMAT(10) 2038 : C 2039 : C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB 2040 : C 2041 : MPTVAL=IVACAR 2042 : IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN 2043 : MELVAL=IVAL(1) 2044 : IBMN=MIN(IB,VELCHE(/2)) 2045 : SCEL =VELCHE(1,IBMN) 2046 : MELVAL=IVAL(2) 2047 : IBMN=MIN(IB,VELCHE(/2)) 2048 : SFLU =VELCHE(1,IBMN) 2049 : MELVAL=IVAL(3) 2050 : IBMN=MIN(IB,VELCHE(/2)) 2051 : EPS =VELCHE(1,IBMN) 2052 : MELVAL=IVAL(4) 2053 : IBMN=MIN(IB,VELCHE(/2)) 2054 : XINERT=VELCHE(1,IBMN) 2055 : EI = E*XINERT/(EPS*EPS) 2056 : ELSE 2057 : MELVAL=IVAL(1) 2058 : IBMN=MIN(IB,VELCHE(/2)) 2059 : SCEL =VELCHE(1,IBMN) 2060 : MELVAL=IVAL(2) 2061 : IBMN=MIN(IB,VELCHE(/2)) 2062 : SFLU =VELCHE(1,IBMN) 2063 : MELVAL=IVAL(3) 2064 : IBMN=MIN(IB,VELCHE(/2)) 2065 : EPS =VELCHE(1,IBMN) 2066 : C E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE 2067 : EI = E /(EPS*EPS) 2068 : ENDIF 2069 : C 2070 : C CALCUL DES COEFFICIENTS DE NORMALISATION 2071 : C 2072 : COEFPR=(RHOREF*CREF*CREF)/RLCAR 2073 : VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) 2074 : VKL2 = EI/SCEL 2075 : C 2076 : C BOUCLE SUR LES POINTS DE GAUSS 2077 : C 2078 : ISDJC=0 2079 : DO 4092 IGAU=1,NBPGAU 2079 : CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT, 2080 : # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) 2081 : IF(IRRT.NE.1) GOTO 5092 2082 : DJAC=DJAC*POIGAU(IGAU) 2082 : CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 2083 : 4092 CONTINUE 2084 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB 2085 : * SEGINI XMATRI 2086 : * IMATTT(IB)=XMATRI 2087 : C 2088 : C REMPLISSAGE DE XMATRI 2089 : C 2089 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2090 : * SEGDES XMATRI 2091 : 3092 CONTINUE 2092 : C 2093 : C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR 2094 : C 2095 : 5092 CONTINUE 2096 : IF(IRRT.EQ.0) THEN 2097 : MOTERR(1:4)=NOMTP(MELE) 2097 : CALL ERREUR(420) 2098 : ELSE 2099 : IF(IRRT.EQ.2) THEN 2100 : INTERR(1)=IB 2100 : CALL ERREUR(405) 2101 : ENDIF 2102 : ENDIF 2103 : IF(I195.NE.0) INTERR(1)=I195 2103 : IF(I195.NE.0) CALL ERREUR(195) 2104 : SEGDES XMATRI 2105 : SEGSUP WRK1,WRK2,WRK5,MVELCH 2106 : GOTO 510 2107 : *_______________________________________________________________________ 2108 : * 2109 : * ELEMENT TUYO 2110 : *_______________________________________________________________________ 2111 : * 2112 : 96 CONTINUE 2113 : NBNO=IPORE 2114 : NBBB=NBNN 2115 : SEGINI WRK1,WRK2,WRK3,WRK6 2116 : C 2117 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 2118 : C 2119 : DO 3096 IB=1,NBELEM 2120 : KERRE=0 2121 : C 2122 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2123 : C 2123 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2123 : CALL ZERO (REL,LRE,LRE) 2124 : * 2125 : XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+ 2126 : . (XE(3,2)-XE(3,1))**2 2127 : XL=SQRT(XL) 2128 : IF(XL.EQ.0.D0) THEN 2129 : KERRE=1 2130 : GO TO 3096 2131 : ENDIF 2132 : C 2133 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 2134 : C ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT 2135 : C 2136 : MPTVAL=IVACAR 2137 : DO 6096 IC=1,NCARR 2138 : IF (IVAL(IC).NE.0) THEN 2139 : MELVAL=IVAL(IC) 2140 : IBMN=MIN(IB,VELCHE(/2)) 2141 : WORK(IC)=VELCHE(1,IBMN) 2142 : ELSE 2143 : WORK(IC)=0.D0 2144 : ENDIF 2145 : 6096 CONTINUE 2146 : C 2147 : C TRAITEMENT DU VECTEUR 2148 : C 2149 : IF (IVAL(NCARR).NE.0) THEN 2150 : MELVAL=IVAL(NCARR) 2151 : IBMN=MIN(IB,IELCHE(/2)) 2152 : IP=IELCHE(1,IBMN) 2153 : IREF=(IP-1)*(IDIM+1) 2154 : DO 6196 IC=1,IDIM 2155 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 2156 : 6196 CONTINUE 2157 : ELSE 2158 : DO 6296 IC=1,IDIM 2159 : WORK(NCARR+IC-1)=0.D0 2160 : 6296 CONTINUE 2161 : ENDIF 2162 : C 2163 : C CALCUL DU REPERE LOCAL 2164 : C 2164 : CALL TUYPAS(XE,XL,WORK,PSS,KERRE) 2165 : IF(KERRE.NE.0) THEN 2166 : INTERR(1)=IB 2166 : CALL ERREUR(5 ) 2167 : RETURN 2168 : ENDIF 2169 : C 2170 : C BOUCLE SUR LES POINTS DE GAUSS 2171 : C 2172 : DO 4096 IGAU=1,NBPGAU 2173 : C 2174 : C TRAITEMENT DU MATERIAU 2175 : C IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE 2176 : C 2177 : MPTVAL=IVAMAT 2178 : IF(IMAT.EQ.2) THEN 2179 : MELVAL=IVAL(1) 2180 : IGMN=MIN(IGAU,VELCHE(/1)) 2181 : IBMN=MIN(IB ,IELCHE(/2)) 2182 : MLREEL=IELCHE(IGMN,IBMN) 2183 : SEGACT MLREEL 2184 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 2184 : . CALL DOHOOO(PROG,LHOOK,DDHOOK) 2185 : SEGDES MLREEL 2186 : * 2187 : ELSE IF (IMAT.EQ.1) THEN 2188 : * 2189 : DO 9096 IM=1,NMATT 2190 : IF (IVAL(IM).NE.0) THEN 2191 : MELVAL=IVAL(IM) 2192 : IGMN=MIN(IGAU,VELCHE(/1)) 2193 : IBMN=MIN(IB ,VELCHE(/2)) 2194 : VALMAT(IM)=VELCHE(IGMN,IBMN) 2195 : ELSE 2196 : VALMAT(IM)=0.D0 2197 : ENDIF 2198 : 9096 CONTINUE 2198 : CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 2199 : EPAIST=WORK(1) 2199 : CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU) 2200 : ENDIF 2201 : * 2202 : * CALCUL DE LA MATRICE B ET DU JACOBIEN 2203 : * 2203 : CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE) 2204 : DJAC=DJAC*POIGAU(IGAU) 2205 : * 2206 : IF(KERRE.NE.0) THEN 2207 : INTERR(1)=IB 2207 : CALL ERREUR(5) 2208 : ENDIF 2209 : * 2210 : * CALCUL ET INTEGRATION DE BTDB 2211 : * 2211 : CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL) 2212 : 4096 CONTINUE 2213 : * 2214 : * CHANGEMENT DE BASE 2215 : * 2215 : CALL TUYROT(REL,LRE,PSS,1) 2216 : * 2217 : * SEGINI XMATRI 2218 : * IMATTT(IB)=XMATRI 2219 : C 2220 : C REMPLISSAGE DE XMATRI 2221 : C 2221 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2222 : * SEGDES XMATRI 2223 : 3096 CONTINUE 2223 : IF(KERRE.EQ.1) CALL ERREUR(128) 2223 : IF(KERRE.EQ.2) CALL ERREUR(138) 2224 : IF(IRTD.EQ.0) THEN 2225 : MOTERR(1:8)=CMATE 2226 : MOTERR(9:16)=NOMFR(MFR/2+1) 2227 : INTERR(1)=IFOUR 2227 : CALL ERREUR(81) 2228 : ENDIF 2229 : SEGDES XMATRI 2230 : SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH 2231 : GOTO 510 2232 : C_______________________________________________________________________ 2233 : C 2234 : C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES QUAH 2235 : C_______________________________________________________________________ 2236 : C 2237 : 126 CONTINUE 2238 : C 2239 : NBNO=NBNN 2240 : NBBB=NBNN 2241 : LRN =NBNN+NBNN 2242 : NSTN=2 2243 : SEGINI WRK1,WRK2 ,WRK5 2244 : I195=0 2245 : DO 3126 IB=1,NBELEM 2246 : C 2247 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2248 : C 2248 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2248 : CALL ZERO (REL,LRE,LRE) 2249 : * 2250 : MPTVAL=IVAMAT 2251 : DO 9126 IM=1,10 2252 : IF (IVAL(IM).NE.0) THEN 2253 : MELVAL=IVAL(IM) 2254 : IBMN=MIN(IB ,VELCHE(/2)) 2255 : VALMAT(IM)=VELCHE(1,IBMN) 2256 : ELSE 2257 : VALMAT(IM)=0.D0 2258 : 2259 : ENDIF 2260 : 9126 CONTINUE 2261 : C 2262 : C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB 2263 : C 2264 : RHOF =VALMAT(4) 2265 : 2266 : E =VALMAT(6) 2267 : 2268 : C =VALMAT(7) 2269 : 2270 : RHOREF=VALMAT(8) 2271 : 2272 : CREF =VALMAT(9) 2273 : 2274 : RLCAR =VALMAT(10) 2275 : 2276 : C 2277 : C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB 2278 : C 2279 : MPTVAL=IVACAR 2280 : MELVAL=IVAL(1) 2281 : IBMN=MIN(IB,VELCHE(/2)) 2282 : SCEL =VELCHE(1,IBMN) 2283 : 2284 : MELVAL=IVAL(2) 2285 : IBMN=MIN(IB,VELCHE(/2)) 2286 : SFLU =VELCHE(1,IBMN) 2287 : 2288 : MELVAL=IVAL(3) 2289 : IBMN=MIN(IB,VELCHE(/2)) 2290 : EPS =VELCHE(1,IBMN) 2291 : 2292 : MELVAL=IVAL(5) 2293 : IBMN=MIN(IB,VELCHE(/2)) 2294 : XINERT=VELCHE(1,IBMN) 2295 : EI = E*XINERT/(EPS*EPS) 2296 : C 2297 : C CALCUL DES COEFFICIENTS DE NORMALISATION 2298 : C 2299 : COEFPR=(RHOREF*CREF*CREF)/RLCAR 2300 : VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) 2301 : VKL2 = EI/SCEL 2302 : C 2303 : C 2304 : C BOUCLE SUR LES POINTS DE GAUSS 2305 : C 2306 : ISDJC=0 2307 : DO 4126 IGAU=1,NBPGAU 2307 : CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT, 2308 : # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) 2309 : IF(IRRT.NE.1) GOTO 5126 2310 : DJAC=DJAC*POIGAU(IGAU) 2310 : CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 2311 : 4126 CONTINUE 2312 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB 2313 : * SEGINI XMATRI 2314 : * IMATTT(IB)=XMATRI 2315 : C 2316 : C REMPLISSAGE DE XMATRI 2317 : C 2317 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2318 : * SEGDES XMATRI 2319 : 3126 CONTINUE 2320 : C 2321 : C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR 2322 : C 2323 : 5126 CONTINUE 2324 : IF(IRRT.EQ.0) THEN 2325 : MOTERR(1:4)=NOMTP(MELE) 2325 : CALL ERREUR(420) 2326 : ELSE 2327 : IF(IRRT.EQ.2) THEN 2328 : INTERR(1)=IB 2328 : CALL ERREUR(405) 2329 : ENDIF 2330 : ENDIF 2331 : IF(I195.NE.0) INTERR(1)=I195 2331 : IF(I195.NE.0) CALL ERREUR(195) 2332 : SEGDES XMATRI 2333 : SEGSUP WRK1,WRK2,WRK5,MVELCH 2334 : GOTO 510 2335 : C_______________________________________________________________________ 2336 : C 2337 : C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES CUBH 2338 : C_______________________________________________________________________ 2339 : C 2340 : 127 CONTINUE 2341 : NBNO=NBNN 2342 : NBBB=NBNN 2343 : LRN =NBNN*2 2344 : NSTN=2 2345 : C 2346 : SEGINI WRK1,WRK2 ,WRK5 2347 : I195=0 2348 : DO 3127 IB=1,NBELEM 2349 : C 2350 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2351 : C 2351 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2351 : CALL ZERO (REL,LRE,LRE) 2352 : * 2353 : MPTVAL=IVAMAT 2354 : DO 9127 IM=1,10 2355 : IF (IVAL(IM).NE.0) THEN 2356 : MELVAL=IVAL(IM) 2357 : IBMN=MIN(IB ,VELCHE(/2)) 2358 : VALMAT(IM)=VELCHE(1,IBMN) 2359 : ELSE 2360 : VALMAT(IM)=0.D0 2361 : 2362 : ENDIF 2363 : 9127 CONTINUE 2364 : C 2365 : C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB 2366 : C 2367 : RHOF =VALMAT(4) 2368 : 2369 : E =VALMAT(6) 2370 : 2371 : C =VALMAT(7) 2372 : 2373 : RHOREF=VALMAT(8) 2374 : 2375 : CREF =VALMAT(9) 2376 : 2377 : RLCAR =VALMAT(10) 2378 : C 2379 : C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB 2380 : C 2381 : MPTVAL=IVACAR 2382 : MELVAL=IVAL(1) 2383 : IBMN=MIN(IB,VELCHE(/2)) 2384 : SCEL =VELCHE(1,IBMN) 2385 : 2386 : MELVAL=IVAL(2) 2387 : IBMN=MIN(IB,VELCHE(/2)) 2388 : SFLU =VELCHE(1,IBMN) 2389 : 2390 : MELVAL=IVAL(3) 2391 : IBMN=MIN(IB,VELCHE(/2)) 2392 : EPS =VELCHE(1,IBMN) 2393 : 2394 : MELVAL=IVAL(5) 2395 : IBMN=MIN(IB,VELCHE(/2)) 2396 : XINERT=VELCHE(1,IBMN) 2397 : EI = E*XINERT/(EPS*EPS) 2398 : C 2399 : C CALCUL DES COEFFICIENTS DE NORMALISATION 2400 : C 2401 : COEFPR=(RHOREF*CREF*CREF)/RLCAR 2402 : VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL) 2403 : VKL2 = EI/SCEL 2404 : C 2405 : C BOUCLE SUR LES POINTS DE GAUSS 2406 : C 2407 : ISDJC=0 2408 : DO 4127 IGAU=1,NBPGAU 2408 : CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT, 2409 : # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT) 2410 : IF(IRRT.NE.1) GOTO 5127 2411 : DJAC=DJAC*POIGAU(IGAU) 2412 : C 2413 : C 2413 : CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL) 2414 : 4127 CONTINUE 2415 : IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB 2416 : * SEGINI XMATRI 2417 : * IMATTT(IB)=XMATRI 2418 : C 2419 : C REMPLISSAGE DE XMATRI 2420 : C 2420 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2421 : * SEGDES XMATRI 2422 : 3127 CONTINUE 2423 : C 2424 : C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR 2425 : C 2426 : 5127 CONTINUE 2427 : IF(IRRT.EQ.0) THEN 2428 : MOTERR(1:4)=NOMTP(MELE) 2428 : CALL ERREUR(420) 2429 : ELSE 2430 : IF(IRRT.EQ.2) THEN 2431 : INTERR(1)=IB 2431 : CALL ERREUR(405) 2432 : ENDIF 2433 : ENDIF 2434 : IF(I195.NE.0) INTERR(1)=I195 2434 : IF(I195.NE.0) CALL ERREUR(195) 2435 : SEGDES XMATRI 2436 : SEGSUP WRK1,WRK2,WRK5,MVELCH 2437 : GOTO 510 2438 : 2439 : C_______________________________________________________________________ 2440 : C 2441 : C ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION 2442 : C 2443 : C_______________________________________________________________________ 2444 : C 2445 : 258 CONTINUE 2446 : NBNO=NBNN 2447 : NBBB=NBNN 2448 : SEGINI WRK1,WRK2,WRK3,WRK4 2449 : C 2450 : C BOUCLE POUR TOUS LES ELEMENTS 2451 : C 2452 : DO IB=1,NBELEM 2453 : C 2454 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2455 : C 2455 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2456 : C 2456 : CALL ZERO (REL,LRE,LRE) 2457 : C 2458 : C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX 2459 : C 2459 : CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE) 2460 : C 2461 : C CALCUL DE LA MATRICE DE HOOK 2462 : C 2463 : MPTVAL=IVAMAT 2464 : IF(IMAT.EQ.2) THEN 2465 : MELVAL=IVAL(1) 2466 : IGMN=MIN(1,IELCHE(/1)) 2467 : MLREEL=IELCHE(IGMN,IBMN) 2468 : SEGACT MLREEL 2469 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 2469 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 2470 : SEGDES MLREEL 2471 : ELSE IF (IMAT.EQ.1) THEN 2472 : DO IM=1,NMATT 2473 : IF (IVAL(IM).NE.0) THEN 2474 : MELVAL=IVAL(IM) 2475 : IBMN=MIN(IB ,VELCHE(/2)) 2476 : VALMAT(IM)=VELCHE(1,IBMN) 2477 : ELSE 2478 : VALMAT(IM)=0.D0 2479 : ENDIF 2480 : ENDDO 2481 : C 2482 : MPTVAL=IVACAR 2483 : DO IC=1,NCARR 2484 : IF (IVAL(IC).NE.0) THEN 2485 : MELVAL=IVAL(IC) 2486 : IBMN=MIN(IB,VELCHE(/2)) 2487 : WORK(IC)=VELCHE(1,IBMN) 2488 : ELSE 2489 : WORK(IC)=0.D0 2490 : ENDIF 2491 : ENDDO 2492 : C 2492 : CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 2493 : ENDIF 2494 : C 2495 : C CALCUL ET INTEGRATION DE BDB 2496 : C 2497 : DDHOOK(1,1)=DDHOOK(1,1)/(XH/2) 2498 : DDHOOK(2,2)=DDHOOK(2,2)/(XH/2) 2499 : DDHOOK(3,3)=DDHOOK(3,3)/ XH 2500 : DDHOOK(4,4)=DDHOOK(4,4)/(XH/2) 2501 : DDHOOK(5,5)=DDHOOK(5,5)/(XH/2) 2501 : CALL BDBST(BGENE,1.D0,DDHOOK,LRE,NSTRS,REL) 2502 : C 2503 : * SEGINI XMATRI 2504 : * IMATTT(IB)=XMATRI 2505 : C 2506 : C REMPLISSAGE DE XMATRI 2507 : C 2507 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2508 : * SEGDES XMATRI 2509 : ENDDO 2510 : C 2511 : SEGDES XMATRI 2512 : SEGSUP WRK1,WRK2,WRK3,WRK4,MVELCH 2513 : GOTO 510 2514 : C_______________________________________________________________________ 2515 : C 2516 : C ELEMENT DE COQUE VOLUMIQUE SHB8 2517 : C_______________________________________________________________________ 2518 : C 2519 : 260 CONTINUE 2520 : NBNO=NBNN 2521 : NBBB=NBNN 2522 : SEGINI WRK1,WRK2,WRK4,WRK7,MVELCH 2523 : C 2524 : C BOUCLE POUR TOUS LES ELEMENTS 2525 : C 2526 : DO IB=1,NBELEM 2527 : C 2528 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2529 : C 2529 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2530 : C 2530 : CALL ZERO (REL,LRE,LRE) 2531 : 2532 : MPTVAL=IVAMAT 2533 : DO 9070 IM=1,NMATT 2534 : IF (IVAL(IM).NE.0) THEN 2535 : MELVAL=IVAL(IM) 2536 : IBMN=MIN(IB ,VELCHE(/2)) 2537 : VALMAT(IM)=VELCHE(1,IBMN) 2538 : 2539 : ELSE 2540 : VALMAT(IM)=0.D0 2541 : 2542 : ENDIF 2543 : 9070 CONTINUE 2544 : 2545 : PROPEL(1)=VALMAT(1) 2546 : PROPEL(2)=VALMAT(2) 2547 : DO IM=3,12 2548 : PROPEL(IM)=VALMAT(1) 2549 : ENDDO 2550 : PROPEL(13)=0 2551 : PROPEL(14)=VALMAT(1) 2552 : WORK1(1)=IB 2553 : 2554 : DO IM=1,5 2555 : REL(IM,1)=0 2556 : ENDDO 2557 : 2558 : OUT(1)=3 2559 : 2560 : C 2561 : C CALCUL DE LA MATRICE DE RIGIDITE 2562 : C 2562 : call SHB8 (2,XE,DDHOOK,PROPEL,WORK1,REL,OUT) 2563 : C 2564 : * SEGINI XMATRI 2565 : * IMATTT(IB)=XMATRI 2566 : C 2567 : C REMPLISSAGE DE XMATRI 2568 : C 2568 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2569 : * SEGDES XMATRI 2570 : ENDDO 2571 : SEGDES XMATRI 2572 : SEGSUP WRK1,WRK2,WRK4,WRK7,MVELCH 2573 : GOTO 510 2574 : * 2575 : C_______________________________________________________________________ 2576 : C 2577 : C ELEMENTS DE ZONE COHESIVE ZCO2, ZCO3, ZCO4 2578 : C_______________________________________________________________________ 2579 : C 2580 : 266 CONTINUE 2581 : 2582 : NDIM = 2 2583 : IF(IFOUR.GT.0) NDIM = 3 2584 : NBNO=NBNN 2585 : NBBB=NBNN 2586 : SEGINI WRK1,WRK2,WRK4 2587 : C 2588 : DO 3266 IB=1,NBELEM 2589 : C 2590 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 2591 : C 2591 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 2592 : C 2592 : CALL ZERO (REL,LRE,LRE) 2593 : C 2594 : C BOUCLE SUR LES POINTS DE GAUSS 2595 : C 2596 : DO 6266 IGAU=1,NBPGAU 2597 : C 2597 : CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS) 2598 : C 2598 : CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT, 2599 : . NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT) 2600 : IF (IERT.NE.0) THEN 2601 : INTERR(1)=IB 2601 : CALL ERREUR(612) 2602 : GOTO 99266 2603 : ENDIF 2604 : C 2605 : DJAC=DJAC*POIGAU(IGAU) 2606 : C 2607 : C CALCUL DE LA MATRICE DE HOOKE 2608 : C 2609 : 2610 : MPTVAL=IVAMAT 2611 : IF(IMAT.EQ.2) THEN 2612 : MELVAL=IVAL(1) 2613 : IBMN=MIN(IB ,IELCHE(/2)) 2614 : MLREEL=IELCHE(1,IBMN) 2615 : SEGACT MLREEL 2616 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 2616 : 1 CALL DOHOOO(PROG,LHOOK,DDHOOK) 2617 : SEGDES MLREEL 2618 : ELSE IF (IMAT.EQ.1) THEN 2619 : DO 9266 IM=1,NMATT 2620 : IF (IVAL(IM).NE.0) THEN 2621 : MELVAL=IVAL(IM) 2622 : IBMN=MIN(IB ,VELCHE(/2)) 2623 : IGMN=MIN(IGAU,VELCHE(/1)) 2624 : VALMAT(IM)=VELCHE(IGMN,IBMN) 2625 : ELSE 2626 : VALMAT(IM)=0.D0 2627 : ENDIF 2628 : 9266 CONTINUE 2629 : IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) 2629 : 1 CALL DOU266(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 2630 : ENDIF 2631 : C 2632 : C CALCUL ET INTEGRATION DE BDB 2633 : C 2633 : CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL) 2634 : 6266 CONTINUE 2635 : C 2636 : * SEGINI XMATRI 2637 : * IMATTT(IB)=XMATRI 2638 : C 2639 : C REMPLISSAGE DE XMATRI 2640 : C 2640 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 2641 : * SEGDES XMATRI 2642 : 3266 CONTINUE 2643 : C 2644 : C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR 2645 : C 2646 : IF (IRTD.EQ.0) THEN 2647 : MOTERR(1:8) = CMATE 2648 : MOTERR(9:16) = NOMFR(MFR/2+1) 2649 : INTERR(1) = IFOUR 2649 : CALL ERREUR(81) 2650 : ENDIF 2651 : C 2652 : 99266 CONTINUE 2653 : SEGDES XMATRI 2654 : SEGSUP WRK1,WRK2,WRK4,MVELCH 2655 : GOTO 510 2656 : 2657 : 2658 : *_______________________________________________________________________ 2659 : * 2660 : 99 CONTINUE 2661 : MOTERR(1:4)=NOMTP(MELE) 2662 : MOTERR(9:12)='RIGI4' 2662 : CALL ERREUR(86) 2663 : * 2664 : 510 CONTINUE 2665 : IF (CMATE.eq.'STATIQUE') THEN 2666 : mlmots = iinc 2667 : if (iinc.gt.0) segsup mlmots 2668 : mlmots = idua 2669 : if (idua.gt.0) segsup mlmots 2670 : ENDIF 2671 : RETURN 2672 : END 2673 : 2674 : 2675 : 2676 : 2677 : 2678 : 2679 : 2680 : 2681 : 2682 : 2683 : 2684 : 2685 : 2686 : 2687 : 2688 :
© Cast3M 2003 - All rights reserved.
Disclaimer