C DTSUPZ    SOURCE    MB234859  26/06/10    21:15:28     12569          
               SUBROUTINE DTSUPz(IRET,ktrace,msorse)
C  **** DESTRUCTION APPROXIMATIVE D'UN SUPER-ELEMENT
      IMPLICIT INTEGER(I-N)
      character*6 msorse                                                                        MSUPER=IRET
      integer i, iaux, ico, inc, ipile, iret, ktrace

-INC PPARAM
-INC CCOPTIO
-INC COCOLL
-INC SMSUPER
-INC SMELEME
-INC SMMATRI
-INC TMCOLAC

      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
      iun=1
      MSUPER=IRET
      SEGACT MSUPER
C
      IAUX=MRIGTO
      CALL DTRIGZ(IAUX,ktrace,msorse)
C
      IAUX=MSURAI
      CALL DTRIGZ(IAUX,ktrace,msorse)
C
      MELEME=MSUPEL
      if( ktrace.eq.meleme) then
        ktrace=-ktrace
        msorse='MELEME'
      endif
      SEGSUP MELEME
         IF(IPSAUV.NE.0) THEN
         ICOLAC = IPSAUV
         SEGACT ICOLAC
         ILISSE=ILISSG
         SEGACT ILISSE*MOD
         CALL TYPFIL('MAILLAGE',ICO)
         ITLACC = KCOLA(ICO)
         SEGACT ITLACC*MOD
         CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
         CALL TYPFIL('RIGIDITE',ICO)
         ITLACC = KCOLA(ICO)
         SEGACT ITLACC*MOD
         IAUX=MSURAI
         CALL AJOUN0(ITLACC,IAUX,ILISSE,iun)
         IAUX=MRIGTO
         CALL AJOUN0(ITLACC,IAUX,ILISSE,iun)
         SEGDES ITLACC
         SEGDES ICOLAC,ILISSE
         ENDIF
C        Suppression des piles d'objets communiques
         if(piComm.gt.0) then
            piles=piComm
            segact piles
            call typfil('MAILLAGE',ico)
            do ipile=1,piles.proc(/1)
               jcolac= piles.proc(ipile)
               if(jcolac.ne.0) then
                  segact jcolac
                  jlisse=jcolac.ilissg
                  segact jlisse*mod
                  jtlacc=jcolac.kcola(ico)
                  segact jtlacc*mod
                  call ajoun0(jtlacc,MELEME,jlisse,iun)
                  segdes jtlacc
               endif
            enddo
            call typfil('RIGIDITE',ico)
            do ipile=1,piles.proc(/1)
               jcolac= piles.proc(ipile)
               if(jcolac.ne.0) then
                  jlisse=jcolac.ilissg
                  jtlacc=jcolac.kcola(ico)
                  segact jtlacc*mod
                  iaux=MSURAI
                  call ajoun0(jtlacc,IAUX,jlisse,iun)
                  iaux=MRIGTO
                  call ajoun0(jtlacc,IAUX,jlisse,iun)
                  segdes jtlacc
                  segdes jlisse
                  segdes jcolac
               endif
            enddo
            segdes piles
         endif
C
      MMATRI=MCROUT
      SEGACT MMATRI
      MDIAG=IDIAG
      if( ktrace.eq.mdiag) then
        ktrace=-ktrace
        msorse='MDNOR'
      endif
      SEGSUP MDIAG
      MELEME=IGEOMA
      if( ktrace.eq.meleme) then
        ktrace=-ktrace
        msorse='MELEME'
      endif
      SEGSUP MELEME
      IF(IPSAUV.NE.0) THEN
         ICOLAC = IPSAUV
         SEGACT ICOLAC
         ILISSE=ILISSG
         SEGACT ILISSE*MOD
         CALL TYPFIL('MAILLAGE',ICO)
         ITLACC = KCOLA(ICO)
         SEGACT ITLACC*MOD
         CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
         SEGDES ITLACC
         SEGDES ICOLAC,ILISSE
      ENDIF
C     Suppression du meleme des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('MAILLAGE',ico)
         do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
               segact jcolac
               jlisse=jcolac.ilissg
               segact jlisse*mod
               jtlacc=jcolac.kcola(ico)
               segact jtlacc*mod
               call ajoun0(jtlacc,MELEME,jlisse,iun)
               segdes jtlacc
               segdes jlisse
               segdes jcolac
            endif
         enddo
         segdes piles
      endif
      MINCPO=IINCPO
      if( ktrace.eq.mincpo) then
        ktrace=-ktrace
        msorse='MINCPO'
      endif
      SEGSUP MINCPO
      MIDUA=IIDUA
      if( ktrace.eq.midua) then
        ktrace=-ktrace
        msorse='MIDUA'
      endif
      SEGSUP MIDUA
      MHARK=IHARK
      if( ktrace.eq.mhark) then
        ktrace=-ktrace
        msorse='MHARK'
      endif
      SEGSUP MHARK
      MIMIK=IIMIK
      if( ktrace.eq.mimik) then
        ktrace=-ktrace
        msorse='MIMIK'
      endif
      SEGSUP MIMIK
      MDNOR=IDNORM
      if( ktrace.eq.mdnor) then
        ktrace=-ktrace
        msorse='MDNOR'
      endif
      SEGSUP MDNOR
      MILIGN=IILIGN
      SEGACT MILIGN
      INC=ILIGN(/1)
      DO 1 I=1,INC
      LIGN=ILIGN(I)
      if( ktrace.eq.lign) then
        ktrace=-ktrace
        msorse='LIGN'
      endif
      SEGSUP LIGN
 1    CONTINUE
      if( ktrace.eq.milign) then
        ktrace=-ktrace
        msorse='MILIGN'
      endif
      SEGSUP MILIGN
      if( ktrace.eq.mmatri) then
        ktrace=-ktrace
        msorse='MMATRI'
      endif
      SEGSUP MMATRI
      IF(IPSAUV.NE.0) THEN
         ICOLAC = IPSAUV
         SEGACT ICOLAC
         ILISSE=ILISSG
         SEGACT ILISSE*MOD
         CALL TYPFIL('IMATRI  ',ICO)
         ITLACC = KCOLA(ICO)
         SEGACT ITLACC*MOD
         CALL AJOUN0(ITLACC,MMATRI,ILISSE,iun)
         SEGDES ITLACC
         SEGDES ICOLAC,ILISSE
      ENDIF
C     Suppression du meleme des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('IMATRI  ',ico)
         do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
               segact jcolac
               jlisse=jcolac.ilissg
               segact jlisse*mod
               jtlacc=jcolac.kcola(ico)
               segact jtlacc*mod
               call ajoun0(jtlacc,MMATRI,jlisse,iun)
               segdes jtlacc
               segdes jlisse
               segdes jcolac
            endif
         enddo
         segdes piles
      endif
C
      if( ktrace.eq.msuper) then
        ktrace=-ktrace
        msorse='MSUPER'
      endif
      SEGSUP MSUPER
      RETURN
      END