1 : C AMOR4 SOURCE KICH 11/08/11 21:15:10 7079 2 : SUBROUTINE AMOR4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS, 3 : & IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT, 4 : & LHOOK,NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD) 5 : *---------------------------------------------------------------------* 6 : * ________________________________________ * 7 : * | | * 8 : * | CALCUL DE L AMORTISSEMENT STRUCTUREL | * 9 : * |_______________________________________| * 10 : * * 11 : * poutre,tuyau,barre 12 : * * 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 : * NMATT Nombre de composantes de materiau (IMAT=1) * 37 : * NCARR Nombre de caracteristiques geometriques * 38 : * ISOUS NUMERO DE LA SOUS-ZONE * 39 : * LW Dimension du tableau de travail * 40 : * IPORE nombre de fonctions de forme * 41 : * ICAS 1 si amortissement * 42 : * 2 si rigidite antisymetrique * 43 : * * 44 : * * 45 : * SORTIES : * 46 : * ________ * 47 : * * 48 : * IPMATR pointeur sur la rigidite de la sous-zone * 49 : * * 50 : * * 51 : *---------------------------------------------------------------------* 52 : IMPLICIT INTEGER(I-N) 53 : IMPLICIT REAL*8(A-H,O-Z) 54 : * 55 : -INC CCOPTIO 56 : -INC CCHAMP 57 : -INC CCREEL 58 : *- 59 : -INC SMCHAML 60 : -INC SMINTE 61 : -INC SMELEME 62 : -INC SMRIGID 63 : -INC SMMODEL 64 : -INC SMCOORD 65 : -INC SMLREEL 66 : -INC SMLMOTS 67 : * 68 : SEGMENT WRK1 69 : REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS) 70 : REAL*8 REL(LRE,LRE) , XE(3,NBBB) 71 : ENDSEGMENT 72 : * 73 : SEGMENT WRK2 74 : REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE) 75 : ENDSEGMENT 76 : * 77 : SEGMENT WRK3 78 : REAL*8 WORK(LW) 79 : ENDSEGMENT 80 : * 81 : SEGMENT WRK4 82 : REAL*8 BPSS(3,3),XEL(3,NBBB) 83 : ENDSEGMENT 84 : * 85 : SEGMENT WRK5 86 : REAL*8 XGENE(NSTN,LRN) 87 : ENDSEGMENT 88 : * 89 : SEGMENT WRK6 90 : REAL*8 PSS(3,3) 91 : ENDSEGMENT 92 : * 93 : SEGMENT,MVELCH 94 : REAL*8 VALMAT(NV1) 95 : ENDSEGMENT 96 : * 97 : SEGMENT MPTVAL 98 : INTEGER IPOS(NS) ,NSOF(NS) 99 : INTEGER IVAL(NCOSOU) 100 : CHARACTER*16 TYVAL(NCOSOU) 101 : ENDSEGMENT 102 : * 103 : CHARACTER*4 lesinc(7),lesdua(7) 104 : DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/ 105 : DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/ 106 : * 107 : DIMENSION CRIGI(12),CMASS(12) 108 : CHARACTER*4 CMOT 109 : CHARACTER*8 CMATE 110 : * 111 : MELEME=IPMAIL 112 : NBNN=NUM(/1) 113 : NBELEM=NUM(/2) 114 : * 115 : NV1=NMATT 116 : SEGINI,MVELCH 117 : * 118 : XMATRI=IPMATR 119 : * LVAL = (LRE*(LRE+1))/2 120 : NLIGRP=LRE 121 : NLIGRD=LRE 122 : * 123 : * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT 124 : * DE LA SECTION EN DEFO PLANE GENERALISEE 125 : * 126 : * PPJ IF (IFOUR.EQ.-3)THEN 127 : IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN 128 : IP=IIPDPG 129 : SEGACT MCOORD 130 : IREF=(IP-1)*(IDIM+1) 131 : XDPGE=XCOOR(IREF+1) 132 : YDPGE=XCOOR(IREF+2) 133 : ELSE 134 : XDPGE=0.D0 135 : YDPGE=0.D0 136 : ENDIF 137 : * 138 : NHRM=NIFOUR 139 : * 140 : MINTE=IPMINT 141 : IRTD=1 142 : * 143 : IF (mfr.eq.28) THEN 144 : jgn = 4 145 : if (ifour.eq.2) then 146 : jgm = 6 147 : segini mlmots 148 : iinc = mlmots 149 : do igm = 1,jgm 150 : mots(igm) = lesinc(igm) 151 : enddo 152 : segini mlmots 153 : idua = mlmots 154 : do igm= 1,jgm 155 : mots(igm) = lesdua(igm) 156 : enddo 157 : else if (ifour.lt.0) then 158 : jgm = 4 159 : segini mlmots 160 : iinc = mlmots 161 : mots(1) = lesinc(1) 162 : mots(2) = lesinc(2) 163 : mots(3) = lesinc(4) 164 : mots(4) = lesinc(5) 165 : segini mlmots 166 : idua = mlmots 167 : mots(1) = lesdua(1) 168 : mots(2) = lesdua(2) 169 : mots(3) = lesdua(4) 170 : mots(4) = lesdua(5) 171 : else if (ifour.eq.0) then 172 : jgm = 3 173 : segini mlmots 174 : iinc = mlmots 175 : mots(1) = lesinc(7) 176 : mots(2) = lesinc(3) 177 : mots(3) = lesinc(6) 178 : segini mlmots 179 : idua = mlmots 180 : mots(1) = lesdua(7) 181 : mots(2) = lesdua(3) 182 : mots(3) = lesdua(6) 183 : else if (ifour.eq.1) then 184 : * a faire 185 : endif 186 : ENDIF 187 : 188 : IMODEL = IMOD 189 : jmat = 0 190 : DO imat = 1 , matmod(/2) 191 : if (matmod(imat).eq.'IMPEDANCE') then 192 : jmat = imat 193 : * goto 29 194 : endif 195 : ENDDO 196 : C 197 : C_______________________________________________________________________ 198 : C 199 : C NUMERO DES ETIQUETTES : 200 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 201 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 202 : C 5 CONTINUE 203 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 204 : C 44 CONTINUE 205 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 206 : C_______________________________________________________________________ 207 : C 208 : 209 : * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 210 : GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 211 : * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT 212 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 213 : * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 214 : & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99 215 : * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 216 : & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 99, 99 217 : * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO 218 : & , 45, 46, 99, 99, 99, 99, 99, 99, 99, 99, 99 219 : * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 220 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 221 : * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 222 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 223 : * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 224 : & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99 225 : * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 226 : & , 99, 99, 99, 99, 99, 99, 46, 99, 99, 99, 99 227 : * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 228 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 229 : * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 230 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 231 : * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 232 : & , 99, 46, 124, 99, 99, 99, 99, 99, 99, 99, 99 233 : * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 234 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 235 : * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 236 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 237 : * TE56 PY91 TRH6 238 : & , 99, 99, 99),MELE 239 : C 240 : C GOTO(168,169,170,171,172),MELE-167 241 : C 242 : GOTO 99 243 : C_______________________________________________________________________ 244 : C 245 : C ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO 246 : C_______________________________________________________________________ 247 : C 248 : 29 CONTINUE 249 : IF (jmat.gt.0) THEN 250 : MPTVAL=IVAMAT 251 : MELVAL=IVAL(1) 252 : if (ival(/1).ge.1) then 253 : * melva1 = ival(1) 254 : melva1 = ival(2) 255 : else 256 : melva1 = 0 257 : endif 258 : jddl = LRE/NBPGAU 259 : DO IB = 1,NBELEM 260 : JDIAG = 0 261 : IBMN=MIN(IB,VELCHE(/2)) 262 : * kich 1 pgauss inutile 263 : ig = 1 264 : igmn = MIN(IG,VELCHE(/1)) 265 : XAMOR=VELCHE(IGMN,IBMN) 266 : XINAM = XAMOR 267 : if (melva1.gt.0) then 268 : XINAM = melva1.VELCHE(IGMN,IBMN) 269 : endif 270 : do idl = 1,jddl 271 : JDIAG = JDIAG + 1 272 : RE(JDIAG,JDIAG,ib) = XAMOR 273 : if (idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM 274 : enddo 275 : do idl = jddl+1, LRE 276 : JDIAG = JDIAG + 1 277 : RE(JDIAG,JDIAG,ib) = XAMOR 278 : if (idl.gt.jddl+3) RE(JDIAG,JDIAG,ib) = XINAM 279 : enddo 280 : ENDDO 281 : SEGDES XMATRI 282 : GOTO 510 283 : ENDIF 284 : 285 : NBBB=NBNN 286 : SEGINI WRK1,WRK3 287 : C 288 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 289 : C 290 : KERRE=0 291 : DO 3029 IB=1,NBELEM 292 : C 293 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 294 : C 294 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 295 : C 296 : C CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE 297 : C 298 : IF (MELE.EQ.98) THEN 298 : CALL ZERO(REL,LRE,LRE) 299 : GOTO 8029 300 : ENDIF 301 : C 302 : C RANGEMENT DES CARACTERISTIQUES DANS WORK 303 : C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION 304 : C 305 : NCARR1=NCARR 306 : IF(IVECT.EQ.1) NCARR1=NCARR-1 306 : CALL ZERO(WORK,NCARR1,1) 307 : DO 4030 IGAU=1,NBNN 308 : MPTVAL=IVACAR 309 : DO 6029 IC=1,NCARR1 310 : IF (IVAL(IC).NE.0) THEN 311 : MELVAL=IVAL(IC) 312 : IBMN=MIN(IB,VELCHE(/2)) 313 : IGMN=MIN(IGAU,VELCHE(/1)) 314 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 315 : ELSE 316 : WORK(IC)=0.D0 317 : ENDIF 318 : IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN 319 : 6029 CONTINUE 320 : 4030 CONTINUE 321 : C 322 : C CAS OU ON A LU LE MOT VECTEUR 323 : C 324 : IF (IVECT.EQ.1) THEN 325 : IF (IVAL(NCARR).NE.0) THEN 326 : MELVAL=IVAL(NCARR) 327 : IBMN=MIN(IB,IELCHE(/2)) 328 : IP=IELCHE(1,IBMN) 329 : IREF=(IP-1)*(IDIM+1) 330 : DO 6129 IC=1,IDIM 331 : WORK(NCARR+IC-1)=XCOOR(IREF+IC) 332 : 6129 CONTINUE 333 : ELSE 334 : DO 6229 IC=1,IDIM 335 : WORK(NCARR+IC-1)=0.D0 336 : 6229 CONTINUE 337 : ENDIF 338 : ENDIF 339 : C 340 : MPTVAL=IVAMAT 341 : C 342 : C AUTRES CAS ...... 343 : C 344 : MELVAL=IVAL(1) 345 : * 346 : IF(CMATE.NE.'SECTION') THEN 347 : IBMN=MIN(IB,VELCHE(/2)) 348 : VALMAT(1)=VELCHE(1,IBMN) 349 : YOUNG=VALMAT(1) 350 : C 351 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 352 : C EQUIVALENTE 353 : IF(MELE.EQ.42) THEN 354 : IF (ICAS.EQ.2) WORK(10)=WORK(9) 355 : WORK(9)=WORK(8) 356 : WORK(8)=WORK(7) 357 : WORK(7)=WORK(6) 358 : EPAIS=WORK(1) 359 : REXT=WORK(2) 360 : RINT=REXT-EPAIS 361 : RACO=WORK(3) 362 : PRES=WORK(4) 363 : CISA=WORK(5) 364 : XIN=XPI*(REXT**4-RINT**4)*0.25D00 365 : WORK(1)=2.D00*XIN 366 : WORK(2)=XIN 367 : WORK(3)=XIN 368 : WORK(4)=XPI*(REXT**2-RINT**2) 369 : WORK(5)=WORK(4)*0.5D0*CISA 370 : WORK(6)=WORK(5) 371 : C 372 : C 373 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 374 : WORK(4)=VALMAT(1) 375 : AUX=VALMAT(2) 376 : WORK(5)=WORK(4)*0.5D0/(1.D0+AUX) 377 : ELSE 378 : C 379 : IF (ICAS.EQ.2) THEN 380 : WORK(11)=VALMAT(1) 381 : WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) 382 : ELSE 383 : WORK(10)=VALMAT(1) 384 : WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) 385 : ENDIF 386 : ENDIF 387 : ENDIF 388 : C 389 : C 390 : DO 9029 IM=1,NMATT 391 : IF (IVAL(IM).NE.0) THEN 392 : MELVAL=IVAL(IM) 393 : IBMN=MIN(IB,VELCHE(/2)) 394 : VALMAT(IM)=VELCHE(1,IBMN) 395 : ELSE 396 : VALMAT(IM)=0.D0 397 : ENDIF 398 : C 399 : 9029 CONTINUE 400 : IF(MELE.EQ.84) THEN 401 : C 402 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 402 : CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 403 : ELSE 403 : CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 404 : ENDIF 405 : ELSE 406 : C 407 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 407 : CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 408 : ELSE 408 : CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD) 409 : ENDIF 410 : ENDIF 411 : C------------- 412 : C PROVISOIRE 413 : C------------- 414 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 415 : WORK(4)=VALMAT(1) 416 : AUX=VALMAT(2) 417 : WORK(5)=WORK(4)*0.5D0/(1.D0+AUX) 418 : ELSE 419 : C 420 : IF (ICAS.EQ.2) THEN 421 : WORK(11)=VALMAT(1) 422 : WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) 423 : ELSE 424 : WORK(10)=VALMAT(1) 425 : WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2)) 426 : ENDIF 427 : ENDIF 428 : C------------- 429 : C ENDIF 430 : C------------- 431 : * 432 : * CAS DE LA FORMULATION SECTION 433 : * 434 : ELSE 435 : * 436 : * ON REGARDE SI ON A LA COMPOSANTE MAHO 437 : * SI OUI, ON LA PREND 438 : * 439 : C IF(IVAL(3).NE.0) THEN 440 : C MELVAL=IVAL(3) 441 : C IBMN=MIN(IB,IELCHE(/2)) 442 : C MLREEL=IELCHE(1,IBMN) 443 : C SEGACT MLREEL 444 : C IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 444 : C $ CALL DOHOOO(PROG,LHOOK,DDHOOK) 445 : C SEGDES MLREEL 446 : * 447 : C ELSE 448 : IBMN=MIN(IB,IELCHE(/2)) 449 : IPMODL=IELCHE(1,IBMN) 450 : MELVAL=IVAL(2) 451 : IBMN=MIN(IB,IELCHE(/2)) 452 : IPMAT=IELCHE(1,IBMN) 452 : CALL FAMORE(IPMODL,IPMAT,CRIGI,CMASS) 453 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 453 : $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 454 : C ENDIF 455 : ENDIF 456 : C 457 : C 458 : C FIN TRAITEMENT DES DONNEES MATERIAUX 459 : C 460 : IF(MELE.EQ.97) THEN 460 : CALL ACORIG(REL,LRE,WORK,XE,KERRE) 461 : ELSE IF(MELE.EQ.84) THEN 462 : IF (ICAS.EQ.1) THEN 463 : C 464 : C Matrice d amortissement symetrique Timo 465 : C 466 : C 467 : IF(CMATE.NE.'SECTION') THEN 468 : C 469 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 469 : CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE) 470 : ELSE 470 : CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE) 471 : ENDIF 472 : * 473 : ELSE 474 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 474 : CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK, 475 : $ DDHOOK,KERRE) 476 : ELSE 476 : CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK, 477 : $ DDHOOK,KERRE) 478 : ENDIF 479 : ENDIF 480 : C 481 : ELSE 482 : C 483 : C Matrice de raideur antisymetrique Timo (seulement en 3D) 484 : C 485 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 486 : KERRE = 1 487 : ELSE 488 : C 489 : IF(CMATE.NE.'SECTION') THEN 489 : CALL TIMDH3(REL,WORK,XE,KERRE) 490 : ELSE 491 : C KERRE = 1 492 : C ENDIF 493 : C 493 : CALL TIFDH3(REL,WORK,XE,LHOOK,DDHOOK,KERRE) 494 : ENDIF 495 : ENDIF 496 : ENDIF 497 : ELSE 498 : C 499 : IF (ICAS.EQ.1) THEN 500 : C 501 : C Matrice d amortissement symetrique Poutre 502 : 503 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 503 : CALL POURI2(REL,LRE,WORK,XE,WORK(12),KERRE) 504 : ELSE 504 : CALL POURIG(REL,LRE,WORK,XE,WORK(12),KERRE) 505 : ENDIF 506 : ELSE 507 : C 508 : C Matrice de raideur antisymetrique Poutre (seulement en 3D) 509 : C 510 : IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN 511 : KERRE = 1 512 : ELSE 512 : CALL POUDH3(REL,WORK,XE,KERRE) 513 : ENDIF 514 : ENDIF 515 : ENDIF 516 : C 517 : IF(KERRE.NE.0) INTERR(1)=ISOUS 518 : IF(KERRE.NE.0) INTERR(2)=IB 519 : C 520 : 4029 CONTINUE 521 : 8029 CONTINUE 522 : * SEGINI XMATRI 523 : * IMATTT(IB)=XMATRI 524 : C 525 : C REMPLISSAGE DE XMATRI 526 : C 527 : DO 4028 IIIA=1,LRE 528 : DO 4028 IIIB=1,LRE 529 : RE(IIIA,IIIB,IB)=REL(IIIA,IIIB) 530 : 4028 CONTINUE 531 : * SEGDES XMATRI 532 : 3029 CONTINUE 532 : IF(KERRE.EQ.1) CALL ERREUR(128) 532 : IF(KERRE.EQ.2) CALL ERREUR(138) 533 : IF(IRTD.EQ.0) THEN 534 : MOTERR(1:8)=CMATE 535 : MOTERR(9:16)=NOMFR(MFR/2+1) 536 : INTERR(1)=IFOUR 536 : CALL ERREUR(81) 537 : ENDIF 538 : SEGDES XMATRI 539 : SEGSUP WRK1,WRK3,MVELCH 540 : GOTO 510 541 : 542 : C_______________________________________________________________________ 543 : C 544 : C ELEMENT POI1 545 : C_______________________________________________________________________ 546 : C 547 : 45 CONTINUE 548 : IF (jmat.gt.0) THEN 549 : MPTVAL=IVAMAT 550 : MELVAL=IVAL(1) 551 : if (ival(/1).ge.1) then 552 : * melva1 = ival(1) 553 : melva1 = ival(2) 554 : else 555 : melva1 = 0 556 : endif 557 : jddl = LRE/NBPGAU 558 : DO IB = 1,NBELEM 559 : JDIAG = 0 560 : IBMN=MIN(IB,VELCHE(/2)) 561 : ig = 1 562 : igmn = MIN(IG,VELCHE(/1)) 563 : XAMOR=VELCHE(IGMN,IBMN) 564 : XINAM = XAMOR 565 : if (melva1.gt.0) then 566 : XINAM = melva1.VELCHE(IGMN,IBMN) 567 : endif 568 : do idl = 1,jddl 569 : JDIAG = JDIAG + 1 570 : RE(JDIAG,JDIAG,ib) = XAMOR 571 : if (idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM 572 : enddo 573 : do idl = jddl+1, LRE 574 : JDIAG = JDIAG + 1 575 : RE(JDIAG,JDIAG,ib) = XAMOR 576 : if (idl.gt.jddl+3) RE(JDIAG,JDIAG,ib) = XINAM 577 : enddo 578 : ENDDO 579 : SEGDES XMATRI 580 : GOTO 510 581 : ENDIF 582 : 583 : IF (MFR.EQ.26) THEN 584 : * MODAL 585 : DO IB = 1,NBELEM 586 : * SEGINI XMATRI 587 : * IMATTT(IB)=XMATRI 588 : 589 : MPTVAL=IVAMAT 590 : MELVAL=IVAL(1) 591 : IBMN=MIN(IB,VELCHE(/2)) 592 : XFREQ=VELCHE(1,IBMN) 593 : MELVAL=IVAL(2) 594 : IBMN=MIN(IB,VELCHE(/2)) 595 : XMASS=VELCHE(1,IBMN) 596 : MELVAL=IVAL(4) 597 : if (melval.gt.0) then 598 : IBMN=MIN(IB,VELCHE(/2)) 599 : XAMOR=VELCHE(1,IBMN) 600 : else 601 : xamor = 0. 602 : endif 603 : OMEG = 2. * XPI * XFREQ 604 : RE(1,1,IB) = XMASS * OMEG * XAMOR 605 : * SEGDES XMATRI 606 : ENDDO 607 : SEGDES XMATRI 608 : GOTO 510 609 : * 610 : ELSE IF (MFR.EQ.28) THEN 611 : * STATIQUE 612 : DO IB = 1,NBELEM 613 : * SEGINI XMATRI 614 : * IMATTT(IB)=XMATRI 615 : 616 : MPTVAL=IVAMAT 617 : MELVAL=IVAL(4) 618 : IBMN=MIN(IB,VELCHE(/2)) 619 : if (melval.gt.0) then 620 : segact melval 621 : XAMOR=VELCHE(1,IBMN) 622 : else 623 : re(1,1,IB) = 0.d0 624 : endif 625 : if (xamor.ne.0.d0) then 626 : MELVAL=IVAL(1) 627 : IBMN=MIN(IB,IELCHE(/2)) 628 : idepl=IELCHE(1,IBMN) 629 : MELVAL=IVAL(2) 630 : IBMN=MIN(IB,IELCHE(/2)) 631 : itreac=IELCHE(1,IBMN) 631 : CALL XTY1(idepl,itreac,iinc,idua,XR1) 632 : if (ierr.ne.0) return 633 : MELVAL=IVAL(3) 634 : IBMN=MIN(IB,IELCHE(/2)) 635 : imade=IELCHE(1,IBMN) 635 : CALL XTY1(idepl,imade,iinc,idua,XM1) 636 : if (ierr.ne.0) return 637 : x1 = xm1 * xr1 638 : re(1,1,IB) = dsqrt(dabs(x1))*xamor 639 : if (x1.lt.0.) re(1,1,IB) = re(1,1,IB) *(-1.d0) 640 : endif 641 : * SEGDES XMATRI 642 : ENDDO 643 : SEGDES XMATRI 644 : GOTO 510 645 : ENDIF 646 : * 647 : C_______________________________________________________________________ 648 : C 649 : C ELEMENTS BARRE ET CERCE 650 : C_______________________________________________________________________ 651 : C 652 : 46 CONTINUE 653 : * 654 : IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN 655 : GO TO 99 656 : ENDIF 657 : NBBB=NBNN 658 : SEGINI WRK1,WRK3 659 : IF(MELE.EQ.123) THEN 660 : NSTN=NBNN 661 : LRN =LRE 662 : SEGINI WRK5 663 : ENDIF 664 : C 665 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 666 : C 667 : KERRE=0 668 : DO 3046 IB=1,NBELEM 669 : C 670 : C ON CHERCHE LES COORDONNEES DE L ELEMENT IB 671 : C 671 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 672 : C 673 : C 674 : C ON RECUPERE LA SECTION DE L'ELEMENT 675 : C 676 : MPTVAL=IVACAR 677 : MELVAL=IVAL(1) 678 : IBMN=MIN(IB,VELCHE(/2)) 679 : SECT=VELCHE(1,IBMN) 680 : C 681 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 682 : C 683 : MPTVAL=IVAMAT 684 : * 685 : DO 9046 IM=1,NMATT 686 : IF (IVAL(IM).NE.0) THEN 687 : MELVAL=IVAL(IM) 688 : IBMN=MIN(IB ,VELCHE(/2)) 689 : VALMAT(IM)=VELCHE(1,IBMN) 690 : ELSE 691 : VALMAT(IM)=0.D0 692 : ENDIF 693 : 9046 CONTINUE 693 : CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) 694 : C 694 : IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) 694 : IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE) 694 : IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB) 695 : IF(KERRE.NE.0) INTERR(1)=ISOUS 696 : IF(KERRE.NE.0) INTERR(2)=IB 697 : C 698 : * SEGINI XMATRI 699 : * IMATTT(IB)=XMATRI 700 : C 701 : C REMPLISSAGE DE XMATRI 702 : C 702 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 703 : * SEGDES XMATRI 704 : 3046 CONTINUE 704 : IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128) 704 : IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601) 704 : IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128) 705 : IF(IRTD.EQ.0) THEN 706 : MOTERR(1:8)=CMATE 707 : MOTERR(9:16)=NOMFR(MFR/2+1) 708 : INTERR(1)=IFOUR 708 : CALL ERREUR(81) 709 : ENDIF 710 : SEGDES XMATRI 711 : SEGSUP WRK1,WRK3,MVELCH 712 : IF(MELE.EQ.123) SEGSUP WRK5 713 : GOTO 510 714 : C 715 : C_______________________________________________________________________ 716 : C 717 : C ELEMENT BARRE 3D EXCENTRE (BAEX) 718 : C_______________________________________________________________________ 719 : C 720 : 124 CONTINUE 721 : NBBB=NBNN 722 : NBNO=NBNN 723 : NSTRS1=NSTRS 724 : NSTRS=NBNN 725 : SEGINI WRK1,WRK2,WRK3 726 : C 727 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 728 : C 729 : KERRE=0 730 : DO 3108 IB=1,NBELEM 731 : C 732 : C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON 733 : C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK 734 : C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ 735 : C 736 : MPTVAL=IVACAR 737 : DO IC=1,NCARR 738 : IF(IVAL(IC).NE.0) THEN 739 : MELVAL=IVAL(IC) 740 : IBMN=MIN(IB,VELCHE(/2)) 741 : WORK(IC)=VELCHE(1,IBMN) 742 : ELSE 743 : WORK(IC)=0.D0 744 : ENDIF 745 : END DO 746 : SECT=WORK(1) 747 : C 748 : C ON CHERCHE LE COEFF DE LA MAT DE HOOKE 749 : C 750 : MPTVAL=IVAMAT 751 : 752 : DO 9108 IM=1,NMATT 753 : IF (IVAL(IM).NE.0) THEN 754 : MELVAL=IVAL(IM) 755 : IBMN=MIN(IB ,VELCHE(/2)) 756 : VALMAT(IM)=VELCHE(1,IBMN) 757 : ELSE 758 : VALMAT(IM)=0.D0 759 : ENDIF 760 : 9108 CONTINUE 761 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1) 761 : 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD) 762 : C 763 : C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE 764 : C 764 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 764 : CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE) 765 : IF(KERRE.NE.0) INTERR(1)=ISOUS 766 : IF(KERRE.NE.0) INTERR(2)=IB 766 : IF(KERRE.EQ.1) CALL ERREUR(128) 766 : CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE) 767 : C 768 : * SEGINI XMATRI 769 : * IMATTT(IB)=XMATRI 770 : C 771 : C REMPLISSAGE DE XMATRI 772 : C 772 : CALL REMPMT(REL,LRE,RE(1,1,IB)) 773 : * SEGDES XMATRI 774 : 3108 CONTINUE 775 : NSTRS=NSTRS1 776 : SEGDES XMATRI 777 : SEGSUP WRK1,WRK2,WRK3,MVELCH 778 : GOTO 510 779 : 780 : C 781 : *_______________________________________________________________________ 782 : * 783 : 99 CONTINUE 784 : MOTERR(1:4)=NOMTP(MELE) 785 : MOTERR(9:12)='AMOR' 785 : CALL ERREUR(86) 786 : * 787 : 510 CONTINUE 788 : RETURN 789 : END 790 : 791 : 792 : 793 : 794 : 795 : 796 : 797 : 798 : 799 : 800 : 801 : 802 : 803 : 804 : 805 : 806 : 807 : 808 : 809 : 810 : 811 : 812 : 813 : 814 : 815 : 816 : 817 : 818 : 819 :
© Cast3M 2003 - All rights reserved.
Disclaimer