1 : C GYRO2 SOURCE FANDEUR 11/07/19 21:16:09 7042 2 : 3 : SUBROUTINE GYRO2 (IPMODL,IPCHE1, IPRIG) 4 : * 5 : *_______________________________________________________________________ 6 : * 7 : * appelé par GYROS 8 : * 9 : * Creation d'une matrice de couplage gyroscopique 10 : * dans le repère inertiel ou fixe (éléments POUTR, TIMO, TUYAU) 11 : * 12 : * entrees : 13 : * ======== 14 : * ipmodl pointeur sur un mmodel 15 : * ipche1 pointeur sur un mchaml de caracteristiques 16 : * 17 : * sorties : 18 : * ========= 19 : * iprig pointeur sur la matrice d'amortissement construite 20 : * =0 sinon en cas d'erreur (et IERR non nul) 21 : * 22 : *_______________________________________________________________________ 23 : 24 : IMPLICIT INTEGER(I-N) 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : 27 : -INC CCOPTIO 28 : -INC CCHAMP 29 : -INC CCGEOME 30 : -INC CCREEL 31 : 32 : -INC SMRIGID 33 : -INC SMCHAML 34 : -INC SMELEME 35 : -INC SMCOORD 36 : -INC SMINTE 37 : -INC SMMODEL 38 : 39 : INTEGER oooval 40 : 41 : SEGMENT NOTYPE 42 : CHARACTER*16 TYPE(NBTYPE) 43 : ENDSEGMENT 44 : 45 : SEGMENT MPTVAL 46 : INTEGER IPOS(NS),NSOF(NS) 47 : INTEGER IVAL(NCOSOU) 48 : CHARACTER*16 TYVAL(NCOSOU) 49 : ENDSEGMENT 50 : 51 : CHARACTER*8 CMATE 52 : CHARACTER*(NCONCH) CONM 53 : 54 : PARAMETER ( INTYP = 4 ) 55 : 56 : PARAMETER (NINF=3) 57 : INTEGER INFOS(NINF) 58 : LOGICAL lsupde,lsupfo 59 : 60 : IPRIG = 0 61 : C 62 : C ACTIVATION DU MODELE 63 : C 64 : MMODEL = IPMODL 65 : SEGACT,MMODEL 66 : NSOUS=KMODEL(/1) 67 : C 68 : C CREATION DE L'OBJET MATRICE DE COUPLAGE GYROSCOPIQUE 69 : C 70 : NRIGEL = 0 71 : SEGINI,MRIGID 72 : MTYMAT = 'RIGIDITE' 73 : IFORIG = IFOMOD 74 : * IFORIG = IFOUR 75 : ICHOLE = 0 76 : IMGEO1 = 0 77 : IMGEO2 = 0 78 : ISUPEQ = 0 79 : C 80 : C_______________________________________________________________________ 81 : C 82 : C DEBUT DE LA BOUCLE SUR LES DIFFERENT MODELES ELEMENTAIRES 83 : C_______________________________________________________________________ 84 : C 85 : DO 500 ISOUS=1,NSOUS 86 : C 87 : IMODEL = KMODEL(ISOUS) 88 : SEGACT,IMODEL 89 : 90 : C- Initialisations 91 : IPMINT = 0 92 : 93 : MOMATR = 0 94 : MOCARA = 0 95 : MOTYPM = 0 96 : MOTYPC = 0 97 : ISUPM = 0 98 : ISUPC = 0 99 : 100 : MODEPL = 0 101 : MOFORC = 0 102 : lsupde = .false. 103 : lsupfo = .false. 104 : 105 : IDESCR = 0 106 : 107 : C- Recuperation d'informations sur le maillage elementaire 108 : IIPDPG = IPDPGE 109 : IPT1 = IMAMOD 110 : SEGACT,IPT1 111 : NBNOE1 = IPT1.NUM(/1) 112 : NBELE1 = IPT1.NUM(/2) 113 : 114 : C- Quelques informations sur le modele 115 : CONM = CONMOD 116 : CMATE = CMATEE 117 : MATE = IMATEE 118 : c* INAT = INATUU 119 : C- Creation du tableau INFOS 120 : iret = 1 120 : CALL IDENT(IPT1,CONM,IPCHE1,0,INFOS,iret) 121 : IF (iret.EQ.0) GOTO 599 122 : 123 : C- Recuperation d'informations sur l'element fini 124 : MELE = NEFMOD 125 : C 126 : NPINT = 1 127 : IF (INFMOD(/1).NE.0) NPINT = INFMOD(1) 128 : C-- Support des champs 129 : IPLAZ = 4 130 : IF (NPINT.EQ.12345) IPLAZ = 1 131 : 132 : MFR = INFELE(13) 133 : LRE = INFELE(9) 134 : LW = INFELE(7) 135 : LHOOK = INFELE(10) 136 : NDDL = INFELE(15) 137 : c* IELE = INFELE(14) 138 : c* ICARA = INFELE(5) 139 : IPMINT = INFMOD(2+IPLAZ) 140 : c* IPMINT = INFELE(11) 141 : IPMIN1 = INFMOD(8) 142 : IPPORE = 0 143 : IF (MFR.EQ.33) IPPORE = NBNOE1 144 : C 145 : C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX 146 : if (lnomid(1).ne.0) then 147 : MODEPL =lnomid(1) 148 : else 149 : lsupde = .true. 149 : CALL IDDEPL(MFR,IFOUR,MODEPL,NDEPL,ndum) 150 : endif 151 : nomid = MODEPL 152 : SEGACT,nomid 153 : NDEPL = lesobl(/2) 154 : c* ndum = lesfac(/2) 155 : 156 : IF (lnomid(2).ne.0) then 157 : MOFORC = lnomid(2) 158 : ELSE 159 : lsupfo = .true. 159 : CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NDUM) 160 : ENDIF 161 : nomid = MOFORC 162 : SEGACT,nomid 163 : NFORC = lesobl(/2) 164 : c* ndum=lesfac(/2) 165 : C 166 : IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN 166 : CALL ERREUR(5) 167 : GOTO 598 168 : ENDIF 169 : C 170 : C- REMPLISSAGE DU SEGMENT DESCRIPTEUR 171 : NLIGRP = LRE 172 : NLIGRD = LRE 173 : SEGINI,DESCR 174 : 175 : NCOMP = NDEPL 176 : NBNNS = NBNOE1 177 : IF (MFR.EQ.33) NCOMP = NDEPL-1 178 : IF (IFOUR.EQ.-3) THEN 179 : NCOMP = NDEPL-3 180 : ENDIF 181 : c* ? IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS = NBNOE1/2 182 : IDDL = 1 183 : DO 1004 INOEUD=1,NBNNS 184 : DO 1005 ICOMP=1,NCOMP 185 : NOMID=MODEPL 186 : LISINC(IDDL)=LESOBL(ICOMP) 187 : NOMID=MOFORC 188 : LISDUA(IDDL)=LESOBL(ICOMP) 189 : NOELEP(IDDL)=INOEUD 190 : NOELED(IDDL)=INOEUD 191 : IDDL=IDDL+1 192 : 1005 CONTINUE 193 : 1004 CONTINUE 194 : * 195 : SEGDES,DESCR 196 : IDESCR = DESCR 197 : 198 : C- Recuperation des noms de composantes MATERIAU 199 : nbrobl = 0 200 : nbrfac = 0 201 : nomid = 0 202 : notype = 0 203 : LHOTRA = 0 204 : C 205 : C rho dans les cas poutre,tuyau 206 : IF (MFR.EQ.7.OR.MFR.EQ.13) THEN 207 : IF (CMATE.NE.'SECTION') THEN 208 : nbrobl = 1 209 : SEGINI,nomid 210 : lesobl(1)='RHO ' 211 : nbtype = 1 212 : SEGINI,notype 213 : type(1) = 'REAL*8' 214 : ELSE 215 : LHOTRA = LHOOK 216 : nbrobl=2 217 : SEGINI,nomid 218 : lesobl(1)='MODS' 219 : lesobl(2)='MATS' 220 : nbtype = 2 221 : SEGINI,notype 222 : type(1) = 'POINTEURMMODEL' 223 : type(2) = 'POINTEURMCHAML' 224 : ENDIF 225 : ENDIF 226 : MOMATR = nomid 227 : MOTYPM = notype 228 : NMATR = nbrobl 229 : NMATF = nbrfac 230 : NMATT = NMATR+NMATF 231 : C-- Verification du support des composantes recherchees 232 : IF (MOMATR.NE.0) THEN 232 : CALL QUESUQ(IMODEL,IPCHE1,INTYP,0,MOMATR,IPLAZ,ISUPM,iret) 233 : IF (ISUPM.GT.1) GOTO 597 234 : ENDIF 235 : 236 : C- Recuperation des noms de composantes CARACTERISTIQUES 237 : nbrobl = 0 238 : nbrfac = 0 239 : nomid = 0 240 : notype = 0 241 : IVECT = 0 242 : * caracteristiques pour les poutres 243 : IF (MFR.EQ.7 ) THEN 244 : IF (CMATE.EQ.'SECTION') THEN 245 : nbrfac = 2 246 : SEGINI,nomid 247 : lesfac(1) = 'OMEG' 248 : lesfac(2) = 'VECT' 249 : IVECT = 1 250 : * 251 : nbtype = 2 252 : SEGINI,notype 253 : type(1) = 'REAL*8' 254 : type(2) = 'POINTEURPOINT ' 255 : ELSE 256 : nbrobl = 4 257 : nbrfac = 4 258 : SEGINI,nomid 259 : lesobl(1) = 'TORS' 260 : lesobl(2) = 'INRY' 261 : lesobl(3) = 'INRZ' 262 : lesobl(4) = 'SECT' 263 : lesfac(1) = 'SECY' 264 : lesfac(2) = 'SECZ' 265 : lesfac(3) = 'OMEG' 266 : lesfac(4) = 'VECT' 267 : IVECT = 1 268 : * 269 : nbtype = 8 270 : SEGINI,notype 271 : type(1) = 'REAL*8' 272 : type(2) = 'REAL*8' 273 : type(3) = 'REAL*8' 274 : type(4) = 'REAL*8' 275 : type(5) = 'REAL*8' 276 : type(6) = 'REAL*8' 277 : type(7) = 'REAL*8' 278 : type(8) = 'POINTEURPOINT ' 279 : ENDIF 280 : * caracteristiques pour les tuyaux 281 : ELSE IF (MFR.EQ.13) THEN 282 : nbrobl = 2 283 : nbrfac = 3 284 : SEGINI,nomid 285 : lesobl(1) = 'EPAI' 286 : lesobl(2) = 'RAYO' 287 : lesfac(1) = 'RACO' 288 : lesfac(2) = 'OMEG' 289 : lesfac(3) = 'VECT' 290 : IVECT = 1 291 : * 292 : nbtype = 5 293 : SEGINI,notype 294 : type(1) = 'REAL*8' 295 : type(2) = 'REAL*8' 296 : type(3) = 'REAL*8' 297 : type(4) = 'REAL*8' 298 : type(5) = 'POINTEURPOINT ' 299 : ENDIF 300 : 301 : MOCARA = nomid 302 : MOTYPC = notype 303 : NCARA = nbrobl 304 : NCARF = nbrfac 305 : NCARR = NCARA+NCARF 306 : 307 : C--- Verification du support des composantes recherchées 308 : IF (MOCARA.NE.0) THEN 308 : CALL QUESUQ(IMODEL,IPCHE1,INTYP,0,MOCARA,IPLAZ,ISUPC,iret) 309 : IF (ISUPC.GT.1) GOTO 597 310 : ENDIF 311 : C 312 : C- Activation du segment MINTE 313 : MINTE = IPMINT 314 : SEGACT,MINTE 315 : NBPGAU = POIGAU(/1) 316 : C 317 : C- Partionnement si necessaire de la matrice d'amortissement 318 : C- determinant ainsi le nombre d'objets elementaires de MRIGID 319 : LTRK = oooval(1,4) 320 : IF (LTRK.EQ.0) LTRK = oooval(1,1) 321 : * Ajout a la taille en mots de la matrice des infos du segment 322 : LSEG = LRE*LRE*NBELE1 + 16 323 : NBLPRT = (LSEG-1)/LTRK + 1 324 : NBLMAX = (NBELE1-1)/NBLPRT + 1 325 : nblprt = (NBELE1-1)/NBLMAX + 1 326 : c* write(ioimp,*) ' gyro2 : nblprt nblmax = ',nblprt,nblmax,nbele1 327 : 328 : C-- Ajout de la matrice de couplage GYROSCOPIQUE a la matrice globale 329 : NRIGE0 = IRIGEL(/2) 330 : NRIGEL = NRIGE0 + nblprt 331 : SEGADJ,MRIGID 332 : 333 : descr = IDESCR 334 : meleme = IPT1 335 : nbnn = NBNOE1 336 : nbelem = NBELE1 337 : nbsous = 0 338 : nbref = 0 339 : 340 : * Boucle sur les PARTITIONS elementaires de la matrice 341 : *------------------------------------------------------ 342 : DO 5000 irige = 1, nblprt 343 : 344 : IF (nblprt.GT.1) THEN 345 : C-- Partitionnement du maillage support de la matrice elementaire 346 : C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !) 347 : SEGACT,IPT1 348 : ielem = (irige-1)*NBLMAX 349 : nbelem = MIN(NBLMAX,NBELE1-ielem) 350 : * write(ioimp,*) ' creation segment ',nbnn,nbelem 351 : SEGINI,meleme 352 : itypel = IPT1.itypel 353 : DO ielt = 1, nbelem 354 : jelt = ielt + ielem 355 : DO inoe = 1, nbnn 356 : num(inoe,ielt) = IPT1.NUM(inoe,jelt) 357 : ENDDO 358 : icolor(ielt) = IPT1.ICOLOR(jelt) 359 : ENDDO 360 : C-- Recopie du descripteur 361 : des1 = IDESCR 362 : SEGINI,descr=des1 363 : SEGDES,descr 364 : ENDIF 365 : C* Voir le cas IFOUR.EQ.-3 366 : ipmail = meleme 367 : ipdesc = descr 368 : ipt2 = meleme 369 : 370 : C-- Initialisation de la matrice de rigidite elementaire (xmatri) 371 : NELRIG = nbelem 372 : SEGINI,xmatri 373 : ipmatr = xmatri 374 : 375 : C-- Recuperation des valeurs des proprietes materiau et geometriques 376 : ivamat = 0 377 : ivacar = 0 378 : IF (MOMATR.NE.0) THEN 378 : CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1, 379 : & INFOS,NINF,ivamat) 380 : IF (IERR.NE.0) GOTO 5099 381 : IF (ISUPM.EQ.1) THEN 381 : CALL VALCHE(ivamat,NMATT,IPMINT,IPPORE) 382 : IF (IERR.NE.0) THEN 383 : ISUPM = 0 384 : GOTO 5099 385 : ENDIF 386 : ENDIF 387 : ENDIF 388 : IF (MOCARA.NE.0) THEN 388 : CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1, 389 : & INFOS,NINF,ivacar) 390 : IF (IERR.NE.0) GOTO 5099 391 : IF (ISUPC.EQ.1) THEN 391 : CALL VALCHE(ivacar,NCARR,IPMINT,IPPORE) 392 : IF (IERR.NE.0) THEN 393 : ISUPC = 0 394 : GOTO 5099 395 : ENDIF 396 : ENDIF 397 : ENDIF 398 : 399 : C_______________________________________________________________________ 400 : C 401 : C NUMERO DES ETIQUETTES : 402 : C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT 403 : C LES ELEMENTS SONT GROUPES COMME SUIT : 404 : C_______________________________________________________________________ 405 : * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9 406 : GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 407 : * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT 408 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 409 : * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6 410 : & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99 411 : * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2 412 : & , 99, 99, 99, 99, 99, 99, 99, 99, 21, 99, 99 413 : * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO 414 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 415 : * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15 416 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 417 : * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 418 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 419 : * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 420 : & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99 421 : * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 422 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 423 : * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8 424 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 425 : * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13 426 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 427 : * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8 428 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 429 : * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3 430 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 431 : * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126 432 : & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99 433 : * TE56 PY91 TRH6 434 : & , 99, 99, 99),MELE 435 : C 436 : 99 CONTINUE 437 : MOTERR(1:4)=NOMTP(MELE) 438 : MOTERR(5:12)='GYROS' 438 : CALL ERREUR(86) 439 : GOTO 5099 440 : C_______________________________________________________________________ 441 : C 442 : C POUTRE, POUTRE DE TIMOSCHENKO 443 : C_______________________________________________________________________ 444 : C 445 : 21 CONTINUE 445 : CALL GYRO3(ipmail,LRE,LW,MELE,ivamat,NMATT,ivacar,NCARR, 446 : & IVECT,ISOUS,NBPGAU,IPMINT,IPMIN1,NDDL,MATE, 447 : & CMATE,LHOTRA,ipmatr,IIPDPG) 448 : GOTO 5100 449 : C_______________________________________________________________________ 450 : C 451 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA 452 : C_______________________________________________________________________ 453 : 5100 CONTINUE 454 : 5099 CONTINUE 455 : c* xmatri = ipmatr 456 : SEGDES,xmatri 457 : IF (nblprt.GT.1) THEN 458 : c* meleme = ipmail 459 : SEGDES,meleme 460 : ENDIF 461 : IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN 461 : CALL DTMVAL(ivamat,3) 462 : ELSE 462 : CALL DTMVAL(ivamat,1) 463 : ENDIF 464 : IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN 464 : CALL DTMVAL(ivacar,3) 465 : ELSE 465 : CALL DTMVAL(ivacar,1) 466 : ENDIF 467 : 468 : C- Sortie prematuree en cas d'erreur 469 : IF (IERR.NE.0) GOTO 596 470 : 471 : C- Stockage de la matrice 472 : jrige = NRIGE0 + irige 473 : COERIG(jrige) = 1. 474 : IRIGEL(1,jrige) = ipt2 475 : IRIGEL(2,jrige) = 0 476 : IRIGEL(3,jrige) = ipdesc 477 : IRIGEL(4,jrige) = ipmatr 478 : IRIGEL(5,jrige) = NIFOUR 479 : IRIGEL(6,jrige) = 0 480 : C-- Matrice antisymetrique 481 : IRIGEL(7,jrige) = 1 482 : IRIGEL(8,jrige) = 0 483 : 484 : 5000 CONTINUE 485 : C- Fin de la boucle sur les partitions 486 : 487 : 596 CONTINUE 488 : c* MINTE = IPMINT 489 : SEGDES,MINTE 490 : 597 CONTINUE 491 : IF (MOMATR.NE.0) THEN 492 : nomid = MOMATR 493 : SEGSUP,nomid 494 : notype = MOTYPM 495 : SEGSUP,notype 496 : ENDIF 497 : IF (MOCARA.NE.0) THEN 498 : nomid = MOCARA 499 : SEGSUP,nomid 500 : notype = MOTYPC 501 : SEGSUP,notype 502 : ENDIF 503 : 598 CONTINUE 504 : NOMID = MODEPL 505 : SEGDES,NOMID 506 : IF (lsupde) SEGSUP,NOMID 507 : NOMID = MOFORC 508 : SEGDES,NOMID 509 : IF (lsupfo) SEGSUP,NOMID 510 : 599 CONTINUE 511 : SEGDES,IPT1 512 : SEGDES,IMODEL 513 : 514 : C- Sortie prematuree en cas d'erreur 515 : IF (IERR.NE.0) GOTO 999 516 : 517 : 500 CONTINUE 518 : C- Fin de la boucle sur les modeles elementaires 519 : 520 : 999 CONTINUE 521 : IF (IERR.NE.0) THEN 522 : SEGSUP,MRIGID 523 : IPRIG = 0 524 : ELSE 525 : SEGDES,MRIGID 526 : IPRIG = MRIGID 527 : ENDIF 528 : SEGDES,MMODEL 529 : 530 : RETURN 531 : END 532 : 533 :
© Cast3M 2003 - All rights reserved.
Disclaimer