1 : C MASSE3 SOURCE AM 13/12/16 21:16:01 7825 2 : SUBROUTINE MASSE3(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR, 3 : &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE, 4 : &LHOOK,IPMATR,ILUMP,IIPDPG,IMOD) 5 : *---------------------------------------------------------------------* 6 : * _________________________________ * 7 : * | | * 8 : * | calcul de la matrice de masse | * 9 : * |________________________________| * 10 : * * 11 : * coq3/poutre,dkt,coq4,coq8,coq2,dst * 12 : * * 13 : *---------------------------------------------------------------------* 14 : * * 15 : * entrees : * 16 : * ________ * 17 : * * 18 : * ipmail pointeur sur un segment meleme * 19 : * lre nombre de ddl dans la matrice de masse * 20 : * lw dimension du tableau de travail de l'element * 21 : * mele numero de l'element fini * 22 : * ivamat pointeur sur un segment mptval pour le materiau * 23 : * nmatt nombre de composante de materiau (imat=1) * 24 : * ivacar pointeur sur un segment mptval pour les caracteri- * 25 : * stiques * 26 : * ncarr nombre de caracteristiques geometriques * 27 : * ivect flag indiquant si on a entree les axes locaux * 28 : * isous numero de la sous-zone * 29 : * nbpgau nombre de point d'integration pour la masse * 30 : * ipmint pointeur sur un segment minte * 31 : * ipmin1 pointeur sur un segment minte (aux noeuds) * 32 : * nddl nombre de degre de liberte /noeud * 33 : * mate numero du materiau * 34 : * cmate nom du materiau * 35 : * ilump =1 si l'opérateur lump est appelé * 36 : * * 37 : * sorties : * 38 : * ________ * 39 : * * 40 : * ipmatr pointeur sur la matrice de masse de la sous-zone * 41 : * * 42 : *---------------------------------------------------------------------* 43 : IMPLICIT INTEGER(I-N) 44 : IMPLICIT REAL*8(A-H,O-Z) 45 : -INC CCOPTIO 46 : -INC CCHAMP 47 : -INC CCREEL 48 : *- 49 : -INC SMRIGID 50 : -INC SMCHAML 51 : -INC SMELEME 52 : -INC SMCOORD 53 : -INC SMINTE 54 : -INC SMMODEL 55 : C 56 : SEGMENT WRK1 57 : REAL*8 REL(LRE,LRE),XE(3,NBBB) 58 : ENDSEGMENT 59 : C 60 : SEGMENT WRK2 61 : REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE) 62 : ENDSEGMENT 63 : C 64 : C 65 : SEGMENT WRK3 66 : REAL*8 DDHOOK(LHOOK,LHOOK) 67 : REAL*8 WORK(LW) 68 : ENDSEGMENT 69 : C 70 : SEGMENT WRK4 71 : REAL*8 BPSS(3,3),XEL(3,NBBB) 72 : ENDSEGMENT 73 : C 74 : SEGMENT WRK6 75 : REAL*8 RHOMAT(6,6) 76 : ENDSEGMENT 77 : C 78 : SEGMENT MVELCH 79 : REAL*8 VALMAT(NV1) 80 : ENDSEGMENT 81 : C 82 : SEGMENT MPTVAL 83 : INTEGER IPOS(NS),NSOF(NS) 84 : INTEGER IVAL(NCOSOU) 85 : CHARACTER*16 TYVAL(NCOSOU) 86 : ENDSEGMENT 87 : * 88 : DIMENSION CRIGI(12),CMASS(12) 89 : CHARACTER*8 CMATE 90 : * 91 : MELEME=IPMAIL 92 : NBNN=NUM(/1) 93 : NBELEM=NUM(/2) 94 : * 95 : NV1=NMATT 96 : SEGINI,MVELCH 97 : * 98 : xMATRI=IPMATR 99 : LVAL = (LRE*(LRE+1))/2 100 : NLIGRP=LRE 101 : NLIGRD=LRE 102 : * 103 : * introduction du point autour duquel se fait le mouvement 104 : * de la section en defo plane generalisee 105 : * 106 : IF (IFOUR.EQ.-3)THEN 107 : IP=IIPDPG 108 : SEGACT MCOORD 109 : IREF=(IP-1)*(IDIM+1) 110 : XDPGE=XCOOR(IREF+1) 111 : YDPGE=XCOOR(IREF+2) 112 : ELSE 113 : XDPGE=0.D0 114 : YDPGE=0.D0 115 : ENDIF 116 : * 117 : NHRM=NIFOUR 118 : * 119 : MINTE=IPMINT 120 : MINTE2=IPMIN2 121 : 122 : IMODEL = IMOD 123 : jmat = 0 124 : DO imat = 1 , matmod(/2) 125 : if (matmod(imat).eq.'IMPEDANCE') then 126 : jmat = imat 127 : goto 27 128 : endif 129 : ENDDO 130 : C_______________________________________________________________________ 131 : C 132 : C NUMERO DES ETIQUETTES : 133 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 134 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 135 : C 5 CONTINUE 136 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 137 : C 44 CONTINUE 138 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 139 : C_______________________________________________________________________ 140 : C 141 : GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 142 : 199,99,99,99,99,99,27,28,27,99,99,99,99,99,99,99,99,99,99,99, 143 : 241,27,99,44,99,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99, 144 : 399,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99, 145 : 499,99,99,27,99,99,99,99,99,99,99,99,93,99,99,99,27),MELE 146 : GOTO 99 147 : C_______________________________________________________________________ 148 : C_______________________________________________________________________ 149 : C 150 : C ELEMENTS COQ3 ET POUTRES 151 : C_______________________________________________________________________ 152 : C 153 : 27 CONTINUE 154 : IF (jmat.gt.0) THEN 155 : MPTVAL=IVAMAT 156 : MELVAL=IVAL(1) 157 : if (ival(/1).ge.1) then 158 : * melva1 = ival(1) 159 : melva1 = ival(2) 160 : else 161 : melva1 = 0 162 : endif 163 : jddl = LRE/NBPGAU 164 : DO IB = 1,NBELEM 165 : JDIAG = 0 166 : IBMN=MIN(IB,VELCHE(/2)) 167 : * kich 1 pgauss inutile 168 : ig = 1 169 : igmn = MIN(IG,VELCHE(/1)) 170 : XMASS=VELCHE(IGMN,IBMN) 171 : XINER = XMASS 172 : if (melva1.gt.0) then 173 : XINER = melva1.VELCHE(IGMN,IBMN) 174 : endif 175 : do idl = 1,jddl 176 : JDIAG = JDIAG + 1 177 : RE(JDIAG,JDIAG,ib) = XMASS 178 : if (idl.gt.3) RE(JDIAG,JDIAG,ib) = XINER 179 : enddo 180 : do idl = jddl+1, LRE 181 : JDIAG = JDIAG + 1 182 : RE(JDIAG,JDIAG,ib) = XMASS 183 : if (idl.gt.jddl+3) RE(JDIAG,JDIAG,ib) = XINER 184 : enddo 185 : ENDDO 186 : SEGDES XMATRI 187 : GOTO 510 188 : ENDIF 189 : 190 : IF (ILUMP .EQ. 1 ) THEN 191 : C LUMP NE FONCTIONNE PAS POUR L'éLéMENT LSE2 192 : IF (MELE.EQ.97) GOTO 99 193 : C LUMP NE FONCTIONNE PAS POUR L'éLéMENT TIMO SECTION 194 : IF (MELE .EQ. 84 .AND. CMATE.EQ.'SECTION') GOTO 99 195 : ENDIF 196 : C 197 : C CAS DES COQUES - POUTRES - TUYAUX - ACOUSTIQUE PURE 198 : C 199 : NBBB=NBNN 200 : SEGINI WRK1,WRK3 201 : * 202 : * cas du materiau section 203 : * 204 : NBGMAT = 0 205 : NELMAT = 0 206 : IF(CMATE.EQ.'SECTION') THEN 207 : MPTVAL=IVAMAT 208 : DO IM=1,NMATT 209 : IF(IVAL(IM).NE.0)THEN 210 : MELVAL=IVAL(IM) 211 : NBGMAT=MAX(NBGMAT,IELCHE(/1)) 212 : NELMAT=MAX(NELMAT,IELCHE(/2)) 213 : END IF 214 : END DO 215 : ENDIF 216 : C 217 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 218 : C 219 : DO 3027 IB=1,NBELEM 220 : C 221 : C ON CHERCHE LES COORDONNEES DE L ELEMENT IB 222 : C 222 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 223 : C 224 : IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.97. 225 : $ OR.MELE.EQ.84) GO TO 5029 226 : C 227 : C CAS DU COQ3 228 : C ----------- 229 : MPTVAL=IVAMAT 230 : MELVAL=IVAL(1) 231 : IBMN=MIN(IB,VELCHE(/2)) 232 : RR=VELCHE(1,IBMN) 233 : MPTVAL=IVACAR 234 : MELVAL=IVAL(1) 235 : IBMN=MIN(IB,VELCHE(/2)) 236 : RR=RR*VELCHE(1,IBMN) 237 : C 237 : CALL COQ3MA(XE,RR,WORK,REL,ILUMP) 238 : GOTO 4027 239 : C 240 : C CAS DES POUTRES ET DU TUYAU ACOUSTIQUE PURE 241 : C ------------------------------------------- 242 : C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK 243 : C 244 : 5029 CONTINUE 245 : C 246 : C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE 247 : C 248 : NCARR1=NCARR 249 : IF(IVECT.EQ.1) NCARR1=NCARR-1 249 : CALL ZERO(WORK,NCARR1,1) 250 : DO 4029 IGAU=1,NBNN 251 : MPTVAL=IVACAR 252 : DO 6029 IC=1,NCARR1 253 : MELVAL=IVAL(IC) 254 : IF (IVAL(IC).NE.0) THEN 255 : IBMN=MIN(IB,VELCHE(/2)) 256 : IGMN=MIN(IGAU,VELCHE(/1)) 257 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 258 : ELSE 259 : WORK(IC)=0.D0 260 : ENDIF 261 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 262 : 6029 CONTINUE 263 : 4029 CONTINUE 264 : C 265 : C CAS OU ON A LU LE MOT VECTEUR 266 : C 267 : IF (IVECT.EQ.1) THEN 268 : IF (IVAL(NCARR).NE.0) THEN 269 : MELVAL=IVAL(NCARR) 270 : IBMN=MIN(IB,IELCHE(/2)) 271 : IP=IELCHE(1,IBMN) 272 : IREF=(IP-1)*(IDIM+1) 273 : DO 6129 IC=1,IDIM 274 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 275 : 6129 CONTINUE 276 : ELSE 277 : DO 6229 IC=1,IDIM 278 : WORK(NCARR+IC-1)=0 279 : 6229 CONTINUE 280 : ENDIF 281 : ENDIF 282 : C 283 : MPTVAL=IVAMAT 284 : C 285 : C CAS DE L'ACOUSTIQUE PURE 286 : C 287 : IF (MELE.EQ.97) THEN 288 : DO 7029 IM=1,NMATT 289 : MELVAL=IVAL(IM) 290 : IBMN=MIN(IB,VELCHE(/2)) 291 : WORK(IM+9)=VELCHE(1,IBMN) 292 : 7029 CONTINUE 293 : C 294 : C CAS DES POUTRES ET TUYAU 295 : C 296 : ELSE 297 : MELVAL=IVAL(1) 298 : IF(CMATE.NE.'SECTION') THEN 299 : IBMN=MIN(IB,VELCHE(/2)) 300 : C 301 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 302 : WORK(4)=VELCHE(1,IBMN) 303 : ELSE 304 : WORK(10)=VELCHE(1,IBMN) 305 : ENDIF 306 : C 307 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 308 : C -------------- EQUIVALENTE 309 : C 310 : IF(MELE.EQ.42)THEN 311 : CISA=WORK(4) 312 : VX=WORK(5) 313 : VY=WORK(6) 314 : VZ=WORK(7) 314 : CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,1) 315 : ENDIF 316 : ELSE 317 : * 318 : * cas formulation section 319 : * 320 : IBMN=MIN(IB,IELCHE(/2)) 321 : IPMODL=IELCHE(1,IBMN) 322 : MELVAL=IVAL(2) 323 : IBMN=MIN(IB,IELCHE(/2)) 324 : IPMAT=IELCHE(1,IBMN) 325 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN 325 : CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) 325 : CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 326 : ENDIF 327 : ENDIF 328 : ENDIF 329 : C 330 : C ON CALCULE LA MATRICE DE MASSE 331 : C 332 : IF (MELE.EQ.97) THEN 332 : CALL ACOMAS(REL,LRE,WORK,XE,KERRE) 333 : ELSE IF (MELE.EQ.84) THEN 334 : IF(CMATE.NE.'SECTION') THEN 335 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 335 : CALL TIMMA2(REL,LRE,WORK,XE,WORK(11),KERRE) 336 : ELSE 336 : CALL TIMMAS(REL,LRE,WORK,XE,WORK(11),KERRE) 337 : ENDIF 338 : ELSE 339 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 339 : CALL TIFMA2(REL,LRE,XE,WORK(11),LHOOK, 340 : & DDHOOK,KERRE) 341 : ELSE 341 : CALL TIFMAS(REL,LRE,WORK,XE,WORK(11),LHOOK, 342 : & DDHOOK,KERRE) 343 : ENDIF 344 : ENDIF 345 : ELSE 346 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 346 : CALL POUMA2(REL,LRE,WORK,XE,WORK(11),KERRE) 347 : ELSE 347 : CALL POUMAS(REL,LRE,WORK,XE,WORK(11),KERRE) 348 : ENDIF 349 : ENDIF 350 : C 351 : IF(KERRE.EQ.0) GO TO 4027 352 : INTERR(1)=ISOUS 353 : INTERR(2)=IB 354 : SEGSUP WRK1,WRK3,MVELCH 354 : CALL ERREUR(128) 355 : SEGSUP xMATRI 356 : GO TO 510 357 : C 358 : 4027 CONTINUE 359 : * SEGINI XMATRI 360 : * IMATTT(IB)=XMATRI 361 : IF (ILUMP.EQ. 1) THEN 362 : IF (MELE.EQ.27) THEN 362 : * call lump3(rel) 362 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 363 : ELSE 363 : CALL LUMP6(REL,LRE,RE(1,1,ib)) 363 : C CALL LUMP3(REL) 364 : ENDIF 365 : ELSE 365 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 366 : ENDIF 367 : * SEGDES XMATRI 368 : 3027 CONTINUE 369 : SEGDES xMATRI 370 : SEGSUP WRK1,WRK3,MVELCH 371 : GO TO 510 372 : C_______________________________________________________________________ 373 : C 374 : C ELEMENT DKT 375 : C_______________________________________________________________________ 376 : C 377 : 28 CONTINUE 378 : NBNO=NBNN 379 : NBBB=NBNN 380 : NDDL=3 381 : SEGINI WRK1,WRK2,WRK4 382 : C 383 : C PLACE DE LA MASSE VOLUMIQUE DANS LE CHAMP DE MATERIAU: 384 : C 385 : C 386 : DO 3028 IB=1,NBELEM 387 : C 388 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 389 : C 389 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 389 : CALL ZERO(REL,LRE,LRE) 389 : CALL VPAST(XE,BPSS) 389 : CALL VCORLC(XE,XEL,BPSS) 390 : C 391 : C ACQUISITION DES EPAISSEURS 392 : C 393 : EPAIST=0.D0 394 : EXCEN=0.D0 395 : MPTVAL=IVACAR 396 : MELVAL=IVAL(1) 397 : IF (MELVAL.NE.0) THEN 398 : DO IGAU=1,NBPGAU 399 : IGMN=MIN(IGAU,VELCHE(/1)) 400 : IBMN=MIN(IB ,VELCHE(/2)) 401 : EPAIST=EPAIST+VELCHE(IGMN,IBMN) 402 : ENDDO 403 : ENDIF 404 : C 405 : MELVAL=IVAL(2) 406 : IF (MELVAL.NE.0) THEN 407 : DO IGAU=1,NBPGAU 408 : IGMN=MIN(IGAU,VELCHE(/1)) 409 : IBMN=MIN(IB ,VELCHE(/2)) 410 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 411 : ENDDO 412 : ENDIF 413 : EPAIST=EPAIST/NBPGAU 414 : EXCEN=EXCEN/NBPGAU 415 : C 416 : C BOUCLE SUR LES POINTS DE GAUSS 417 : C 418 : MPTVAL=IVAMAT 419 : MELVAL=IVAL(1) 420 : DO 5028 IGAU=1,NBPGAU 421 : IGMN=MIN(IGAU,VELCHE(/1)) 422 : IBMN=MIN(IB,VELCHE(/2)) 422 : CALL NDKT (IGAU,XEL,EXCEN,SHPTOT,SHPWRK,BGENE,DJAC) 423 : DJAC=DJAC*POIGAU(IGAU)*EPAIST 424 : DJAC=DJAC*VELCHE(IGMN,IBMN) 424 : CALL NTNST(BGENE,DJAC,LRE,NDDL,REL) 425 : 5028 CONTINUE 426 : C 427 : C 428 : C DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP 429 : C 430 : C REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) .... 431 : C 432 : IF ( ILUMP .EQ. 1 ) THEN 432 : CALL LUMP3(REL) 433 : ENDIF 434 : C 435 : C 436 : C 437 : ICOM = 0 438 : IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0) 439 : & ICOM=1 439 : CALL TRANSK(REL,BPSS,LRE,3,ICOM) 440 : * SEGINI XMATRI 441 : * IMATTT(IB)=XMATRI 442 : C 443 : C REMPLISSAGE DE XMATRI 444 : C 444 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 445 : * SEGDES XMATRI 446 : 3028 CONTINUE 447 : SEGSUP WRK1,WRK2,WRK4,MVELCH 448 : segdes xmatri 449 : GOTO 510 450 : C_______________________________________________________________________ 451 : C 452 : C ELEMENT COQ6 COQ8 453 : C_______________________________________________________________________ 454 : C 455 : 41 CONTINUE 456 : NBBB=NBNN 457 : SEGINI WRK1,WRK3 458 : C 459 : DO 3041 IB=1,NBELEM 459 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 460 : MPTVAL=IVAMAT 461 : MELVAL=IVAL(1) 462 : IBMN=MIN(IB,VELCHE(/2)) 463 : VALMAT(1)=VELCHE(1,IBMN) 464 : C 465 : MPTVAL=IVACAR 466 : MELVAL=IVAL(1) 467 : IBMN=MIN(IB,VELCHE(/2)) 468 : RR=VALMAT(1)*VELCHE(1,IBMN) 469 : C 470 : C CALCUL DE L'EPAISSEUR ET DE L'EXCENREMENT 471 : C 472 : C MPTVAL=IVACAR 473 : IF (IVAL(1).NE.0) THEN 474 : MELVAL=IVAL(1) 475 : DO IGAU=1,NBPGAU 476 : IGMN=MIN(IGAU,VELCHE(/1)) 477 : IBMN=MIN(IB ,VELCHE(/2)) 478 : WORK(IGAU)=VELCHE(IGMN,IBMN) 479 : ENDDO 480 : ELSE 481 : WORK(IGAU)=0 482 : ENDIF 483 : IF (IVAL(2).NE.0) THEN 484 : MELVAL=IVAL(2) 485 : DO IGAU=1,NBPGAU 486 : IGMN=MIN(IGAU,VELCHE(/1)) 487 : IBMN=MIN(IB ,VELCHE(/2)) 488 : WORK(IGAU+10)=VELCHE(IGMN,IBMN) 489 : ENDDO 490 : ELSE 491 : WORK(IGAU+10)=0 492 : ENDIF 493 : 5041 CONTINUE 494 : C 495 : RHO=VALMAT(1) 496 : EPAI = WORK(1) 497 : EXENT= WORK(11) 498 : SEGDES WRK1,WRK3 499 : SEGDES MINTE 499 : CALL COQ8MA(NBNN,RHO,NBPGAU,EPAI,EXENT,WRK1,MINTE,MINTE2) 500 : SEGACT WRK1,WRK3*MOD 501 : SEGACT MINTE 502 : * SEGINI XMATRI 503 : * IMATTT(IB)=XMATRI 504 : IF (ILUMP .EQ. 1) THEN 504 : CALL LUMP7(REL,LRE,RE,NBNN) 505 : ELSE 505 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 506 : ENDIF 507 : * SEGDES XMATRI 508 : 3041 CONTINUE 509 : SEGDES xMATRI 510 : SEGSUP WRK1,WRK3,MVELCH 511 : GOTO 510 512 : C_______________________________________________________________________ 513 : C 514 : C SECTEUR DE CALCUL POUR LES COQ2 515 : C_______________________________________________________________________ 516 : C 517 : 44 CONTINUE 518 : DIM3=1.D0 519 : NBNO=NBNN 520 : NBBB=NBNN 521 : SEGINI WRK1,WRK3 522 : I255=0 523 : I256=0 524 : C 525 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 526 : C 527 : DO 3044 IB=1,NBELEM 528 : C 529 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 530 : C 530 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 531 : C 532 : MPTVAL=IVACAR 533 : MELVAL=IVAL(1) 534 : IBMN=MIN(IB,VELCHE(/2)) 535 : EP=VELCHE(1,IBMN) 536 : IF(IFOUR.EQ.-2) THEN 537 : MELVAL=IVAL(3) 538 : IF(MELVAL.NE.0) THEN 539 : IBMN=MIN(IB,VELCHE(/2)) 540 : DIM3=VELCHE(1,IBMN) 541 : ELSE 542 : DIM3=1.D0 543 : ENDIF 544 : ENDIF 545 : C 546 : MPTVAL=IVAMAT 547 : DO 4044 IM=1,NMATT 548 : MELVAL=IVAL(IM) 549 : IBMN=MIN(IB,VELCHE(/2)) 550 : VALMAT(IM)=VELCHE(1,IBMN) 551 : 4044 CONTINUE 552 : RHO=VALMAT(1) 553 : C 554 : C APPEL A LA SUBROUTINE CALCULANT LA MATRICE MASSE 555 : C 555 : CALL COQ2MA(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, 556 : + XDPGE,YDPGE) 557 : C 558 : C GESTION D'ERREUR 559 : C 560 : IF(IARR.EQ.1) I255=IB 561 : IF(IARR.EQ.2) I256=IB 562 : C 563 : C REMPLISSAGE 564 : C 565 : C 566 : * SEGINI XMATRI 567 : * IMATTT(IB)=XMATRI 568 : IF (ILUMP .EQ. 1) THEN 568 : CALL LUMP5(REL,LRE,RE(1,1,ib),IFOUR) 569 : ELSE 569 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 570 : ENDIF 571 : * SEGDES XMATRI 572 : 3044 CONTINUE 573 : C 574 : C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... 575 : C 576 : IF(I255.NE.0) THEN 577 : INTERR(1)=I255 577 : CALL ERREUR(255) 578 : ENDIF 579 : IF(I256.NE.0) THEN 580 : INTERR(1)=I256 580 : CALL ERREUR(256) 581 : ENDIF 582 : C 583 : SEGDES xMATRI 584 : SEGSUP WRK1,WRK3,MVELCH 585 : GOTO 510 586 : C_______________________________________________________________________ 587 : C 588 : C SECTEUR DE CALCUL POUR LES COQ4 589 : C_______________________________________________________________________ 590 : C 591 : 49 CONTINUE 592 : NBNO=NBNN 593 : NBBB=NBNN 594 : SEGINI WRK1,WRK2,WRK4,WRK6 595 : IG1=0 596 : IG2=0 597 : IG3=0 598 : C 599 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 600 : C 601 : DO 3049 IB=1,NBELEM 602 : C 603 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 604 : C 604 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 604 : CALL ZERO (REL,LRE,LRE) 605 : C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé 605 : CALL CQ4LOC(XE,XEL,BPSS,IERT,0) 606 : C 607 : MPTVAL=IVACAR 608 : MELVAL=IVAL(1) 609 : IBMN=MIN(IB,VELCHE(/2)) 610 : EP=VELCHE(1,IBMN) 611 : IF (IVAL(2).NE.0) THEN 612 : MELVAL=IVAL(2) 613 : IBMN=MIN(IB,VELCHE(/2)) 614 : EXCEN =VELCHE(1,IBMN) 615 : ELSE 616 : EXCEN=0.D0 617 : ENDIF 618 : C 619 : MPTVAL=IVAMAT 620 : MELVAL=IVAL(1) 621 : IBMN=MIN(IB,VELCHE(/2)) 622 : VALMAT(1)=VELCHE(1,IBMN) 623 : RHO=VALMAT(1) 624 : C 625 : C CALCUL MATRICE MASSE 626 : C 626 : CALL ZERO(RHOMAT,6,6) 627 : RHOMAT( 1, 1)=RHO*EP 628 : RHOMAT( 1, 5)=RHO*EP*EXCEN 629 : RHOMAT( 5, 1)=RHOMAT(1,5) 630 : RHOMAT( 2, 2)=RHO*EP 631 : RHOMAT( 2, 4)=-RHO*EP*EXCEN 632 : RHOMAT( 4, 2)=RHOMAT(2,4) 633 : RHOMAT( 3, 3)=RHO*EP 634 : RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2 635 : RHOMAT( 5, 5)=RHOMAT(4,4) 636 : NBPGAM=NBPGAU-1 637 : DO 4049 IGAU=1,NBPGAM 637 : CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT) 638 : C IERT=1 JACOBIANO=<0 639 : IF(IERT.EQ.1) IG3=IB 640 : DJAC=DJAC*POIGAU(IGAU) 640 : CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL) 641 : 4049 CONTINUE 642 : C 643 : C LA DIAGONALISATION éVENTUELLE A LIEU AVANT LE PASSAGE 644 : C EN COORDONNéES GLOBALES 645 : C 646 : IF ( ILUMP .EQ. 1) THEN 646 : CALL LUMP4(REL) 647 : ENDIF 648 : C 648 : CALL TRANSK(REL,BPSS,24,4,0) 649 : C 650 : C REMPLISSAGE 651 : C 652 : * SEGINI XMATRI 653 : * IMATTT(IB)=XMATRI 653 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 654 : * SEGDES XMATRI 655 : 3049 CONTINUE 656 : C 657 : C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR... 658 : C 659 : IF(IG1.NE.0) THEN 660 : INTERR(1)=IG1 660 : CALL ERREUR(323) 661 : ENDIF 662 : IF(IG2.NE.0) THEN 663 : INTERR(1)=IG2 663 : CALL ERREUR(322) 664 : ENDIF 665 : IF(IG3.NE.0) THEN 666 : INTERR(1)=IG3 666 : CALL ERREUR(321) 667 : ENDIF 668 : C 669 : SEGDES xMATRI 670 : SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH 671 : GOTO 510 672 : C_______________________________________________________________________ 673 : C 674 : C SECTEUR DE CALCUL POUR L'ELEMENT DST 675 : C_______________________________________________________________________ 676 : C 677 : 93 CONTINUE 678 : NBNO=NBNN 679 : NBBB=NBNN 680 : SEGINI WRK1,WRK2,WRK4,WRK6 681 : C 682 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 683 : C 684 : DO 3093 IB=1,NBELEM 685 : C 686 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 687 : C 687 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 687 : CALL ZERO (REL,LRE,LRE) 687 : CALL VPAST(XE,BPSS) 687 : CALL VCORLC(XE,XEL,BPSS) 688 : C 689 : C ACQUISITION DES EPAISSEURS 690 : C 691 : EP=0.D0 692 : EXCEN=0.D0 693 : MPTVAL=IVACAR 694 : MELVAL=IVAL(1) 695 : IF (MELVAL.NE.0) THEN 696 : DO IGAU=1,NBPGAU 697 : IGMN=MIN(IGAU,VELCHE(/1)) 698 : IBMN=MIN(IB ,VELCHE(/2)) 699 : EP=EP+VELCHE(IGMN,IBMN) 700 : ENDDO 701 : ENDIF 702 : C 703 : MELVAL=IVAL(2) 704 : IF (MELVAL.NE.0) THEN 705 : DO IGAU=1,NBPGAU 706 : IGMN=MIN(IGAU,VELCHE(/1)) 707 : IBMN=MIN(IB ,VELCHE(/2)) 708 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 709 : ENDDO 710 : ENDIF 711 : EP=EP/NBPGAU 712 : EXCEN=EXCEN/NBPGAU 713 : C 714 : C BOULE SUR LES POINTS DE GAUSS 715 : C 716 : DO 5093 IGAU=1,NBPGAU 717 : C 718 : MPTVAL=IVAMAT 719 : MELVAL=IVAL(1) 720 : IBMN=MIN(IB,VELCHE(/2)) 721 : IGMN=MIN(IGAU,VELCHE(/1)) 722 : RHO=VELCHE(IGMN,IBMN) 723 : C 724 : C CALCUL MATRICE MASSE 725 : C 725 : CALL ZERO(RHOMAT,6,6) 726 : RHOMAT( 1, 1)=RHO*EP 727 : RHOMAT( 1, 5)=RHO*EP*EXCEN 728 : RHOMAT( 5, 1)=RHOMAT(1,5) 729 : RHOMAT( 2, 2)=RHO*EP 730 : RHOMAT( 2, 4)=-RHO*EP*EXCEN 731 : RHOMAT( 4, 2)=RHOMAT(2,4) 732 : RHOMAT( 3, 3)=RHO*EP 733 : RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2 734 : RHOMAT( 5, 5)=RHOMAT(4,4) 734 : CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC) 735 : DJAC=DJAC*POIGAU(IGAU) 735 : CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL) 736 : 5093 CONTINUE 737 : C 738 : C DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP 739 : C 740 : C REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) .... 741 : C 742 : IF ( ILUMP .EQ. 1 ) THEN 742 : CALL LUMP3(REL) 743 : ENDIF 744 : C 745 : C 746 : C 747 : ICOM = 0 748 : IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0) 749 : & ICOM=1 749 : CALL TRANSK(REL,BPSS,18,3,ICOM) 750 : C 751 : C REMPLISSAGE 752 : C 753 : * SEGINI XMATRI 754 : * IMATTT(IB)=XMATRI 754 : CALL REMPMT(REL,LRE,RE(1,1,ib)) 755 : * SEGDES XMATRI 756 : 3093 CONTINUE 757 : SEGDES xMATRI 758 : SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH 759 : GOTO 510 760 : C_______________________________________________________________________ 761 : * 762 : 99 CONTINUE 763 : MOTERR(1:4)=NOMTP(MELE) 764 : MOTERR(5:12)='MASSE3' 764 : CALL ERREUR(86) 765 : * 766 : 510 CONTINUE 767 : RETURN 768 : END 769 : C 770 : 771 : 772 : 773 : 774 :
© Cast3M 2003 - All rights reserved.
Disclaimer