1 : C CORIO2 SOURCE FANDEUR 11/07/19 21:15:49 7042 2 : SUBROUTINE CORIO2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR, 3 : &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE, 4 : &LHOOK,IPMATR,VROT,NUMLIS,IIPDPG) 5 : *---------------------------------------------------------------------* 6 : * _________________________________________________ * 7 : * | | * 8 : * | calcul de la matrice de couplage gyroscopique | * 9 : * | dans le repère tournant | * 10 : * |________________________________________________| * 11 : * * 12 : * barr,poutre,timo,tuyau * 13 : * coq3,dkt,coq4,coq8,dst * 14 : *---------------------------------------------------------------------* 15 : * * 16 : * entrees : * 17 : * ________ * 18 : * * 19 : * ipmail pointeur sur un segment meleme * 20 : * lre nombre de ddl dans la matrice de masse * 21 : * lw dimension du tableau de travail de l'element * 22 : * mele numero de l'element fini * 23 : * ivamat pointeur sur un segment mptval pour le materiau * 24 : * nmatt nombre de composante de materiau (imat=1) * 25 : * ivacar pointeur sur un segment mptval pour les caracteri- * 26 : * stiques * 27 : * ncarr nombre de caracteristiques geometriques * 28 : * ivect flag indiquant si on a entree les axes locaux * 29 : * isous numero de la sous-zone * 30 : * nbpgau nombre de point d'integration pour la masse * 31 : * ipmint pointeur sur un segment minte * 32 : * ipmin1 pointeur sur un segment minte (aux noeuds) * 33 : * nddl nombre de degre de liberte /noeud * 34 : * mate numero du materiau * 35 : * cmate nom du materiau * 36 : * vrot vecteur vitesse de rotation * 37 : * * 38 : * sorties : * 39 : * ________ * 40 : * * 41 : * ipmatr pointeur sur la matrice d'amortissement * 42 : * de la sous-zone * 43 : * * 44 : * Didier COMBESCURE mars 2003 * 45 : *---------------------------------------------------------------------* 46 : IMPLICIT INTEGER(I-N) 47 : IMPLICIT REAL*8(A-H,O-Z) 48 : -INC CCOPTIO 49 : -INC CCHAMP 50 : -INC CCREEL 51 : *- 52 : -INC SMRIGID 53 : -INC SMCHAML 54 : -INC SMELEME 55 : -INC SMCOORD 56 : -INC SMINTE 57 : -INC SMMODEL 58 : C 59 : SEGMENT WRK1 60 : REAL*8 REL(LRE,LRE),XE(3,NBBB) 61 : ENDSEGMENT 62 : C 63 : SEGMENT WRK2 64 : REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE) 65 : ENDSEGMENT 66 : C 67 : SEGMENT WRK3 68 : REAL*8 DDHOOK(LHOOK,LHOOK) 69 : REAL*8 WORK(LW) 70 : ENDSEGMENT 71 : C 72 : SEGMENT WRK4 73 : REAL*8 BPSS(3,3),XEL(3,NBBB) 74 : ENDSEGMENT 75 : C 76 : SEGMENT WRK6 77 : REAL*8 RHOMAT(6,6) 78 : ENDSEGMENT 79 : 80 : SEGMENT WRK7 81 : REAL*8 XJI(3,3),TXR(3,3,NBNO),FINT(3,LRE),XJ(3,3),B(3,3) 82 : REAL*8 TH(NBNO),EXC(NBNO),H(NBNO) 83 : REAL*8 ROME(3,3),REWO(LRE,LRE) 84 : ENDSEGMENT 85 : C 86 : SEGMENT MVELCH 87 : REAL*8 VALMAT(NV1) 88 : ENDSEGMENT 89 : C 90 : SEGMENT MPTVAL 91 : INTEGER IPOS(NS),NSOF(NS) 92 : INTEGER IVAL(NCOSOU) 93 : CHARACTER*16 TYVAL(NCOSOU) 94 : ENDSEGMENT 95 : * 96 : DIMENSION VROT(*) 97 : 98 : DIMENSION CRIGI(12),CMASS(12),VROTL(3) 99 : CHARACTER*8 CMATE 100 : * 101 : MELEME=IPMAIL 102 : c* SEGACT,IPMAIL 103 : NBNN=NUM(/1) 104 : NBELEM=NUM(/2) 105 : * 106 : NV1=NMATT 107 : SEGINI,MVELCH 108 : * 109 : xMATRI=IPMATR 110 : c* SEGACT,xMATRI*MOD 111 : c* NLIGRP=LRE 112 : c* NLIGRD=LRE 113 : * 114 : NHRM=NIFOUR 115 : * 116 : MINTE =IPMINT 117 : c* SEGACT,MINTE 118 : c 119 : C_______________________________________________________________________ 120 : C 121 : C NUMERO DES ETIQUETTES : 122 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 123 : C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR : 124 : C 5 CONTINUE 125 : C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ... 126 : C 44 CONTINUE 127 : C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ... 128 : C_______________________________________________________________________ 129 : C 130 : * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 131 : GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 132 : * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT 133 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 134 : * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 135 : & , 99, 99, 99, 99, 93, 93, 21, 99, 99, 99, 99 136 : * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 137 : & , 99, 99, 99, 99, 99, 99, 99, 41, 21, 99, 44 138 : * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO 139 : & , 99, 21, 99, 99, 51, 99, 99, 99, 99, 99, 99 140 : * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 141 : & , 41, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 142 : * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 143 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 144 : * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 145 : & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99 146 : * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 147 : & , 99, 99, 99, 99, 93, 99, 99, 99, 99, 99, 99 148 : * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 149 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 150 : * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 151 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 152 : * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 153 : & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99 154 : * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 155 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 156 : * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 157 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 158 : * TE56 PY91 TRH6 159 : & , 99, 99, 99),MELE 160 : C 161 : C_______________________________________________________________________ 162 : C 163 : C ELEMENTS POUTRES 164 : C_______________________________________________________________________ 165 : C 166 : 21 CONTINUE 167 : C 168 : C CAS DES POUTRES - TUYAUX 169 : C 170 : NBBB=NBNN 171 : SEGINI WRK1,WRK3 172 : * 173 : * cas du materiau section 174 : * 175 : NBGMAT = 0 176 : NELMAT = 0 177 : IF(CMATE.EQ.'SECTION') THEN 178 : MPTVAL=IVAMAT 179 : DO IM=1,NMATT 180 : IF(IVAL(IM).NE.0)THEN 181 : MELVAL=IVAL(IM) 182 : NBGMAT=MAX(NBGMAT,IELCHE(/1)) 183 : NELMAT=MAX(NELMAT,IELCHE(/2)) 184 : END IF 185 : END DO 186 : ENDIF 187 : C 188 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 189 : C 190 : DO 2027 IB=1,NBELEM 191 : C 192 : C ON CHERCHE LES COORDONNEES DE L ELEMENT IB 193 : C 193 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 194 : C 195 : C CAS DES POUTRES 196 : C -------------- 197 : C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK 198 : C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE 199 : C 200 : NCARR1=NCARR 201 : IF(IVECT.EQ.1) NCARR1=NCARR-1 202 : 203 : MPTVAL=IVACAR 204 : 205 : DO 2429 IC=1,NCARR1 206 : WORK(IC)=0.D0 207 : IF (IVAL(IC).NE.0) THEN 208 : MELVAL=IVAL(IC) 209 : IBMN=MIN(IB,VELCHE(/2)) 210 : DO 2029 IGAU=1,NBNN 211 : IGMN=MIN(IGAU,VELCHE(/1)) 212 : WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN) 213 : 2029 CONTINUE 214 : WORK(IC)=WORK(IC)/NBNN 215 : ENDIF 216 : 2429 CONTINUE 217 : C 218 : C CAS OU ON A LU LE MOT VECTEUR 219 : C 220 : IF (IVECT.EQ.1) THEN 221 : IF (IVAL(NCARR).NE.0) THEN 222 : MELVAL=IVAL(NCARR) 223 : IBMN=MIN(IB,IELCHE(/2)) 224 : IP=IELCHE(1,IBMN) 225 : IREF=(IP-1)*(IDIM+1) 226 : DO 2129 IC=1,IDIM 227 : WORK(NCARR1+IC)=XCOOR(IREF+IC) 228 : 2129 CONTINUE 229 : ELSE 230 : DO 2229 IC=1,IDIM 231 : WORK(NCARR1+IC)=0. 232 : 2229 CONTINUE 233 : ENDIF 234 : ENDIF 235 : C 236 : MPTVAL=IVAMAT 237 : C 238 : C CAS DES POUTRES ET TUYAU 239 : C 240 : MELVAL=IVAL(1) 241 : IF(CMATE.NE.'SECTION') THEN 242 : IBMN=MIN(IB,VELCHE(/2)) 243 : C 244 : IF(MELE.EQ.46) THEN 245 : WORK(2)=VELCHE(1,IBMN) 246 : ELSE 247 : WORK(11)=VELCHE(1,IBMN) 248 : ENDIF 249 : C 250 : C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE 251 : C -------------- EQUIVALENTE 252 : C 252 : IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1) 253 : ELSE 254 : * 255 : * cas formulation section 256 : * 257 : IBMN=MIN(IB,IELCHE(/2)) 258 : IPMODL=IELCHE(1,IBMN) 259 : MELVAL=IVAL(2) 260 : IBMN=MIN(IB,IELCHE(/2)) 261 : IPMAT=IELCHE(1,IBMN) 262 : IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN 262 : CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS) 262 : CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD) 263 : ENDIF 264 : ENDIF 265 : C 266 : C ON CALCULE LA MATRICE DE COUPLAGE GYROSCOPIQUE 267 : C 268 : IF (MELE.EQ.46) THEN 268 : CALL BARCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) 269 : ELSEIF (MELE.EQ.84) THEN 270 : IF(CMATE.NE.'SECTION') THEN 270 : CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) 271 : ELSE 271 : CALL TIFCOR(REL,LRE,WORK,XE,VROT,WORK(12),LHOOK, 272 : & DDHOOK,KERRE) 273 : ENDIF 274 : ELSE 274 : CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE) 275 : ENDIF 276 : C 277 : IF (KERRE.NE.0) THEN 278 : INTERR(1)=ISOUS 279 : INTERR(2)=IB 279 : CALL ERREUR(128) 280 : GOTO 9027 281 : ENDIF 282 : 283 : DO 2128 IIIA=1,LRE 284 : DO 2128 IIIB=1,LRE 285 : RE(IIIA,IIIB,ib)=REL(IIIA,IIIB) 286 : 2128 CONTINUE 287 : * 288 : 2027 CONTINUE 289 : 290 : 9027 CONTINUE 291 : SEGSUP,WRK1,WRK3 292 : GOTO 510 293 : 294 : C_______________________________________________________________________ 295 : C 296 : C SECTEUR DE CALCUL POUR LES ELEMENTS DST, DKT ET COQ3 297 : C ADAPTE DE LA MATRICE DE MASSE DES ELEMENTS DST 298 : C CAR PROBLEME AVEC DKT ET COQ3 299 : C_______________________________________________________________________ 300 : C 301 : 93 CONTINUE 302 : NBNO=NBNN 303 : NBBB=NBNN 304 : SEGINI WRK1,WRK2,WRK4,WRK6 305 : C 306 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 307 : C 308 : DO 9300 IB=1,NBELEM 309 : C 310 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 311 : C 311 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 311 : CALL ZERO (REL,LRE,LRE) 311 : CALL VPAST(XE,BPSS) 311 : CALL VCORLC(XE,XEL,BPSS) 312 : C 313 : MPTVAL=IVACAR 314 : C 315 : C ACQUISITION DES EPAISSEURS 316 : C 317 : EP=0.D0 318 : MELVAL=IVAL(1) 319 : IF (MELVAL.NE.0) THEN 320 : DO IGAU=1,NBPGAU 321 : IGMN=MIN(IGAU,VELCHE(/1)) 322 : IBMN=MIN(IB ,VELCHE(/2)) 323 : EP=EP+VELCHE(IGMN,IBMN) 324 : ENDDO 325 : EP=EP/NBPGAU 326 : ENDIF 327 : C 328 : EXCEN=0.D0 329 : MELVAL=IVAL(2) 330 : IF (MELVAL.NE.0) THEN 331 : DO IGAU=1,NBPGAU 332 : IGMN=MIN(IGAU,VELCHE(/1)) 333 : IBMN=MIN(IB ,VELCHE(/2)) 334 : EXCEN=EXCEN+VELCHE(IGMN,IBMN) 335 : ENDDO 336 : EXCEN=EXCEN/NBPGAU 337 : ENDIF 338 : C 339 : C BOULE SUR LES POINTS DE GAUSS 340 : C 341 : DO 9310 IGAU=1,NBPGAU 342 : C 343 : MPTVAL=IVAMAT 344 : MELVAL=IVAL(1) 345 : IBMN=MIN(IB,VELCHE(/2)) 346 : IGMN=MIN(IGAU,VELCHE(/1)) 347 : RHO=VELCHE(IGMN,IBMN) 348 : C 348 : CALL ZERO(RHOMAT,6,6) 349 : C 350 : VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2) 351 : . +BPSS(1,3)*VROT(3) 352 : VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2) 353 : . +BPSS(2,3)*VROT(3) 354 : VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2) 355 : . +BPSS(3,3)*VROT(3) 356 : C 357 : RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3) 358 : RHOMAT( 1, 3)=RHO*EP*VROTL(2) 359 : RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2) 360 : RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1) 361 : RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3) 362 : RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3) 363 : C 364 : RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3) 365 : RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3) 366 : RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1) 367 : RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2) 368 : C 369 : RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4) 370 : RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5) 371 : RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4) 372 : RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5) 373 : C 373 : CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC) 374 : DJAC=DJAC*POIGAU(IGAU) 374 : CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL) 375 : 9310 CONTINUE 376 : C 377 : ICOM = 0 378 : IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4) ICOM=1 378 : CALL TRANSG(REL,BPSS,18,3,ICOM) 379 : C 380 : C REMPLISSAGE 381 : C 382 : DO 9311 I2=1,LRE 383 : DO 9311 I1=1,LRE 384 : RE(I1,I2,ib) = REL(I1,I2) 385 : 9311 CONTINUE 386 : C 387 : 9300 CONTINUE 388 : SEGSUP WRK1,WRK2,WRK4,WRK6 389 : GOTO 510 390 : C_______________________________________________________________________ 391 : C 392 : C ELEMENT COQ6 COQ8 393 : C_______________________________________________________________________ 394 : C 395 : 41 CONTINUE 396 : NBBB=NBNN 397 : NBNO = NBNN 398 : SEGINI WRK1,WRK7 399 : 400 : c Debut du remplissage WRK7 401 : ROME(1,1) = 0.D0 402 : ROME(1,2) = (-1.)*VROT(3) 403 : ROME(1,3) = VROT(2) 404 : ROME(2,1) = VROT(3) 405 : ROME(2,2) = 0.D0 406 : ROME(2,3) = (-1.)*VROT(1) 407 : ROME(3,1) = (-1.)*VROT(2) 408 : ROME(3,2) = VROT(1) 409 : ROME(3,3) = 0.D0 410 : 411 : MINTE2=IPMIN2 412 : SEGACT,MINTE2 413 : C 414 : DO 4041 IB=1,NBELEM 414 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 415 : 416 : MPTVAL=IVAMAT 417 : MELVAL=IVAL(1) 418 : IBMN=MIN(IB,VELCHE(/2)) 419 : VALMAT(1)=VELCHE(1,IBMN) 420 : RHO = VALMAT(1) 421 : C 422 : C CALCUL DE L'EPAISSEUR ET DE L'EXCENTREMENT (MOYENS) 423 : C 424 : MPTVAL=IVACAR 425 : MELVAL=IVAL(1) 426 : IBMN=MIN(IB,VELCHE(/2)) 427 : C 428 : EPAI = 0.D0 429 : IF (IVAL(1).NE.0) THEN 430 : MELVAL=IVAL(1) 431 : IBMN=MIN(IB ,VELCHE(/2)) 432 : DO IGAU=1,NBPGAU 433 : IGMN=MIN(IGAU,VELCHE(/1)) 434 : EPAI = EPAI + VELCHE(IGMN,IBMN) 435 : ENDDO 436 : EPAI = EPAI / NBPGAU 437 : ENDIF 438 : EXENT = 0.D0 439 : IF (IVAL(2).NE.0) THEN 440 : MELVAL=IVAL(2) 441 : IBMN=MIN(IB ,VELCHE(/2)) 442 : DO IGAU=1,NBPGAU 443 : IGMN=MIN(IGAU,VELCHE(/1)) 444 : EXENT = EXENT + VELCHE(IGMN,IBMN) 445 : ENDDO 446 : EXENT = EXENT / NBPGAU 447 : ENDIF 448 : C 449 : DO igau = 1, NBNO 450 : TH(igau) = EPAI 451 : EXC(igau) = EXENT 452 : ENDDO 453 : C 453 : CALL COQ8GY(NBNN,RHO,NBPGAU,WRK1,MINTE,MINTE2,WRK7) 454 : C 455 : DO 4128 IIIB=1,LRE 456 : DO 4128 IIIA=1,LRE 457 : RE(IIIA,IIIB,ib)=REL(IIIA,IIIB) 458 : 4128 CONTINUE 459 : 460 : 4041 CONTINUE 461 : 462 : SEGSUP,WRK1,WRK7 463 : SEGDES,MINTE2 464 : 465 : GOTO 510 466 : C_______________________________________________________________________ 467 : C 468 : C SECTEUR DE CALCUL POUR LES COQ2 469 : C_______________________________________________________________________ 470 : C+DC: d apres la matrice de massse 471 : 44 CONTINUE 472 : NBNO=NBNN 473 : NBBB=NBNN 474 : SEGINI WRK1 475 : 476 : XDPGE = 0.D0 477 : YDPGE = 0.D0 478 : C 479 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 480 : C 481 : DO 3044 IB=1,NBELEM 482 : C 483 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 484 : C 484 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 484 : CALL ZERO (REL,LRE,LRE) 485 : C 486 : MPTVAL=IVACAR 487 : MELVAL=IVAL(1) 488 : IBMN=MIN(IB,VELCHE(/2)) 489 : EP=VELCHE(1,IBMN) 490 : C 491 : MPTVAL=IVAMAT 492 : DO 4044 IM=1,NMATT 493 : MELVAL=IVAL(IM) 494 : IBMN=MIN(IB,VELCHE(/2)) 495 : VALMAT(IM)=VELCHE(1,IBMN) 496 : 4044 CONTINUE 497 : RHO=VALMAT(1) 498 : C 499 : C APPEL A LA SUBROUTINE CALCULANT LA MATRICE DE CORIOLIS 500 : C 501 : IF (NUMLIS.EQ.1) THEN 502 : C Cas d'une matrice utilsé en calcul harmonique (symétrique) 502 : CALL COQ2CH(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, 503 : + XDPGE,YDPGE,VROT) 504 : ELSE 505 : C Cas de la matrice utilisé en temporel (antisymétrique) 505 : CALL COQ2CO(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR, 506 : + XDPGE,YDPGE,VROT) 507 : ENDIF 508 : C 509 : C GESTION D'ERREUR 510 : C 511 : IF(IARR.NE.0) THEN 512 : INTERR(1)=IB 512 : IF(IARR.EQ.1) CALL ERREUR(195) 512 : IF(IARR.EQ.2) CALL ERREUR(259) 513 : GOTO 9044 514 : ENDIF 515 : C 516 : C REMPLISSAGE 517 : C 518 : DO 3043 I2=1,LRE 519 : DO 3043 I1=1,LRE 520 : RE(I1,I2,ib) = REL(I1,I2) 521 : 3043 CONTINUE 522 : C 523 : 3044 CONTINUE 524 : C 525 : 9044 CONTINUE 526 : SEGSUP,WRK1 527 : GOTO 510 528 : 529 : C_______________________________________________________________________ 530 : C 531 : C SECTEUR DE CALCUL POUR LES COQ4 532 : C_______________________________________________________________________ 533 : C 534 : 51 CONTINUE 535 : NBNO=NBNN 536 : NBBB=NBNN 537 : SEGINI WRK1,WRK2,WRK4,WRK6 538 : C 539 : C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS 540 : C 541 : DO 5149 IB=1,NBELEM 542 : c 543 : C 544 : C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB 545 : C 545 : CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE) 545 : CALL ZERO (REL,LRE,LRE) 546 : C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé 546 : CALL CQ4LOC(XE,XEL,BPSS,IERT,0) 547 : C 548 : MPTVAL=IVACAR 549 : MELVAL=IVAL(1) 550 : IBMN=MIN(IB,VELCHE(/2)) 551 : EP=VELCHE(1,IBMN) 552 : IF (IVAL(2).NE.0) THEN 553 : MELVAL=IVAL(2) 554 : IBMN=MIN(IB,VELCHE(/2)) 555 : EXCEN =VELCHE(1,IBMN) 556 : ELSE 557 : EXCEN=0.D0 558 : ENDIF 559 : C 560 : MPTVAL=IVAMAT 561 : MELVAL=IVAL(1) 562 : IBMN=MIN(IB,VELCHE(/2)) 563 : VALMAT(1)=VELCHE(1,IBMN) 564 : RHO=VALMAT(1) 565 : C 565 : CALL ZERO(RHOMAT,6,6) 566 : C 567 : VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2) 568 : . +BPSS(1,3)*VROT(3) 569 : VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2) 570 : . +BPSS(2,3)*VROT(3) 571 : VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2) 572 : . +BPSS(3,3)*VROT(3) 573 : C 574 : RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3) 575 : RHOMAT( 1, 3)=RHO*EP*VROTL(2) 576 : RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2) 577 : RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1) 578 : RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3) 579 : RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3) 580 : C 581 : RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3) 582 : RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3) 583 : RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1) 584 : RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2) 585 : C 586 : RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4) 587 : RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5) 588 : RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4) 589 : RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5) 590 : C 591 : NBPGAM=NBPGAU-1 592 : DO 5049 IGAU=1,NBPGAM 592 : CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT) 593 : C IERT=1 JACOBIANO=<0 594 : IF (IERT.EQ.1) THEN 595 : INTERR(1)=IB 595 : CALL ERREUR(321) 596 : GOTO 9051 597 : ENDIF 598 : C 599 : DJAC=DJAC*POIGAU(IGAU) 599 : CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL) 600 : 5049 CONTINUE 601 : C 602 : C PASSAGE EN COORDONNéES GLOBALES 603 : C 603 : CALL TRANSG(REL,BPSS,24,4,0) 604 : C 605 : C REMPLISSAGE ET ON BOULEVERSE LA MATRICE DE COUPLAGE 606 : C 607 : DO 5050 I1=1,LRE 608 : DO 5050 I2=1,LRE 609 : RE(I1,I2,ib) = REL(I1,I2) 610 : 5050 CONTINUE 611 : 612 : 5149 CONTINUE 613 : C 614 : 9051 CONTINUE 615 : SEGSUP WRK1,WRK2,WRK4,WRK6 616 : GOTO 510 617 : C_______________________________________________________________________ 618 : C 619 : 99 CONTINUE 620 : MOTERR(1:4)=NOMTP(MELE) 621 : MOTERR(5:12)='CORI' 621 : CALL ERREUR(86) 622 : * 623 : 510 CONTINUE 624 : SEGSUP,MVELCH 625 : 626 : RETURN 627 : END 628 : 629 :
© Cast3M 2003 - All rights reserved.
Disclaimer