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