C FRIG3C SOURCE PV090527 26/04/30 21:15:34 12529 SUBROUTINE FRIG3C (maifro,IPRIGI,IPCHJE,IPRIG2) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * Ce sous-programme calcule la raideur de frottement en 3D. * il a besoin pour cela du maillage de frottement et de la raideur * de contact (ou la raideur totale si c'est plus simple) -INC PPARAM -INC CCOPTIO -INC CCREEL -INC CCGEOME -INC SMCHPOI -INC SMELEME -INC SMRIGID -INC SMCOORD * icpr lx du contact ==> lx du frottement segment icpr1(nbpts) segment icpr2(nbpts) * xjeu champs de jeux initiaux segment xjeu(nbpts) * * * creation et remplissage de icpr * segini icpr1,icpr2 nbp=0 meleme=maifro segact meleme ipt1=meleme do is=1,max(1,lisous(/1)) if (lisous(/1).ne.0) ipt1=lisous(is) segact ipt1 if (ipt1.itypel.ne.22) then write (6,*) ' ipt1.itypel ',ipt1.itypel call erreur(16) endif if (ierr.ne.0) return do iel=1,ipt1.num(/2) il=ipt1.num(1,iel) if (icpr1(il).eq.0) then nbp=nbp+1 icpr1(il)=ipt1.num(ipt1.num(/1)-1,iel) icpr2(il)=ipt1.num(ipt1.num(/1),iel) endif if(icpr1(il).ne.ipt1.num(ipt1.num(/1)-1,iel)) call erreur(5) enddo enddo * remplissage du champ de jeux (demi-frottement si jeu non nul) segini xjeu mchpoi = IPCHJE segact mchpoi iOK=0 do 15 isoupo = 1, ipchp(/1) msoupo = ipchp(isoupo) segact msoupo DO 16 i=1,nocomp(/2) IF (NOCOMP(i).NE.'FLX ') GOTO 16 mpoval=ipoval segact mpoval ipt8=igeoc segact ipt8 DO 17 j=1,vpocha(/1) xjeu(ipt8.num(1,j))=vpocha(j,i) 17 CONTINUE iOK=1 16 CONTINUE 15 continue IF (iOK.NE.1) THEN MOTERR(1:4)='FLX ' MOTERR(5:8)='DEPI' CALL ERREUR(77) ENDIF IF (ierr.ne.0) return * * boucle sur les raideurs de contact pour les transformer en frottement * mrigid=iprigi segact mrigid segini,ri1=mrigid er1 = 1.d0 er2 = 2.71828182845904523536 er3 = xpi sr=sqrt(er1**2+er2**2+er3**2) er1=er1/sr er2=er2/sr er3=er3/sr do 10 ir=1,irigel(/2) ri1.irigel(1,ir)=0 ri1.irigel(4,ir)=0 meleme=irigel(1,ir) segact meleme ipt1=0 if (itypel.ne.22) goto 10 if (irigel(6,ir).eq.0) goto 10 nbsous=0 nbref=0 nbnn=num(/1) nbelem=num(/2)*2 segini,ipt1 ipt1.itypel=22 xmatri=irigel(4,ir) segact xmatri nligrd=re(/1) nligrp=re(/2) nelrig=re(/3)*2 RIGREL=0 segini,xmatr1 do iel=1,num(/2) il=num(1,iel) * coefficient multiplicateur suivant le jeu par rapport a la taille de l'element * taille de l'element au carre iel1=2*iel-1 if1=icpr1(il) ipt1.num(1,iel1)=if1 ipt1.icolor(iel1)=icolor(iel) do in=2,ipt1.num(/1) ipt1.num(in,iel1)=num(in,iel) enddo sre=sqrt(re(1,nligrp-2,iel)**2+re(1,nligrp-1,iel)**2+ > re(1,nligrp,iel)**2) do ic=2,re(/2),3 srev=sqrt(re(1,ic,iel)**2+re(1,ic+1,iel)**2+re(1,ic+2,iel)**2) xmatr1.re(1,ic,iel1)=(er2*re(1,ic+2,iel)-er3*re(1,ic+1,iel)) xmatr1.re(1,ic+1,iel1)=(er3*re(1,ic,iel)-er1*re(1,ic+2,iel)) xmatr1.re(1,ic+2,iel1)=(er1*re(1,ic+1,iel)-er2*re(1,ic,iel)) srep=sqrt(xmatr1.re(1,ic,iel1)**2+xmatr1.re(1,ic+1,iel1)**2+ > xmatr1.re(1,ic+2,iel1)**2) if (srep.ne.srep) write(6,*) ' frig3c ',re(1,ic,iel), > re(1,ic+1,iel),re(1,ic+2,iel) * iel1 orthogonal a iel et a 1 e pi if (srep/srev.gt.1d-3) then xmatr1.re(1,ic,iel1)=xmatr1.re(1,ic,iel1)*srev/srep xmatr1.re(1,ic+1,iel1)=xmatr1.re(1,ic+1,iel1)*srev/srep xmatr1.re(1,ic+2,iel1)=xmatr1.re(1,ic+2,iel1)*srev/srep else write(6,*) ' frig3c second choix ',srep,srev srev=sqrt(re(1,ic,iel)**2+re(1,ic+1,iel)**2+re(1,ic+2,iel)**2) srep=sqrt(re(1,ic+2,iel)**2+re(1,ic,iel)**2) if (srep.lt.xpetit) srep=1.d0 xmatr1.re(1,ic,iel1)=-re(1,ic+2,iel)*srev/srep xmatr1.re(1,ic+1,iel1)=0.d0 xmatr1.re(1,ic+2,iel1)=re(1,ic,iel)*srev/srep endif * write(6,*) ' re ',re(1,ic,iel),re(1,ic+1,iel),re(1,ic+2,iel) * write(6,*) xmatr1.re(1,ic,iel1),xmatr1.re(1,ic+1,iel1), * > xmatr1.re(1,ic+2,iel1) enddo ** xmatr1.re(1,ic,iel1)=-re(1,ic+1,iel)*srev/srep ** xmatr1.re(1,ic+1,iel1)=re(1,ic,iel)*srev/srep ** xmatr1.re(1,ic+2,iel1)=0.d0 ** enddo do ic=2,re(/1) xmatr1.re(ic,1,iel1)=xmatr1.re(1,ic,iel1) enddo iel2=2*iel if2=icpr2(il) ipt1.num(1,iel2)=if2 ipt1.icolor(iel2)=icolor(iel) do in=2,ipt1.num(/1) ipt1.num(in,iel2)=num(in,iel) enddo sre=sqrt(re(1,nligrp-2,iel)**2+re(1,nligrp-1,iel)**2+ > re(1,nligrp,iel)**2) do ic=2,re(/2),3 if (sre.lt.xpetit) sre=1.d0 * iel2 orthogonal a iel et iel1 xmatr1.re(1,ic,iel2)= > (re(1,nligrp-1,iel)*xmatr1.re(1,ic+2,iel1)- > re(1,nligrp ,iel)*xmatr1.re(1,ic+1,iel1))/sre xmatr1.re(1,ic+1,iel2)= > (re(1,nligrp ,iel)*xmatr1.re(1,ic ,iel1)- > re(1,nligrp-2,iel)*xmatr1.re(1,ic+2,iel1))/sre xmatr1.re(1,ic+2,iel2)= > (re(1,nligrp-2,iel)*xmatr1.re(1,ic+1,iel1)- > re(1,nligrp-1,iel)*xmatr1.re(1,ic, iel1))/sre enddo do ic=2,re(/1) xmatr1.re(ic,1,iel2)=xmatr1.re(1,ic,iel2) enddo enddo segdes xmatri ri1.irigel(1,ir)=ipt1 ri1.irigel(4,ir)=xmatr1 ri1.irigel(6,ir)=2 10 continue segdes mrigid * * boucle de compaction du resultat * mrigid=ri1 irr=0 do 100 ir=1,irigel(/2) meleme=irigel(1,ir) xmatri=irigel(4,ir) if (meleme.eq.0) goto 100 ill=0 do iel=1,num(/2) if (num(1,iel).ne.0) then ill=ill+1 if (ill.ne.0) then do in=1,num(/1) num(in,ill)=num(in,iel) enddo icolor(ill)=icolor(iel) do ic=1,re(/1) re(1,ic,ill)=re(1,ic,iel) re(ic,1,ill)=re(ic,1,iel) enddo endif endif enddo if (ill.eq.0) goto 100 if (ill.ne.num(/2)) then nbsous=0 nbref=0 nbnn=num(/1) nbelem=ill segadj meleme endif ** write (6,*) ' meleme sortie dans frig2c ' ** call ecmail(meleme,0) irr=irr+1 if (irr.ne.ir) then do ir1=1,irigel(/1) irigel(ir1,irr)=irigel(ir1,ir) enddo coerig(irr)=coerig(ir) endif 100 continue nrigel=irr if (irigel(/2).ne.irr) segadj mrigid iprig2=mrigid ** call prrigi(mrigid,1) segsup icpr1,icpr2,xjeu return end