C DBBSUP    SOURCE    PV090527  26/04/30    21:15:26     12529          
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
          rigrel=0
          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