C DBBSUP SOURCE PV 21/01/29 21:15:17 10866 C suppression des doubles multiplicateurs de L sur une restitution C subroutine dbbsup(icolac) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC TMCOLAC -INC SMELEME -INC SMRIGID -INC SMCHPOI -INC SMCOORD -INC PPARAM -INC CCOPTIO segment trav integer lag1(nbpts) integer lag2(nbpts) endsegment write (6,*) ' fusion des doubles multiplicateurs de Lagrange' segini trav nbnn=2 nbelem=0 nbsous=0 nbref=0 segini ipt8 ipt8.itypel=2 segact icolac * * on construit d'abord le meleme des couples de multiplicateurs * ITLACC=KCOLA(1) segact itlacc IF (ITLAC(/1).EQ.0) GOTO 20 DO 12 I=1,ITLAC(/1) MELEME=ITLAC(I) IF (meleme.eq.0) goto 12 segact meleme*mod if (itypel.ne.49) then segdes meleme goto 12 endif * ok on supprime le 2eme noeud nbele=num(/2) nbelem=nbelem+nbele nbnn=2 segadj ipt8 do 30 ie=1,nbele ipt8.num(1,nbelem-nbele+ie)=num(1,ie) ipt8.num(2,nbelem-nbele+ie)=num(2,ie) lag1(num(1,ie))=num(2,ie) lag2(num(2,ie))=num(1,ie) * do 40 in=2,num(/1)-1 * num(in,ie)=num(in+1,ie) * 40 continue 30 continue * nbelem=num(/2) * nbnn=num(/1)-1 * segadj meleme segdes meleme 12 continue 20 continue * on elimine dans les chpoint itlacc=kcola(2) segact itlacc if (itlac(/1).eq.0) goto 90 do 100 i=1,itlac(/1) mchpoi=itlac(i) segact mchpoi do 110 isoupo=1,ipchp(/1) msoupo=ipchp(isoupo) segact msoupo if (nocomp(/2).ne.1) goto 110 mul=0 if (nocomp(1).eq.'LX') mul=2 if (nocomp(1).eq.'FLX') mul=1 if (mul.eq.0) goto 110 write (6,*) ' conversion du mpoval ',ipoval,nocomp(1) meleme=igeoc segact meleme mpoval=ipoval segact mpoval*mod ict=0 do 130 iv=1,vpocha(/1) if (lag2(num(1,iv)).ne.0) goto 130 val=vpocha(iv,1) if (lag1(num(1,iv)).ne.0) val=mul*val ict=ict+1 vpocha(iv,1)=val 130 continue n=ict nc=1 segadj mpoval segdes mpoval,meleme 110 continue 100 continue 90 continue * on élimine dans les raideurs itlacc=kcola(3) segact itlacc if (itlac(/1).eq.0) goto 290 do 300 i=1,itlac(/1) mrigid=itlac(i) segact mrigid do 310 ir=1,irigel(/2) descr=irigel(3,ir) segact descr*mod if (lisinc(2).ne.'LX') goto 311 write (6,*) 'conversion de la raideur ',mrigid,ir do 320 il=2,lisinc(/2)-1 lisinc(il)=lisinc(il+1) lisdua(il)=lisdua(il+1) noelep(il)=noelep(il+1)-1 noeled(il)=noeled(il+1)-1 320 continue nligrp=lisinc(/2)-1 nligrd=nligrp segadj descr xmatri=irigel(4,ir) segact xmatri*mod nelrig=re(/3) if (re(/1).ne.nligrd) then segadj xmatri do 330 im=1,nelrig * xmatri=imattt(im) * segact xmatri*mod * test si le xmatri a déjà été converti if (re(/1).eq.nligrd) goto 341 do il=1,nligrd do ic=1,nligrd re(il,ic,im)=re(il+1,ic+1,im) enddo enddo re(1,1,im)=0.d0 * segadj xmatri 341 continue * segdes xmatri 330 continue endif segdes xmatri 311 continue segdes descr 310 continue segdes mrigid 300 continue 290 continue * on elimine dans les maillages en dernier itlacc=kcola(1) segact itlacc if (itlac(/1).eq.0) goto 190 do 200 i=1,itlac(/1) meleme=itlac(i) segact meleme*mod if (itypel.ne.1 ) goto 210 ict=0 do 220 j=1,num(/2) if (lag2(num(1,j)).ne.0) goto 220 ict=ict+1 num(1,ict)=num(1,j) 220 continue if (nbelem.ne.ict) > write (6,*) ' conversion du meleme poin1 ',meleme nbnn=1 nbelem=ict nbsous=0 nbref=0 segadj meleme 210 continue if (itypel.ne.49) goto 230 write (6,*) ' conversion du meleme type 22 ',meleme do j=1,num(/2) do ip=num(/1)-1,2,-1 num(ip,j)=num(ip+1,j) enddo enddo nbnn=num(/1)-1 nbelem=num(/2) nbsous=0 nbref=0 segadj meleme 230 continue segdes meleme 200 continue 190 continue segsup trav * return end