C RFCO SOURCE MB234859 26/05/13 21:15:19 12548 SUBROUTINE RFCO *---------------------------------------------------------------------- * Calcul des raideurs et des jeux dans le cas de modeles de contact * avec ou sans frottements * * Entree : MMODEL de contact * * Sortie : CHPOINT (valeurs des jeux) (pas pour les frocable) * RIGIDITE conditions de contact et de frottements * * Remarque : faut-il egalement sortir les conditions de frottements * pour les utiliser comme indicateur de recalcul des * conditions en cas de grands glissements. * Les lignes commentees demarrant par CCC permettent de * faire cela mais a tester davantage avant *---------------------------------------------------------------------- C IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER (I-N) C -INC PPARAM -INC CCOPTIO -INC SMMODEL pointeur mmode3.mmodel,imode3.imodel -INC SMRIGID -INC SMCHPOI -INC SMELEME -INC SMCOORD C logical lconv SEGMENT ICPR(NBPTS) SEGMENT IRELA(NBELT) C CALL LIROBJ('MMODEL ',MMODEL,1,IRETOU) CALL ACTOBJ('MMODEL ',MMODEL,1) IF(IERR.NE.0) RETURN C CALL LIRLOG(lconv,1,iretou) IF(IERR.NE.0) RETURN C MCHELX=0 CALL LIROBJ('MCHAML ', MCHELX,0,IRCHA1) IF(IRCHA1.EQ.1) CALL ACTOBJ('MCHAML ', MCHELX,1) IF(IERR.NE.0) RETURN C segact mcoord irigi0=0 irigi1=0 irigi2=0 mforc=0 C DO 10 ISOUS=1,KMODEL(/1) imodel=kmodel(isous) if (formod(1).NE.'CONTACT') GOTO 10 C C D'apres NOMATE : C imate=1 unilateral; imate=2 maintenu; C inatu=0 sans frottement;inatu=1 coulomb; inatu=2 frocable C C CONTACT UNILATERAL if(imatee.eq.1) then C C FROCABLE if(inatuu.eq.2) then if (lconv) then ** write(6,*) ' ivamod ',ivamod(/1) if(ivamod(/1).ne.3) call erreur(5) ri3 = 0 meleme = ivamod(2) ipt1 = ivamod(1) * call ecmail( meleme,1) * call ecmail ( ipt1,1) * Petit modele unitaire local (a detruire en fin de traitement) n1=1 segini,mmode2,mmode3 nfor=0 nmat=0 mn3=1 nobmod=1 segini imode2 imode2.imamod=imamod imode2.conmod=conmod imode2.ivamod(1)=mmode3 imode2.tymode(1)='MMODEL' mmode2.kmodel(1)=imode2 nobmod=0 segini imode3 imode3.imamod=ipt1 imode3.conmod=conmod mmode3.kmodel(1)=imode3 * Option accro 'GLISS' igliss=1 call ecrree(1.d-3) call ecrobj('MAILLAGE',meleme) call ecrobj('MMODEL ',mmode2) call accro(igliss) IF (IERR.NE.0) THEN CALL ERREUR(19) GOTO 9000 ENDIF call lirobj('RIGIDITE',ri2,1,iretou) IF (IERR.NE.0) THEN CALL ERREUR(19) GOTO 9000 ENDIF segsup mmode2,mmode3 if(irigi2.eq.0) then irigi2=ri2 else call fusrig(irigi2,ri2,Inoup) irigi2= inoup endif endif C else C Cas sans frottement ou avec frottement de Coulomb ipt1 = imamod ipt6 = ivamod(1) ipt8 = ivamod(2) itcont = ivamod(3) C if (idim.eq.3) then ** write(6,*) ' avant impo32 ipt6 ipt8 itcont inatuu', ** > ipt6,ipt8,itcont,inatuu call impo32(ipt1,ipt6,ipt8,itcont,mchelx,ri1,mchpo2) if (ierr.ne.0) GOTO 9000 C-------------------------------------------------------------------- CCC if (mchpo2.ne.0) call frig3C(ipt1,ri1,mchpo2,ri2) C-------------------------------------------------------------------- if (inatuu.eq.1.and.mchpo2.ne.0) then call frig3C(ipt1,ri1,mchpo2,ri2) if (ierr.ne.0) GOTO 9000 endif C elseif (idim.eq.2) then if (ifomod.ne.-1 .and. ifomod.ne.0) then call erreur(710) GOTO 9000 endif call impos2(ipt1,ipt6,ipt8,itcont,mchelx,ri1,mchpo2) if (ierr.ne.0) GOTO 9000 C-------------------------------------------------------------------- CCC if (mchpo2.ne.0) call frig2C(ipt1,ri1,mchpo2,ri2) C-------------------------------------------------------------------- if (inatuu.eq.1.and.mchpo2.ne.0) then call frig2C(ipt1,ri1,mchpo2,ri2) if (ierr.ne.0) GOTO 9000 endif endif C call ftaill(ipt1,mchpo2) if (ierr.ne.0) goto 9000 C C Fusionner les objets pour le modele elementaire courant ri3=ri1 if (inatuu.eq.1.and.mchpo2.ne.0) call fusrig(ri1,ri2,ri3) C C-------------------------------------------------------------------- C Fusionner les objets avec les autres modeles elementaires CCC if(irigi0.eq.0.or.ri2.eq.0) then CCC irigi0=irigi0+ri2 CCC else CCC call fusrig(irigi0,ri2,inoup) CCC irigi0=inoup CCC endif C-------------------------------------------------------------------- C C Fusionner les objets avec les autres modeles elementaires if(irigi1.eq.0) then irigi1=ri3 else call fusrig(irigi1,ri3,inoup) irigi1=inoup endif C if(mforc.eq.0.or.mchpo2.eq.0) then mforc=mforc+mchpo2 else call adchpo(mchpo2,mforc,iret,1.D0,1.D0) mforc=iret endif C endif C endif 10 CONTINUE C C IRIGI2 : Pointeur sur les rigidites des modeles FROCABLES C IRIGI1 : Pointeur sur les rigidites des autres modeles * on reordonne mrigid pour mettre en premier toutes * les relations unilatérales ( frocables peut en sortir des pas unil) C C Elements quadratiques : ajout de conditions sur noeuds milieu C -> ne le faire que pour les elements ayant une condition de C contact if(irigi1.ne.0) then if (ivamod(/1).eq.4) then C C Identifier les noeuds avec une condition de contact segini,icpr ri4=irigi1 segact,ri4 do 13 iri=1,ri4.irigel(/2) if (ri4.irigel(6,iri).ne.1) goto 13 ipt4=ri4.irigel(1,iri) do iel=1,ipt4.num(/2) do ino=2,ipt4.num(/1) ipoin=ipt4.num(ino,iel) if (icpr(ipoin).eq.0) icpr(ipoin)=1 enddo enddo 13 continue C ri4=ivamod(4) segact,ri4 nri=ri4.irigel(/2) nrigel=nri segini,ri5 ri5.mtymat=ri4.mtymat ri5.iforig=ri4.iforig irj=0 do iri=1,nri igard=0 ipt4=ri4.irigel(1,iri) segact,ipt4 nbnoe=ipt4.num(/1) nbelt=ipt4.num(/2) segini,irela do 14 iel=1,nbelt do ino=2,nbnoe ipoin=ipt4.num(ino,iel) if (icpr(ipoin).ne.1) goto 14 enddo igard=igard+1 irela(iel)=igard 14 continue if (igard.eq.0) goto 15 irj=irj+1 C xmatr4=ri4.irigel(4,iri) if (igard.eq.nbelt) then ipt5=ipt4 xmatr5=xmatr4 goto 16 endif C nbelem=igard nbnn=nbnoe nbref=0 nbsous=0 segini,ipt5 segact,xmatr4 nligrd=xmatr4.re(/1) nligrp=xmatr4.re(/2) nelrig=igard rigrel=0 segini,xmatr5 do 17 iel=1,nbelt iel2=irela(iel) if (iel2.eq.0) goto 17 do ino=1,nbnoe ipt5.num(ino,iel2)=ipt4.num(ino,iel) enddo do ilc=1,nligrp do ili=1,nligrd xmatr5.re(ili,ilc,iel2)=xmatr4.re(ili,ilc,iel) enddo enddo 17 continue 16 continue ri5.coerig(irj)=ri4.coerig(iri) ri5.irigel(1,irj)=ipt5 ri5.irigel(2,irj)=ri4.irigel(2,iri) ri5.irigel(3,irj)=ri4.irigel(3,iri) ri5.irigel(4,irj)=xmatr5 ri5.irigel(5,irj)=ri4.irigel(5,iri) ri5.irigel(6,irj)=ri4.irigel(6,iri) ri5.irigel(7,irj)=ri4.irigel(7,iri) ri5.irigel(8,irj)=ri4.irigel(8,iri) 15 continue segsup,irela enddo C if (irj.eq.0) then segsup,ri5 else if (irj.ne.nri) segadj,ri5 ri4=ivamod(4) call fusrig(ri5,irigi1,iret) irigi1=iret endif segsup,icpr endif endif C mrigid=irigi1 if(irigi2.ne.0) then mrigid=irigi2 segini,ri1=mrigid ide=0 segact mrigid ifi=irigel(/2)+1 do i=1,irigel(/2) if( irigel(6,i). eq .0) then ifi=ifi-1 ipla=ifi else ide=ide+1 ipla=ide endif do ib=1,irigel(/1) ri1.irigel(ib,ipla)=irigel(ib,i) enddo ri1.coerig(ipla)= coerig(i) enddo segdes ri1 **** segsup mrigid mrigid=ri1 * une seule raideur en sortie if (ri1.eq.0.or.irigi1.eq.0) then mrigid = ri1+irigi1 else call fusrig(ri1,irigi1,mrigid) endif endif C C-------------------------------------------------------------------- C Conditions de frottement : pour tests dans unpas CCC if(irigi0.eq.0) then CCC call ecrent(irigi0) CCC else CCC call actobj('RIGIDITE',irigi0,0) CCC call ecrobj('RIGIDITE',irigi0) CCC endif C-------------------------------------------------------------------- C if(mforc.eq.0) then call ecrent(mforc) else call actobj('CHPOINT',mforc,1) call ecrobj('CHPOINT',mforc) endif C if(mrigid.eq.0) then call ecrent(mrigid) else call actobj('RIGIDITE',mrigid,0) call ecrobj('RIGIDITE',mrigid) endif C 9000 CONTINUE END