1 : C COMALO SOURCE FANDEUR 13/01/16 21:15:06 7665 2 : SUBROUTINE COMALO(ipmode,itruli,ipmel) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : *-------------------------------------------------------- 6 : * CF DEVALO.ESO et DEVTRA.ESO 7 : * indexe infos deformees modales , deplacements 8 : *-------------------------------------------------------- 9 : -INC SMCOORD 10 : -INC DECHE 11 : -INC CCOPTIO 12 : -INC CCGEOME 13 : -INC SMCHAML 14 : -INC SMELEME 15 : -INC SMMODEL 16 : -INC SMLENTI 17 : -INC CCREEL 18 : * 19 : segment wrktvu 20 : integer jtvu(lilmel(/1)) 21 : endsegment 22 : segment mwinit 23 : integer jpdep,jpvit,jrepr 24 : endsegment 25 : * 26 : * Segment des variables g�n�ralis�es: 27 : * 28 : SEGMENT,MTQ 29 : REAL*8 Q1(NA1,4),Q2(NA1,4),Q3(NA1,4) 30 : REAL*8 WEXT(NA1,2),WINT(NA1,2) 31 : ENDSEGMENT 32 : SEGMENT,MTKAM 33 : REAL*8 XK(NA1),XASM(NA1),XM(NA1) 34 : ENDSEGMENT 35 : 36 : * Segment pour Champoints 37 : SEGMENT,MSAM 38 : integer jplibb(NPLB) 39 : ENDSEGMENT 40 : * 41 : *** segment sous-structures dynamiques 42 : segment struli 43 : integer itlia,itbmod,momoda, mostat,itmail,molia 44 : integer ldefo(np1),lcgra(np1),lsstru(np1) 45 : integer nsstru,nndefo,nliab,nsb,na2,idimb 46 : integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas 47 : INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib 48 : * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0) 49 : INTEGER ICHAIN 50 : endsegment 51 : 52 : SEGMENT MOLIAI 53 : integer modtla,modtlb 54 : ENDSEGMENT 55 : * 56 : * Segment de travail pour reprise force POLYNOMIALE base A 57 : * 58 : SEGMENT,MTRA 59 : INTEGER IPLA(NTRA) 60 : ENDSEGMENT 61 : 62 : SEGMENT,ICPR(XCOOR(/1)/(IDIM+1)) 63 : SEGMENT,MCPR(XCOOR(/1)/(IDIM+1)) 64 : SEGMENT,MPREF 65 : INTEGER IPOREF(NPREF) 66 : ENDSEGMENT 67 : segment icma(0) 68 : segment icnna2(0) 69 : PARAMETER (MDEPL=20) 70 : LOGICAL REPRIS,LMODYN,RIGIDE,ilogmo,ilogst,ilogre,L0,LVA1,LVAR 71 : CHARACTER*4 LISDEP(MDEPL),LISVIT(MDEPL),TESDEP 72 : CHARACTER*6 MO2 73 : CHARACTER*8 CMOT,TYPRET,MORIGI,CHARRE 74 : CHARACTER*10 MO1 75 : CHARACTER*40 MONMOT 76 : DATA LISDEP/ 'UX ','UY ','UZ ','UR ','UT ','RX ','RY ', 77 : &'RZ ','RT ','ALFA','BETA','IUX ','IUY ','IUZ ','IUR ','IUT ', 78 : &'IRX ','IRY ','IRZ ','IRT '/ 79 : DATA LISVIT/ 'VTX ','VTY ','VTZ ','VTR ','VTT ','VWX ','VWY ', 80 : &'VWZ ','VWT ','VALF','VBET','IVTX','IVTY','IVTZ','IVTR','IVTT', 81 : &'IVWX','IVWY','IVWZ','IVWT'/ 82 : * 83 : * si IFOMOD = -1 : mod?le PLAN 84 : * si IFOMOD = 0 : mod?le AXIS 85 : * si IFOMOD = 1 : mod?le FOUR 86 : * si IFOMOD = 2 : mod?le TRID 87 : * 88 : * 89 : ITREP = 0 90 : MTQ = 0 91 : MTKAM = 0 92 : MTPHI = 0 93 : MTLIAA = 0 94 : MTLIAB = 0 95 : MTFEX = 0 96 : MTPAS = 0 97 : MTRES = 0 98 : MTNUM = 0 99 : MTRA = 0 100 : XTINI = 0.D0 101 : ITLA = 0 102 : ITLB = 0 103 : REPRIS = .FALSE. 104 : 105 : lilmel = ipmel 106 : struli = itruli 107 : jliaib = 0 108 : nmost = 0 109 : nmost0 = 0 110 : kovaen = 0 111 : kovare = 0 112 : * identifie materiau MODAL ou STATIQUE 113 : 114 : itmod = ipmode 115 : * 115 : call ecrcha('MODAL') 115 : call ecrcha('MATE') 115 : call ecrobj('MMODEL',ITMOD) 115 : call exis 115 : call lirlog(ilogmo,0,iret) 116 : IF (ilogmo) THEN 116 : call ecrcha('MECANIQUE') 116 : call ecrcha('FORM') 116 : call ecrobj('MMODEL',ITMOD) 116 : call extrai 116 : call lirobj('MMODEL',momod1,0,iret) 116 : call ecrcha('MODAL') 116 : call ecrcha('MATE') 116 : call ecrobj('MMODEL',momod1) 116 : call extrai 116 : call lirobj('MMODEL',ipmodz,0,iret) 117 : momoda = ipmodz 118 : mmode1 = ipmodz 119 : segact mmode1 120 : nmost0 = mmode1.kmodel(/1) 121 : nmost = nmost + nmost0 122 : ENDIF 122 : call ecrcha('STATIQUE') 122 : call ecrcha('MATE') 122 : call ecrobj('MMODEL',ITMOD) 122 : call exis 122 : call lirlog(ilogst,0,iret) 123 : IF (ilogst) THEN 123 : call ecrcha('MECANIQUE') 123 : call ecrcha('FORM') 123 : call ecrobj('MMODEL',ITMOD) 123 : call extrai 123 : call lirobj('MMODEL',momod1,0,iret) 123 : call ecrcha('STATIQUE') 123 : call ecrcha('MATE') 123 : call ecrobj('MMODEL',momod1) 123 : call extrai 123 : call lirobj('MMODEL',ipmodz,0,iret) 124 : mostat = ipmodz 125 : mmode1 = ipmodz 126 : segact mmode1 127 : nmost = nmost + mmode1.kmodel(/1) 128 : ENDIF 129 : na1 = nmost 130 : mmode2 = itlia 131 : segact mmode2 132 : nliat = mmode2.kmodel(/1) 133 : mmode1 = ipmode 134 : segact mmode1 135 : ilogre = (mmode1.kmodel(/1) - na1 - nliat).gt.0 136 : 137 : n1 = nmost 138 : segini mmodel 139 : mmode1 = momoda 140 : do im = 1,nmost0 141 : kmodel(im) = mmode1.kmodel(im) 142 : enddo 143 : IF (ilogst) THEN 144 : mmode1 = mostat 145 : do im = 1,mmode1.kmodel(/1) 146 : kmodel(nmost0 + im) = mmode1.kmodel(im) 147 : enddo 148 : ENDIF 149 : itbmod = mmodel 150 : np1 = nmost 151 : segadj struli 152 : * 153 : * collecte deplacements, vitesses, deformation , centre gravite 154 : segini wrktvu 155 : iptvu = wrktvu 156 : do 2010 mvu = 1,lilmel(/1) 157 : deche = lilmel(mvu) 158 : if(ilogmo) then 159 : if (nomdec.eq.'ALFA'.and.indec.eq.1) then 160 : jtvu(mvu) = 101 161 : goto 2010 162 : endif 163 : if (nomdec.eq.'ALFA'.and.indec.gt.1) then 164 : jtvu(mvu) = 102 165 : goto 2010 166 : endif 167 : if (nomdec.eq.'FALF'.and.indec.gt.1) then 168 : jtvu(mvu) = 105 169 : goto 2010 170 : endif 171 : if (nomdec.eq.'VALF'.and.indec.eq.1) then 172 : jtvu(mvu) = 106 173 : goto 2010 174 : endif 175 : if (nomdec.eq.'VALF'.and.indec.gt.1) then 176 : jtvu(mvu) = 107 177 : goto 2010 178 : endif 179 : endif 180 : if(ilogst) then 181 : if (nomdec.eq.'BETA'.and.indec.eq.1) then 182 : jtvu(mvu) = 201 183 : goto 2010 184 : endif 185 : if (nomdec.eq.'BETA'.and.indec.gt.1) then 186 : jtvu(mvu) = 202 187 : goto 2010 188 : endif 189 : if (nomdec.eq.'FBET'.and.indec.gt.1) then 190 : jtvu(mvu) = 205 191 : goto 2010 192 : endif 193 : if (nomdec.eq.'VBET'.and.indec.eq.1) then 194 : jtvu(mvu) = 206 195 : goto 2010 196 : endif 197 : if (nomdec.eq.'VBET'.and.indec.gt.1) then 198 : jtvu(mvu) = 207 199 : goto 2010 200 : endif 201 : endif 202 : if(ilogmo.or.ilogst) then 203 : if (nomdec.eq.'DEFO'.and.indec.gt.1) then 204 : jtvu(mvu)= 302 205 : goto 2010 206 : endif 207 : if (nomdec.eq.'AMOR'.and.indec.gt.1) then 208 : jtvu(mvu)= 305 209 : goto 2010 210 : endif 211 : endif 212 : if(ilogmo) then 213 : if (nomdec.eq.'CGRA'.and.indec.gt.1) then 214 : jtvu(mvu)= 303 215 : goto 2010 216 : endif 217 : if (nomdec.eq.'FREQ'.and.indec.gt.1) then 218 : jtvu(mvu)= 304 219 : goto 2010 220 : endif 221 : if (nomdec.eq.'MASS'.and.indec.gt.1) then 222 : jtvu(mvu)= 305 223 : goto 2010 224 : endif 225 : endif 226 : if (ilogre) then 227 : do mdep = 1,MDEPL 228 : if (nomdec.eq.lisdep(mdep)) then 229 : jtvu(mvu)= mdep 230 : goto 2010 231 : endif 232 : if (nomdec.eq.lisvit(mdep)) then 233 : jtvu(mvu)= mdep * (-1) 234 : goto 2010 235 : endif 236 : enddo 237 : endif 238 : 239 : if (nomdec.eq.'SORT') then 240 : jtvu(mvu) = 501 241 : goto 2010 242 : endif 243 : 244 : if (nomdec.eq.'VAEN') then 245 : jtvu(mvu) = 506 246 : kovaen = kovaen + 1 247 : goto 2010 248 : endif 249 : 250 : if (nomdec.eq.'VARE') then 251 : jtvu(mvu) = 507 252 : kovare = kovare + 1 253 : goto 2010 254 : endif 255 : 256 : 257 : jtvu(mvu) = -100 258 : 259 : 2010 continue 260 : 261 : IK = 0 262 : SEGINI,ICPR 263 : LCPR = XCOOR(/1)/(IDIM+1) 264 : 265 : MMODEL = itbmod 266 : segact MMODEL 267 : do 60 im = 1,kmodel(/1) 268 : imodel = kmodel(im) 269 : segact imodel*nomod 270 : meleme = imamod 271 : segact meleme 272 : * a priori 1 seul point 273 : do ip = 1,num(/2) 274 : knoe = num(1,ip) 275 : IF (KNOE.NE.0) THEN 276 : IF (ICPR(KNOE).EQ.0) THEN 277 : IK = IK + 1 278 : ICPR(KNOE) = IK 279 : IF (IIMPI.EQ.333) THEN 280 : WRITE(IOIMP,*)'COMALO : basemo. ICPR(',KNOE,')=',ICPR(KNOE) 281 : ENDIF 282 : ENDIF 283 : ENDIF 284 : enddo 285 : 60 continue 286 : * 287 : 288 : * 289 : * 5/ Cr{ation du segment d{finissant les points supports: 290 : * 291 : NPREF = IK 292 : SEGINI,MPREF 293 : KPREF = MPREF 294 : ikpref = KPREF 295 : DO 100 I=1,LCPR 296 : IF (ICPR(I).NE.0) THEN 297 : IREF = ICPR(I) 298 : IPOREF(IREF) = I 299 : IF (IIMPI.EQ.333) THEN 300 : WRITE(IOIMP,*)'COMALO : IPOREF(',IREF,')=',IPOREF(IREF) 301 : ENDIF 302 : ENDIF 303 : 100 CONTINUE 304 : 305 : * 306 : * creation et remplissage MTQ (revoir indices dans DYNE 1=actuel 2=avant) 307 : * 308 : NA1 = nmost 309 : segini MTQ,MTKAM 310 : ktq = MTQ 311 : ktkam = MTKAM 312 : do ia1 = 1,na1 313 : xk(ia1) = 1.d0 314 : enddo 315 : mmodel = itbmod 316 : 317 : do 3010 mvu = 1,lilmel(/1) 318 : if (jtvu(mvu).ne.101.and.jtvu(mvu).ne.102.and. 319 : &jtvu(mvu).ne.106.and.jtvu(mvu).ne.107.and. 320 : &jtvu(mvu).ne.201.and.jtvu(mvu).ne.202.and. 321 : &jtvu(mvu).ne.206.and.jtvu(mvu).ne.207.and. 322 : &jtvu(mvu).ne.105.and.jtvu(mvu).ne.205.and. 323 : &jtvu(mvu).ne.304.and.jtvu(mvu).ne.305) goto 3010 324 : deche = lilmel(mvu) 325 : melval = ieldec 326 : segact melval 327 : 328 : do 3050 im = 1,kmodel(/1) 329 : imodel = kmodel(im) 330 : if (imadec.ne.imamod.or.condec.ne.conmod) goto 3050 331 : meleme = imamod 332 : IA = ICPR(num(1,1)) 333 : * en gros ordre du MMODEL 334 : if (nomdec.eq.'ALFA'.or.nomdec.eq.'BETA') then 335 : if (indec.eq.1) Q1(ia,2) = velche(1,1) 336 : if (indec.gt.1) Q1(ia,1) = velche(1,1) 337 : q1(ia,3) = q1(ia,2) 338 : endif 339 : if (nomdec.eq.'VALF'.or.nomdec.eq.'VBET') then 340 : if (indec.eq.1) Q2(ia,2) = velche(1,1) 341 : if (indec.gt.1) Q2(ia,1) = velche(1,1) 342 : q2(ia,3) = q2(ia,2) 343 : endif 344 : if (nomdec.eq.'FALF'.or.nomdec.eq.'FBET') then 345 : if (indec.gt.1) then 346 : Q3(ia,2) = velche(1,1) 347 : endif 348 : endif 349 : if (nomdec.eq.'FREQ') then 350 : OMEGA = velche(1,1) * 2.d0* xpi 351 : xk(ia) = xk(ia) * omega * omega 352 : endif 353 : if (nomdec.eq.'MASS') then 354 : xm(ia) = velche(1,1) 355 : xk(ia) = velche(1,1) * xk(ia) 356 : endif 357 : if (nomdec.eq.'AMOR') then 358 : xasm(ia) = velche(1,1) 359 : endif 360 : goto 3009 361 : 3050 continue 362 : 3009 segdes melval 363 : 364 : 3010 continue 365 : segsup icpr 366 : 367 : 5001 continue 368 : 369 : * (kich : traitement sur base modale-stat pour l instant) 370 : * 371 : ipmodz = itbmod 371 : call ecrcha('MAIL') 371 : call ecrobj('MMODEL',ipmodz) 371 : call extrai 371 : call lirobj('MAILLAGE',ipt1,0,iret) 372 : itmail = ipt1 373 : if (ierr.ne.0) return 374 : if (iret.ne.1) then 375 : write(6,*) 'pb developpement comalo' 376 : ierr = 2 377 : return 378 : endif 379 : segact ipt1 380 : segini mcpr 381 : do ie = 1,ipt1.num(/2) 382 : mcpr(ipt1.num(1,ie)) = 1 383 : enddo 384 : 385 : mmodel = itlia 386 : segact mmodel 387 : n1 = kmodel(/1) 388 : segini mmode1,mmode2 389 : klia = 0 390 : klib = 0 391 : do ik = 1,kmodel(/1) 392 : imodel = kmodel(ik) 393 : * liaisons issues de DYNE 394 : segact imodel 395 : meleme = imamod 396 : if (imatee.lt.23) then 397 : segact meleme 398 : 399 : if (mcpr(num(1,1)).gt.0) then 400 : klia = klia + 1 401 : mmode1.kmodel(klia) = imodel 402 : else 403 : klib = klib + 1 404 : mmode2.kmodel(klib) = imodel 405 : endif 406 : 407 : endif 408 : enddo 409 : nliady = klia+klib 410 : n1 = klia 411 : itla = mmode1 412 : segadj mmode1 413 : n1 = klib 414 : segadj mmode2 415 : itlb = mmode2 416 : segsup mcpr 417 : segini moliai 418 : modtla = itla 419 : if (klia.eq.0) modtla = 0 420 : modtlb = itlb 421 : if (klib.eq.0) modtlb = 0 422 : * distingue liaisons A et B 423 : IMOLIA = MOLIAI 424 : molia = moliai 425 : 426 : * recense variables internes de continuation, rustique ! 427 : if (kovare.eq.kovaen.and.kovare.eq.klia + klib) then 428 : segsup wrktvu 429 : return 430 : endif 431 : 432 : * 433 : * dimensionnement MTPHI : repere les deformees modales 434 : wrktvu =iptvu 435 : 436 : segini icma,icnna2 437 : MMODEL = itbmod 438 : segact MMODEL 439 : kstru = 0 440 : kdefo = 0 441 : do 50 im = 1,kmodel(/1) 442 : imodel = kmodel(im) 443 : segact imodel*nomod 444 : meleme = imamod 445 : segact meleme 446 : ** recherche sommaire nombre de sous-structures independantes (NSB) 447 : ** nombre maxi de modes pour une meme sous-structure (NA2) 448 : do 46 in = 1,jtvu(/1) 449 : if (jtvu(in).ne.302.and.jtvu(in).ne.303) goto 46 450 : deche = lilmel(in) 451 : if (condec(1:16).ne.conmod(1:16).or.imamod.ne.imadec) goto 46 452 : 453 : * assume point support reduit à 1 point 454 : if (nomdec(1:4).eq.'CGRA') then 455 : * recherche corps rigide 456 : if (IDIM.eq.2 .and. IDIMB.lt.3) IDIMB = 3 457 : if (IDIM.eq.3 .and. IDIMB.lt.6) IDIMB = 6 458 : melval = ieldec 459 : segact melval 460 : icdg = ielche(1,1) 461 : lcgra(im) = icdg 462 : segdes melval 463 : else if (nomdec(1:4).eq.'DEFO') then 464 : melval = ieldec 465 : segact melval 466 : * assume que le maillage modele se reduit au point support 467 : icdef1 = ielche(1,1) 468 : segdes melval 468 : call ecrcha('NOMU') 468 : call ecrcha('MAIL') 468 : call ecrobj('CHPOINT ',icdef1) 468 : call extrai 468 : call lirobj('MAILLAGE', icmaio,1,iret) 469 : if (ierr.ne.0) return 470 : if (kstru.eq.0) goto 44 471 : 472 : ipt5 = icmaio 473 : do ic = 1,kstru 474 : icmic = icma(ic) 474 : CALL INTERB(icmaio,icmic,IRETIB,icinte) 475 : if (iretib.eq.0) then 476 : ipt6 = icinte 477 : segact ipt6,ipt5 478 : if (ipt5.num(/2).eq.ipt6.num(/2)) then 479 : segsup ipt6 480 : icnna2(ic) = icnna2(ic) + 1 481 : lsstru(im) = ic 482 : goto 45 483 : endif 484 : segsup ipt6 485 : endif 486 : enddo 487 : 44 continue 488 : kstru = kstru + 1 489 : icma(**) = icmaio 490 : icnna2(**) = 1 491 : lsstru(im) = kstru 492 : 45 continue 493 : do ism = 1,im 494 : if (icdef1.ne.0.and.icdef1.eq.ldefo(ism)) then 495 : c write(6,*) 'deformee ',icdef1,'utilisee autre support', ism,im 495 : call erreur(26) 496 : return 497 : endif 498 : enddo 499 : ldefo(im) = icdef1 500 : kdefo = kdefo + 1 501 : goto 46 502 : endif 503 : 46 continue 504 : if (ldefo(im).eq.0) then 505 : c write(6,*) 'manque deformee modale pour support', imamod 505 : call erreur(26) 506 : return 507 : endif 508 : 509 : 47 continue 510 : 49 continue 511 : 50 continue 512 : NSB = icma(/1) 513 : NA2 = icnna2(1) 514 : do ic = 1,icnna2(/1) 515 : na2 = MAX(icnna2(ic),NA2) 516 : enddo 517 : nsstru = kstru 518 : nndefo = kdefo 519 : if (nndefo.ne.nmost) then 519 : call erreur(26) 520 : return 521 : endif 522 : if (nsstru.ne.nsb) then 522 : call erreur(26) 523 : return 524 : endif 525 : segsup icma,icnna2 526 : segsup wrktvu 527 : * 528 : RETURN 529 : END 530 : 531 :
© Cast3M 2003 - All rights reserved.
Disclaimer