1 : C COML2 SOURCE FANDEUR 12/07/18 21:15:18 7435 2 : 3 : SUBROUTINE COML2(IPMODL,IPMEL,INDESO,IRETOU) 4 : 5 : *--------------------------------------------------------------------- 6 : * coml2 : trie et boucle sur les modeles elementaires 7 : * selectionne les composantes de meme support 8 : * passe a coml6 9 : * complete les deche resultats 10 : *---------------------------------------------------------------- 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8(A-H,O-Z) 13 : 14 : -INC CCOPTIO 15 : -INC CCGEOME 16 : -INC CCHAMP 17 : -INC SMCHAML 18 : -INC SMELEME 19 : -INC SMCOORD 20 : -INC SMMODEL 21 : -INC SMINTE 22 : -INC SMLENTI 23 : * segment deroulant le mcheml 24 : -INC DECHE 25 : SEGMENT icorre 26 : integer mel2(nmel1),icor(nmel1),idej 27 : ENDSEGMENT 28 : SEGMENT INFO 29 : INTEGER INFELL(16) 30 : ENDSEGMENT 31 : segment igard(lilmel(/1)) 32 : segment izozo(nzo+1) 33 : segment ipozo(lilmel(/1)) 34 : segment ncop 35 : character*8 ncopi(ncopj) 36 : endsegment 37 : ** pile des deche contruits pour changer de support 38 : segment lichan(iichan) 39 : ** pile des deche pour construire le champ de caracteristiques geometriques 40 : segment licarb(iicarb) 41 : ** pile des noms de composantes a proteger 42 : segment linomp(iinomp) 43 : ** pile modeles elementaires 44 : segment limode(i100) 45 : ** segment sous-structures dynamiques 46 : segment struli 47 : integer itlia,itbmod,momoda, mostat,itmail,molia 48 : integer ldefo(np1),lcgra(np1),lsstru(np1) 49 : integer nsstru,nndefo,nliab,nsb,na2,idimb 50 : integer ktliab,ktphi,ktq,ktres,kpref,ktkam,kcpr,ktpas 51 : INTEGER NIPALB,NXPALB,NPLBB,NPLB,NIP,jliaib 52 : * ichain segment MLENTI initialise dans dyne12 (tjs actif si > 0) 53 : INTEGER ICHAIN 54 : endsegment 55 : c 56 : logical lome1,lome2,lsupca 57 : 58 : PARAMETER (MFORMC=1, MFORMU=17, MFORMT=MFORMC+MFORMU) 59 : CHARACTER*16 LISFOR(MFORMT) 60 : c Liste des formulations simples (cf. MODELI et NOMATE) 61 : DATA (LISFOR(i), i=1,MFORMU) 62 : & / 'THERMIQUE ','MECANIQUE ','LIQUIDE ', 63 : & 'CONVECTION ','POREUX ','DARCY ', 64 : & 'FROTTEMENT ','RAYONNEMENT ','MAGNETODYNAMIQUE', 65 : & 'NAVIER_STOKES ','MELANGE ','EULER ', 66 : & 'FISSURE ','LIAISON ','THERMOHYDRIQUE ', 67 : & 'ELECTROSTATIQUE ','DIFFUSION ' / 68 : c Liste des formulations "combinees" 69 : DATA (LISFOR(i), i=MFORMU+1,MFORMT) 70 : & / 'MECANIQUE+LIQUID' / 71 : 71 : * call gibtem (xkt) 72 : * write(ioimp,*) ' entree coml2 ', xkt 73 : c 74 : c active modele 75 : c 76 : mmodel = ipmodl 77 : segact mmodel*nomod 78 : NSOUS = kmodel(/1) 79 : c 80 : c moterr(1:6) = 'COML2 ' 81 : c moterr(7:15) = 'MMODEL ' 82 : c interr(1) = mmodel 82 : c call erreur(-329) 83 : c 84 : * On cree un nouveau mmodel en deroulant le modele d'entree : 85 : * Important en cas de modele melange ! 86 : i100=100 87 : segini limode 88 : c 89 : nlimod = 0 90 : nmomel = 0 91 : do im = 1, NSOUS 92 : imodel = kmodel(im) 93 : segact,imodel*nomod 94 : nlimod = nlimod+1 95 : if (nlimod.gt.i100) then 96 : i100=i100+100 97 : segadj limode 98 : endif 99 : limode(nlimod) = imodel 100 : if (formod(1).eq.'MELANGE') then 101 : nmomel = nmomel + 1 102 : if (matmod(1).ne.'SERIE') then 103 : if (ivamod(/1).ge.1) then 104 : do ivm1 = 1,ivamod(/1) 105 : if (tymode(ivm1).eq.'IMODEL') then 106 : imode1 = ivamod(ivm1) 107 : segact imode1 108 : nlimod = nlimod+1 109 : if (nlimod.gt.i100) then 110 : i100=i100+100 111 : segadj limode 112 : endif 113 : limode(nlimod) = imode1 114 : endif 115 : enddo 116 : endif 117 : endif 118 : endif 119 : enddo 120 : *pv segdes mmodel 121 : * Ajustement du segment limode (inutile) 122 : *of i100 = nlimod 123 : *of segadj limode 124 : if (nlimod.le.0) then 125 : write(ioimp,*) 'Erreur anormale : MMODEL vide !' 125 : call erreur(5) 126 : return 127 : endif 128 : * write(ioimp,*) ' nlimod ' ,nlimod 129 : * write(ioimp,*) ' limode ',(limode(i),i=1,nlimod) 130 : * Test de non redondance des sous-modeles 131 : N1 = 1 132 : DO 1161 it1 = nlimod, 2, -1 133 : imode1 = limode(it1) 134 : DO it2 = (it1 - 1), 1, -1 135 : imode2 = limode(it2) 136 : if (imode1.EQ.imode2) then 137 : limode(it1) = 0 138 : goto 1161 139 : else if (imode1.imamod.eq.imode2.imamod .and. 140 : & imode1.conmod.eq.imode2.conmod) then 141 : limode(it1) = 0 142 : *of segdes,imode1 143 : goto 1161 144 : endif 145 : ENDDO 146 : N1 = N1 + 1 147 : 1161 CONTINUE 148 : * Initialisation du modele de travail (ipmod7) 149 : * => Cas particulier de la formulation MELANGE : 150 : * On met les sous-modeles de formulation MELANGE a la fin du modele 151 : * de travail pour qu'ils soient traites en dernier car ils dependent 152 : * des resultats des autres sous-modeles ! 153 : SEGINI,mmodel 154 : it1 = 0 155 : it2 = N1 - nmomel 156 : do im = 1, nlimod 157 : imodel = limode(im) 158 : if (imodel.gt.0) then 159 : if (formod(1).NE.'MELANGE') then 160 : it1 = it1 + 1 161 : kmodel(it1) = imodel 162 : else 163 : it2 = it2 + 1 164 : kmodel(it2) = imodel 165 : endif 166 : endif 167 : enddo 168 : * if (it1.ne.(N1-nmomel) .and. it2.ne.N1) then 169 : * write(ioimp,*) 'Erreur anormale : traitement MELANGE !' 169 : * call erreur(5) 170 : * return 171 : * endif 172 : NSOUS = N1 173 : ipmod7 = mmodel 174 : 175 : * Cas particulier de la formulation LIAISON : 176 : itruli = 0 177 : struli = 0 178 : iplia = 0 179 : * Test sur la presence de la formulation LIAISON 180 : * On utilise limode pour stocker les modeles elementaires associes 181 : N1 = 0 182 : DO im = 1, NSOUS 183 : imodel = kmodel(im) 184 : if (formod(1).EQ.'LIAISON') then 185 : N1 = N1 + 1 186 : limode(N1) = imodel 187 : endif 188 : ENDDO 189 : * Definition du modele (iplia) associe a la seule formulation LIAISON 190 : if (N1.ne.0) then 191 : segini,mmode1 192 : DO im = 1, N1 193 : mmode1.kmodel(im) = limode(im) 194 : ENDDO 195 : iplia = mmode1 196 : * Initialisation du segment struli 197 : np1 = 0 198 : segini struli 199 : itruli = struli 200 : itlia = iplia 201 : * Remplissage avec les donnees dependant des sous-modeles MODAL / STATIQUE 201 : call comalo(ipmodl,itruli,ipmel) 202 : endif 203 : * 204 : * Destruction du segment limode (devenu inutile) 205 : segsup,limode 206 : * 207 : * Tri prealable sur les pointeurs de maillage 208 : * 209 : lilmel = ipmel 210 : iimel = lilmel(/1) 211 : * write(ioimp,*) 'iou imadec, nomdec condec indec' 212 : deche = lilmel(1) 213 : ijmin = imadec 214 : ijmax = imadec 215 : * write(ioimp,*) 1,imadec,' ',nomdec ,' ', condec,' ',indec 216 : do im = 2, iimel 217 : deche = lilmel(im) 218 : ijmin = min(ijmin,imadec) 219 : ijmax = max(ijmax,imadec) 220 : * write(ioimp,*) im,imadec,' ',nomdec ,' ', condec,' ',indec 221 : enddo 222 : * write(ioimp,*) 'lilmel(/1) ijmin ,ijmax ',iimel,ijmin,ijmax 223 : ijdif = ijmax-ijmin+1 224 : izo = max(1,ijdif/(nsous*40)) 225 : * if (izo.gt.11) izo=izo/3 226 : nzo = ijdif / izo + 1 227 : * write(ioimp,*) ' nzo izo ijmax ijmin ',nzo,izo,ijmax,ijmin 228 : segini izozo 229 : do im = 1, iimel 230 : deche = lilmel(im) 231 : ivamad = imadec-ijmin 232 : izu = ivamad/izo + 1 233 : izozo(izu)=izozo(izu) + 1 234 : enddo 235 : ia = izozo(1) 236 : do im = 2 , nzo+1 237 : ia = ia + izozo(im) 238 : izozo(im) = ia 239 : enddo 240 : segini ipozo 241 : do im = 1, iimel 242 : deche = lilmel(im) 243 : ivamad=imadec-ijmin 244 : izu=ivamad/izo+1 245 : ipa=izozo(izu) 246 : ipozo(ipa)=im 247 : izozo(izu)=ipa-1 248 : enddo 249 : * write(ioimp,*) 'izozo' ,izozo(1),izozo(2),izozo(3),izozo(4) 250 : * write(ioimp,*) 'ipozo ',(ipozo(izu),izu=1,20) 251 : c 252 : mmodel = ipmod7 253 : segact,mmodel 254 : NSOUS = kmodel(/1) 255 : 256 : * On va creer d'office un modele contenant seulement le sous-modele 257 : * elementaire (isous) au cours de la boucle (1000) utile en cas de 258 : * projection et ou de changement de support ! 259 : * Attention : Il faut reactiver le sous-modele apres utilisation 260 : * pour la bonne suite du traitement du comportement. 261 : N1 = 1 262 : SEGINI,mmode1 263 : IPMOD1 = mmode1 264 : * 265 : * Idem on cree un mchaml a une sous-zone et une composante qui sera a 266 : * mettre a jour a chaque fois que besoin par le deche en cours 267 : N1 = 1 268 : L1 = 1 269 : N3 = 6 270 : SEGINI,mchelm 271 : titche = ' ' 272 : conche(1) = ' ' 273 : c* ifoche = 0 274 : c* imache(1) = 0 275 : c* DO i = 1, N3 276 : c* infche(1,i) = 0 277 : c* ENDDO 278 : n2 = 1 279 : SEGINI,mchaml 280 : ichaml(1) = mchaml 281 : nomche(1) = ' ' 282 : typche(1) = ' ' 283 : c* ielval(1) = 0 284 : IPOI1 = mchelm 285 : c 286 : c Boucle (1000) sur les modeles elementaires 287 : c -------------------------------------------- 288 : c 289 : DO 1000 isous = 1, NSOUS 290 : * 291 : imodel = kmodel(isous) 292 : segact imodel*nomod 293 : iqmod = imodel 294 : 295 : mmode1 = IPMOD1 296 : SEGACT,mmode1*MOD 297 : mmode1.kmodel(1) = iqmod 298 : C* SEGDES,mmode1 299 : * 300 : * write(ioimp,*) 'coml2 modele elementaire numero ',im 301 : * write(6,*) 'coml2 formulation ',formod(1),' cons ',conmod 302 : * moterr(1:6) = 'COML2 ' 303 : * moterr(7:15) = 'IMODEL ' 304 : * interr(1) = im 304 : * call erreur(-329) 305 : c 306 : c Determination de la formulation du modele : 307 : c 308 : nformu = FORMOD(/2) 309 : iform1 = 0 309 : CALL PLACE(LISFOR,MFORMU,iform1,FORMOD(1)) 310 : lformu = iform1 311 : IF (nformu.EQ.2) THEN 312 : iform2 = 0 312 : CALL PLACE(LISFOR,MFORMU,iform2,FORMOD(2)) 313 : lformu = 0 314 : IF ( (iform1.eq.2 .and. iform2.eq.3) .or. 315 : & (iform1.eq.3 .and. iform2.eq.2) ) lformu = 18 316 : ENDIF 317 : if (lformu.eq.0) then 318 : write(ioimp,*) 'COML2 : formulation non prevue ici' 319 : goto 1000 320 : endif 321 : 322 : MELE1 =NEFMOD 323 : MELEME=IMAMOD 324 : c 325 : c Indicateur de support 326 : cof : a stocker dans un segment de travail pour la suite ? 327 : c Par defaut, on initialise le support : lesupp = 5 328 : lesupp = 5 329 : * Formulation MECANIQUE+LIQUIDE 330 : * if (lformu.eq.18) lesupp = 5 331 : * Formulation THERMIQUE then 332 : if (lformu.eq.1) then 333 : lesupp = 6 334 : * Formulation MECANIQUE ou POREUX ou DIFFUSION ou ELECTROSTATIQUE 335 : * else if (lformu.eq. 2 .OR. lformu.EQ. 5 .OR. lformu.EQ.16 .OR. 336 : * lformu.eq.17) then 337 : * lesupp = 5 338 : else if (lformu.eq.11) then 339 : if (ivamod(/1).gt.0) then 340 : lesupp = 5 341 : else 342 : lesupp = 3 343 : endif 344 : else if (lformu.EQ.14) then 345 : lesupp = 1 346 : endif 347 : c 348 : c cas particulier de la formulation LIAISON 349 : jtruli = 0 350 : if (lformu.EQ.14) jtruli = itruli 351 : c____________________________________________________________________ 352 : c 353 : c information sur l'element fini 354 : c____________________________________________________________________ 355 : info = 0 356 : ipinf = 0 357 : if (infmod(/1).lt.2+lesupp) then 357 : CALL ELQUOI(MELE1,0,lesupp,IPINF,IMODEL) 358 : IF (IERR.NE.0) THEN 359 : SEGDES IMODEL*NOMOD,MMODEL*NOMOD 360 : RETURN 361 : ENDIF 362 : INFO = IPINF 363 : mfr2 = infell(13) 364 : else 365 : mfr2 = infele(13) 366 : endif 367 : * 368 : iinomp=lilmel(/1) 369 : ijnomp=0 370 : segini,linomp,igard 371 : ivamad=imamod-ijmin 372 : izu=ivamad/izo + 1 373 : * write(ioimp,*) ' ijmin izo izu ',ijmin,izo,izu 374 : if (izu.le.nzo+1.and.izu.gt.0) then 375 : ideb=izozo(izu) + 1 376 : ifin=izozo(izu+1) 377 : else 378 : ideb=1 379 : ifin=0 380 : write(ioimp,*) ' coml2 en dehors du zonage ' 381 : endif 382 : do iopo=ideb,ifin 383 : idn=ipozo(iopo) 384 : * do idn = 1,lilmel(/1) 385 : deche = lilmel(idn) 386 : ***** segact deche 387 : if (imamod.eq.imadec.and.conmod.eq.condec) then 388 : ijnomp=ijnomp+1 389 : igard(idn)=1 390 : linomp(ijnomp) = deche 391 : endif 392 : enddo 393 : * write(ioimp,*) ' ijnomp ' , ijnomp 394 : ncopj=ijnomp 395 : segini ncop 396 : * inop=1 397 : * deche=linomp(1) 398 : * ncopi(1)=nomdec 399 : do 648 idn=1,ijnomp 400 : deche=linomp(idn) 401 : * do iyu=1,inop 402 : * if(nomdec.eq.ncopi(iyu)) go to 648 403 : * enddo 404 : ncopi(idn)=nomdec 405 : 648 continue 406 : * write(ioimp,*) ' premier passage ijnomp ',ijnomp,ideb,ifin 407 : * 408 : * on met maintenant tous les champs qui sont sur le bon imamod 409 : * et qui n ont pas le bon constituant 410 : ncopjj=ncopj 411 : do 650 iopo=ideb,ifin 412 : idn=ipozo(iopo) 413 : if(igard(idn).eq.1) go to 650 414 : deche=lilmel(idn) 415 : if(imadec.ne.imamod) go to 650 416 : do iou=1,ncopjj 417 : if(ncopi(iou).eq.nomdec) go to 650 418 : enddo 419 : * write(6,*) ' composante ajoutée ' , nomdec 420 : ncopj=ncopJ+1 421 : segadj ncop 422 : ijnomp=ijnomp+1 423 : linomp(ijnomp)=deche 424 : igard(idn)=1 425 : ncopi(ncopj)=nomdec 426 : 650 continue 427 : * write(6,*) ' apres deuxielme passage ijnomp ' ,ijnomp 428 : iinomp=ijnomp 429 : segadj linomp 430 : * write(6,*) 'linomp ', linomp(/1) 431 : * do iou=1,linomp(/1) 432 : * deche=linomp(iou) 433 : * write(6,*)'condec nomdec indec ',condec,' ', nomdec,' ',indec 434 : * enddo 435 : * on met à -1 les deche que l'on peut sauter 436 : do 649 idn=1,lilmel(/1) 437 : deche= lilmel(idn) 438 : if(igard(idn).eq.1) go to 649 439 : do iyu=1,iinomp 440 : if( nomdec.eq.ncopi(iyu)) then 441 : igard(idn)=-1 442 : go to 649 443 : endif 444 : enddo 445 : 649 continue 446 : 447 : * write(6,*) ' ijnomp ',ijnomp 448 : 449 : c composantes des caracteristiques geometriques 450 : if(lnomid(7).ne.0) then 451 : lsupca=.false. 452 : mocomp=lnomid(7) 453 : nomid = mocomp 454 : segact nomid 455 : nobl=lesobl(/2) 456 : nfac=lesfac(/2) 457 : else 458 : lsupca=.true. 458 : CALL IDCARB(MELE1,IFOUR,MOCOMP,NOBL,NFAC) 459 : nomid = mocomp 460 : segact nomid 461 : endif 462 : ncarb = nobl + nfac 463 : * cherche les deche correspondants aux caracteristiques geometriques a t1 et t2 464 : ipcarb1 = 0 465 : ipcarb2 = 0 466 : * write(6,*) ' linomp(/1) nobl,nfac',linomp(/1),ncarb,nobl,nfac 467 : if (ncarb.gt.0) then 468 : iicarb=linomp(/1) 469 : segini licarb 470 : do minde = 1,2 471 : ijcarb=0 472 : n3=0 473 : do le = 1,linomp(/1) 474 : deche = linomp(le) 475 : ***** segact deche 476 : * write(ioimp,*)' le deche nomdec nindec',le,deche,nomdec,indec 477 : if (indec.eq.minde) then 478 : do jd = 1,nobl 479 : if (nomdec.eq.lesobl(jd)) then 480 : ijcarb=ijcarb+1 481 : licarb(ijcarb) = deche 482 : n3 = max (n3,infdec(/1)) 483 : endif 484 : enddo 485 : do jd = 1,nfac 486 : if (nomdec.eq.lesfac(jd)) then 487 : ijcarb=ijcarb+1 488 : licarb(ijcarb) = deche 489 : n3 = max (n3,infdec(/1)) 490 : endif 491 : enddo 492 : endif 493 : ***** segdes deche 494 : enddo 495 : 496 : if (ijcarb.gt.0) then 497 : c cree un mchelm de caracteristiques 498 : * write(6,*) ' ijcarb ', ijcarb 499 : n1=ijcarb 500 : l1 = 13 501 : segini mchelm 502 : n2 = 1 503 : TITCHE = 'CARACTERISTIQUES' 504 : do 108 iga=1,ijcarb 505 : deche = licarb(iga) 506 : segini mchaml 507 : CONCHE(iga)=condec 508 : IMACHE(iga)=imadec 509 : ICHAML(iga)=mchaml 510 : IFOCHE = ifodec 511 : do in3=1,infdec(/1) 512 : infche(iga,in3) = infdec(in3) 513 : enddo 514 : NOMCHE(1)=nomdec 515 : TYPCHE(1)=typdec 516 : IELVAL(1)=ieldec 517 : *pv segdes MCHAML 518 : 108 continue 519 : *pv segdes mchelm 520 : if (minde.eq.1) ipcarb1 = mchelm 521 : if (minde.eq.2) ipcarb2 = mchelm 522 : endif 523 : enddo 524 : segsup licarb 525 : endif 526 : if(lsupca)segsup nomid 527 : c write(6,*) 'carac',ipcarb1,ipcarb2 528 : 529 : c segment pour changer les supports d integration et geometrique 530 : iichan=lilmel(/1) 531 : ijchan=0 532 : segini lichan 533 : c segment des composantes qui correspondent au support : on les protege 534 : * 535 : * trie les composantes concernees 536 : * on cherche a descendre le plus d informations possible ... mais 537 : * il faut certaines fois etre raisonnable 538 : * on raisonne selon le type d element, le constituant et le support des pg 539 : iilcon=iinomp 540 : ijlcon=0 541 : segini lilcon 542 : ipcon = lilcon 543 : c* 544 : c pour gagner du temps 545 : c --- on vise les etudes d ingenierie donc la selection est faite sur 546 : c la formulation --- on ne passe dans coml6 que les deche qui correspondent 547 : c au support. ce n est pas bien parce que la philosophie de COMP 548 : c est justement de faire descendre le maximum d info. o tristesse.kich (05/01) 549 : * write(6,*) 'mfr2', mfr2,conmod 550 : if (((mfr2.ge.11.or.mfr2.eq.7).and.mfr2.ne.33) .or. 551 : & lformu.eq.14) then 552 : do ldn=1,linomp(/1) 553 : lilcon(ldn) = linomp(ldn) 554 : enddo 555 : ijlcon=iinomp 556 : goto 201 557 : endif 558 : c 559 : * write(6,*) ' passage a la cloche mfr2 ', mfr2,lilmel(/1) 560 : nmel1=50 561 : segini icorre 562 : do 200 iol=1,lilmel(/1) 563 : segact imodel*nomod 564 : deche = lilmel(iol) 565 : if(igard(iol).eq.1) go to 170 566 : if(igard(iol).eq.-1) go to 200 567 : ***** segact deche 568 : * moterr(1:6) = nomdec 569 : * moterr(7:22) = condec 570 : * interr(1) = deche 570 : * call erreur(-329) 571 : c write(6,*) 'compo ', nomdec,condec,indec,imadec ,meleme 572 : *tc do ldn = 1,linomp(/1) 573 : * parmi les composantes protegees on privilegie celles qui ont le bon 574 : * constituant 575 : *tc if (deche.eq.linomp(ldn).and.condec.eq.conmod) goto 170 576 : *tc enddo 577 : *tc 578 : *tc if (formod(1).ne.'MELANGE'.and.matmod(1).ne.'PARALLELE') then 579 : *tc do ldn = 1,linomp(/1) 580 : * on evite de garder les composantes qui n ont pas le bon constituant 581 : * pour lesquelles la composante avec le bon constituant existe 582 : * sauf pour le melange parallele (kich 01/05) 583 : *tc dec1 = linomp(ldn) 584 : *tc if (nomdec.eq.dec1.nomdec.and.dec1.condec.eq.conmod) 585 : *tc & goto 200 586 : *tc enddo 587 : *tc endif 588 : * 589 : * traite les composantes qui n existent pas sur le bon support : 590 : * celui du modele ... on va chercher a projeter 591 : if (meleme.ne.imadec) then 592 : * write(6,*) ' coml2 passage meleme.ne.imadec' 593 : ipt1 = imadec 594 : segact meleme,ipt1 595 : * si le type des elements est le meme on cree un melval 596 : if (itypel.eq.ipt1.itypel) then 597 : * concretement pour les elments qui ne sont pas massifs ou coque on passe 598 : * au deche suivant (kich 05/01) 599 : ielin = ieldec 600 : * write(6,*) ' appel à comail ' 600 : call comail(meleme,ipt1,ielin,ielout,icorre) 601 : if (ielout.eq.0)go to 200 602 : * qu on range dans un deche que l on cree 603 : segini,dec1=deche 604 : dec1.ieldec= ielout 605 : dec1.imadec = meleme 606 : ***** segdes meleme,ipt1,deche 607 : deche = dec1 608 : ijchan=ijchan+1 609 : if(ijchan.gt.iichan) then 610 : iichan=iichan+100 611 : segadj lichan 612 : endif 613 : lichan(ijchan) = deche 614 : c write(6,*) 'cree sup geom deche', deche, nomdec,condec,indec 615 : else if (condec.ne.conmod.and.itypel.ne.ipt1.itypel 616 : & .and.infdec(6).eq.1) then 617 : * sinon si le constituant n est pas le meme on projette aux pts rigidite 618 : c!!! pour l instant ne marche que pour les mchaml aux noeuds !!! 619 : **** segdes meleme,ipt1 620 : iem = indec 621 : if (iem.eq.1.and.ncarb.gt.0.and.ipcarb1.eq.0) goto 200 622 : if (iem.gt.1.and.ncarb.gt.0.and.ipcarb2.eq.0) goto 200 623 : 624 : * cree un mchaml 625 : mchelm = IPOI1 626 : segact,mchelm*MOD 627 : ifoche=ifodec 628 : conche(1) = condec 629 : imache(1) = imadec 630 : do j = 1,infdec(/1) 631 : infche(1,j) = infdec(j) 632 : enddo 633 : mchaml = ichaml(1) 634 : SEGACT,mchaml*MOD 635 : nomche(1) = nomdec 636 : typche(1) = typdec 637 : ielval(1) = ieldec 638 : c* SEGDES,mchaml,mchelm 638 : call ecrcha('RIGIDITE') 638 : call ecrobj('MCHAML ',IPOI1) 639 : if (indec.eq.1.and.ipcarb1.ne.0) then 639 : call ecrobj('MCHAML ',ipcarb1) 640 : elseif (indec.gt.1.and.ipcarb2.ne.0) then 640 : call ecrobj('MCHAML ',ipcarb2) 641 : else 642 : endif 642 : call ecrobj('MMODEL ',IPMOD1) 642 : call PROIET 643 : IF(IERR.NE.0) RETURN 643 : call lirobj('MCHAML',IPCHE,0,IRE2) 644 : IF(IERR.NE.0) RETURN 645 : mchelm = ipche 646 : segact mchelm 647 : n1 = ichaml(/1) 648 : * pas de champ projete passe au suivant 649 : if (n1.eq.0) goto 200 650 : if (n1.ne.1) then 651 : * bizarre , contacter support 652 : moterr(1:6) = 'COML2' 653 : interr(1) = 11 653 : call erreur(943) 654 : return 655 : endif 656 : mchaml = ichaml(1) 657 : segact mchaml 658 : n2 = ielval(/1) 659 : * pas de champ projete passe au suivant 660 : if (n2.eq.0) goto 200 661 : if (n2.ne.1) then 662 : * bizarre , contacter support 663 : moterr(17:24) = 'COML2' 664 : interr(1) = 12 664 : call erreur(943) 665 : return 666 : endif 667 : * creer un deche 668 : n3 = infche(/2) 669 : segini deche 670 : indec = iem 671 : ieldec = ielval(1) 672 : typdec = typche(1) 673 : nomdec = nomche(1) 674 : imadec = imache(1) 675 : condec = conche(1) 676 : ifodec = ifoche 677 : do in3 = 1, n3 678 : infdec(in3) = infche(1,in3) 679 : enddo 680 : * mettre dans une pile 681 : c write(6,*) 'cree proi deche ', deche, nomdec, condec, indec 682 : ijchan=ijchan+1 683 : if(ijchan.gt.iichan) then 684 : iichan=iichan+ 100 685 : segadj lichan 686 : endif 687 : lichan(ijchan) = deche 688 : segsup mchaml,mchelm 689 : c 690 : else 691 : * sinon on passe au deche suivant 692 : **** segdes meleme,ipt1 693 : goto 200 694 : endif 695 : endif 696 : 697 : 170 continue 698 : * on change eventuellement sur les points d integration 699 : * convenables ... ce qui suppose en fait que l information 700 : * fournie a COMP n est pas redondante 701 : * en mecanique on utilise directement les champs fournis aux pgauss rigidite 702 : lome1 = infdec(6).eq.3.and.lesupp.eq.5 703 : lome2 = nomdec.eq.'TEMP'.or.nomdec.eq.'LX'.or.nomdec.eq.'FLX' 704 : if (infdec(6).ne.lesupp.and..not.lome1.and..not.lome2) then 705 : c write(6,*) 'change ', deche, nomdec 706 : iem = indec 707 : * cree un mchaml 708 : mchelm = IPOI1 709 : segact,mchelm*MOD 710 : ifoche=ifodec 711 : conche(1) = condec 712 : imache(1) = imadec 713 : do j = 1,infdec(/1) 714 : infche(1,j) = infdec(j) 715 : enddo 716 : mchaml = ichaml(1) 717 : SEGACT,mchaml*MOD 718 : nomche(1) = nomdec 719 : typche(1) = typdec 720 : ielval(1) = ieldec 721 : c* SEGDES,mchaml,mchelm 722 : * write(6,*) ' changement de support nomdec ',nomdec 722 : call CHASUP(IPMOD1,IPOI1,IPOI2,IRET,lesupp) 723 : if (IRET.NE.0) then 723 : CALL ERREUR(IRET) 724 : return 725 : endif 726 : if (ierr.ne.0) return 727 : mchelm = ipoi2 728 : segact mchelm 729 : n1 = ichaml(/1) 730 : if (n1.ne.1) then 731 : * bizarre , contacter support 732 : moterr(17:24) = 'COML2' 733 : interr(1) = 1 733 : call erreur(943) 734 : return 735 : endif 736 : mchaml = ichaml(1) 737 : segact mchaml 738 : n2 = ielval(/1) 739 : if (n2.ne.1) then 740 : * bizarre , contacter support 741 : moterr(17:24) = 'COML2' 742 : interr(1) = 2 742 : call erreur(943) 743 : return 744 : endif 745 : * creer un deche 746 : n3 = infche(/2) 747 : segini deche 748 : indec = iem 749 : ieldec = ielval(1) 750 : typdec = typche(1) 751 : nomdec = nomche(1) 752 : imadec = imache(1) 753 : condec = conche(1) 754 : ifodec = ifoche 755 : do in3 = 1, n3 756 : infdec(in3) = infche(1,in3) 757 : enddo 758 : segsup mchaml,mchelm 759 : * mettre dans une pile 760 : c write(6,*) 'cree sup pg deche ', deche, nomdec, condec, indec 761 : ijchan=ijchan+1 762 : if(ijchan.gt.iichan) then 763 : iichan=iichan+100 764 : segadj lichan 765 : endif 766 : lichan(ijchan) = deche 767 : endif 768 : c 769 : * write(6,*) 'lilcon ',deche,nomdec,typdec,condec,imadec,indec 770 : ijlcon=ijlcon+1 771 : if(ijlcon.gt.iilcon) then 772 : iilcon=iilcon+100 773 : segadj lilcon 774 : endif 775 : lilcon(ijlcon) = deche 776 : 777 : 200 continue 778 : do iou=1,idej 779 : mlenti=icor(iou) 780 : if(mlenti.ne.0)segsup mlenti 781 : enddo 782 : segsup icorre 783 : 201 continue 784 : 785 : imodel = iqmod 786 : segact imodel*nomod 787 : c passe ce qui reste 788 : if (ijlcon.ne.iilcon) then 789 : iilcon=ijlcon 790 : segadj lilcon 791 : endif 792 : if (lilcon(/1).ge.1) then 792 : * call gibtem(xkt) 793 : * write(6,*) ' coml2 : appel a coml6 ', xkt 794 : * write(6,*) 'appel a coml6 ' 795 : * do ioup=1,lilcon(/1) 796 : * deche=lilcon(ioup) 797 : * write(6,*)deche,' ',nomdec,' ',imadec,' ',indec,' ',condec 798 : * enddo 798 : call coml6(iqmod,ipcon,ipinf,indeso,lesupp,jtruli,IRETOU) 799 : 799 : * call gibtem(xkt) 800 : * write(6,*) ' coml2 : retour de coml6 ',xkt 801 : else 802 : c write(6,*) 'pas de composante pour le sous-model ',imodel 803 : endif 804 : * write(6,*) 'coml2 : ierr ', ierr , 'iretou ', iretou 805 : if (ierr.gt.1) return 806 : 807 : * complete la pile des deche en sortie / desactive les DECHE et les MELVAL 808 : lilcon = ipcon 809 : ijmel=lilmel(/1) 810 : do 800 ioc =iilcon+1,lilcon(/1) 811 : deche = lilcon(ioc) 812 : ***** segact deche*nomod 813 : if (indec.lt.indeso) then 814 : else if (indec.eq.indeso.and.condec.eq.conmod) then 815 : * si on a ete coherent on ne peut creer 2 fois le meme deche 816 : * on ne rajoute que les deche crees sur le constituant 817 : * on ne met pas dans lilmel les deches intermediaires 818 : if (ijchan.gt.0) then 819 : do iyf = 1,ijchan 820 : if (lichan(iyf).eq.deche) goto 800 821 : enddo 822 : endif 823 : c write(6,*) 'dans lilmel ',deche,nomdec,condec,indec 824 : ijmel=ijmel+1 825 : if(ijmel.gt.iimel) then 826 : iimel=iimel+100 827 : segadj lilmel 828 : endif 829 : lilmel(ijmel) = deche 830 : c melval = ieldec 831 : c segact melval 832 : else 833 : endif 834 : * melval = ieldec 835 : *** segdes melval 836 : c segdes deche 837 : 800 continue 838 : iimel=ijmel 839 : segadj lilmel 840 : segsup lilcon,linomp,igard,ncop 841 : 842 : * supprime melval intermediaire 843 : if (ijchan.gt.0) then 844 : do iop = 1,ijchan 845 : deche = lichan(iop) 846 : ******* segact deche 847 : do il = 1,lilmel(/1) 848 : dec1 = lilmel(il) 849 : if (dec1.indec.eq.indeso.and.dec1.ieldec.eq.ieldec) goto 810 850 : enddo 851 : melval = ieldec 852 : c write(6,*) 'supprime deche ',nomdec,melval,deche 853 : segsup melval 854 : 810 continue 855 : segsup deche 856 : enddo 857 : endif 858 : segsup lichan 859 : 860 : * supprime les mchaml de caracteristiques 861 : mchel1=ipcarb1 862 : do minde = 1, 2 863 : if (minde.eq.2) mchel1=ipcarb2 864 : if (mchel1.gt.0) then 865 : segact mchel1 866 : do jch1 = 1,mchel1.ichaml(/1) 867 : mchaml = mchel1.ichaml(jch1) 868 : if (mchaml.gt.0) segsup mchaml 869 : enddo 870 : segsup mchel1 871 : endif 872 : enddo 873 : c write(6,*) 'supprime caracteristiques ' , ipcarb1,ipcarb2 874 : 875 : if (ierr.ne.0) return 876 : if (iretou.ne.0) return 877 : c 878 : c cas traitement non-local MELANGE 879 : c 880 : IF (lformu.EQ.11) THEN 881 : IF (ivamod(/1).gt.0) THEN 882 : c 883 : c rassemble les deche lies aux phases 884 : iilcon=lilmel(/1) 885 : ijlcon=0 886 : segini lilcon 887 : ipcon = lilcon 888 : do 910 ide = 1,iilcon 889 : deche = lilmel(ide) 890 : if (indec.eq.indeso.and.imadec.eq.imamod) then 891 : if (condec.eq.conmod) then 892 : ijlcon = ijlcon + 1 893 : lilcon(ijlcon) = deche 894 : else 895 : do im = 1,ivamod(/1) 896 : if (tymode(im).eq.'IMODEL') then 897 : imode1 = ivamod(im) 898 : segact imode1 899 : if ((condec.eq.imode1.conmod).or. 900 : &(nomdec(1:4).eq.imode1.conmod(17:20))) then 901 : ijlcon = ijlcon + 1 902 : lilcon(ijlcon) = deche 903 : endif 904 : endif 905 : enddo 906 : endif 907 : elseif (indec.eq.2.and.imadec.eq.imamod.and.condec.ne.conmod) 908 : &then 909 : do im = 1,ivamod(/1) 910 : if (tymode(im).eq.'IMODEL') then 911 : imode1 = ivamod(im) 912 : segact imode1 913 : if ((condec.eq.imode1.conmod).or. 914 : &(nomdec(1:4).eq.imode1.conmod(17:20))) then 915 : ijlcon = ijlcon + 1 916 : lilcon(ijlcon) = deche 917 : endif 918 : endif 919 : enddo 920 : endif 921 : 910 continue 922 : iilcon = ijlcon 923 : segadj lilcon 924 : iilcon0 = iilcon 925 : 926 : c traite 926 : call coml9(iqmod,ipcon,ipinf,indeso,IRETOU,lesupp) 927 : 928 : c range 929 : * complete la pile des deche en sortie 930 : lilcon = ipcon 931 : ijmel=lilmel(/1) 932 : iimel=ijmel 933 : do 920 ioc =iilcon0+1,lilcon(/1) 934 : deche = lilcon(ioc) 935 : if (indec.lt.indeso) then 936 : else if (indec.eq.indeso.and.condec.eq.conmod) then 937 : * si on a ete coherent on ne peut creer 2 fois le meme deche 938 : ijmel=ijmel+1 939 : if(ijmel.gt.iimel) then 940 : iimel=iimel+100 941 : segadj lilmel 942 : endif 943 : lilmel(ijmel) = deche 944 : c melval = ieldec 945 : c segact melval 946 : else 947 : endif 948 : 920 continue 949 : iimel=ijmel 950 : segadj lilmel 951 : c detruit 952 : segsup lilcon 953 : 954 : c fin traitement non local MELANGE 955 : ENDIF 956 : ENDIF 957 : c 958 : if (info.ne.0) then 959 : segsup info 960 : info=0 961 : endif 962 : c 963 : *pv segdes meleme 964 : *pv segdes,imodel 965 : 966 : 1000 CONTINUE 967 : c------------------------------------ 968 : c fin boucle modeles elementaires 969 : c------------------------------------ 970 : 971 : c Destruction du segment struli (si utilise) 972 : if (itruli.ne.0) then 973 : if (momoda.gt.0) then 974 : mmode2 = momoda 975 : segsup mmode2 976 : endif 977 : if (mostat.gt.0) then 978 : mmode2 = mostat 979 : segsup mmode2 980 : endif 981 : if (itbmod.gt.0) then 982 : mmode2 = itbmod 983 : segsup mmode2 984 : endif 985 : if (itlia.gt.0) then 986 : mmode2 = itlia 987 : segsup mmode2 988 : endif 989 : if (ichain.gt.0) then 990 : mlent3 = ichain 991 : segsup mlent3 992 : endif 993 : segsup struli 994 : endif 995 : c Destruction modele deroule 996 : c* mmodel = impod7 997 : segsup mmodel 998 : segsup ipozo,izozo 999 : c Destruction autres segments 1000 : mmode1 = IPMOD1 1001 : segsup mmode1 1002 : mchelm = IPOI1 1003 : segact,mchelm 1004 : mchaml = ichaml(1) 1005 : segsup,mchaml,mchelm 1006 : 1006 : * call gibtem (xkt) 1007 : * write(ioimp,*) ' sortie coml2 ' , xkt 1008 : 1009 : RETURN 1010 : END 1011 : 1012 :
© Cast3M 2003 - All rights reserved.
Disclaimer