C DTRIGZ    SOURCE    PV090527  25/06/24    10:57:51     12300          
               SUBROUTINE DTRIGz(IRET,ktrace,msorse)
C  **** DESTRUCTION DE LA MATRICE SI ELLE EXISTE,DESTRUCTION DU CHAPEAU
C  **** MATRICE: ON DETRUIT TOUT
      IMPLICIT INTEGER(I-N)
      CHARACTER*4 MOMOT(1)
      character*6 msorse
      integer i,ico,idet,ipile,inc,iret,ktrace
      
      LOGICAL ooovp1

-INC PPARAM
-INC CCOPTIO
-INC COCOLL
-INC SMRIGID
-INC SMMATRI
-INC SMELEME
-INC TMCOLAC
-INC TMVECRIG
      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
      segment  ladet(0)
      DATA MOMOT(1)/'ELEM'/
      iun=1
      CALL LIRMOT(MOMOT,1,IDET,0)
      MRIGID=IRET
      segini ladet
*  fabrication de la liste des matrices a detruire
 1010 continue
      segact mrigid
      ladet(**)=mrigid
      if(jrdepp.ne.0) ladet(**)=jrdepp
      if(jrdepd.ne.0) ladet(**)=jrdepd
      if(jrelim.ne.0) ladet(**)=jrelim
      if(jrtot.ne.0) ladet(**)=jrtot
      if(jrgard.ne.0) ladet(**)=jrgard
      if (jrcond.ne.0) then
        mrigid=jrcond
        goto 1010
      endif
**    write(6,*) ' nb matrice a detruire ',ladet(/1)
      do 1000 ir=1,ladet(/1)
      mrigid=ladet(ir)
      SEGACT MRIGID*mod
      IF(IIMPI.ne.0) WRITE(IOIMP,10) ICHOLE
   10 FORMAT('  ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
     1 I5)
      IF(ICHOLE.EQ.0) GOTO 2
C
C  **** DESTRUCTION DE LA MATRICE
      MMATRI=ICHOLE
      SEGACT MMATRI
      MDIAG=IDIAG
      if(ktrace.eq.mdiag) then
        ktrace=-ktrace
        msorse='MDIAG'
      endif
      SEGSUP MDIAG
      MELEME=IGEOMA
      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,ILISSE
*        SEGDES ICOLAC
      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
***   SEGSUP MELEME
      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
*  la partie non symetrique eventuellement
      MILIGN=IILIGS
***   write(6,*) 'iiligs dans dtrigz ',iiligs
      IF(milign.ne.0) then
      SEGACT MILIGN
      INC=ILIGN(/1)
      DO 6 I=1,INC
      LIGN=ILIGN(I)
      if(ktrace.eq.lign) then
        ktrace=-ktrace
        msorse='LIGN'
      endif
      SEGSUP LIGN
 6    CONTINUE
      if(ktrace.eq.milign)  then
        ktrace=-ktrace
        msorse='MILIGN'
      endif
      SEGSUP MILIGN
      endif
      if(ktrace.eq.mmatri) then
        ktrace=-ktrace
        msorse='MMATRI'
      endif
      SEGSUP MMATRI
C
C  **** DESTRUCTION DU CHAPEAU
 2    CONTINUE
C
CCCCCCCCCCCCC  SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
C              ELEMENTAIRES
      IF(IMGEO1.NE.0) THEN
              IMGEOD=IMGEO1
              SEGSUP IMGEOD
              IMGEO1 = 0
              if(ktrace.eq.imgeo1) then
                ktrace=-ktrace
                msorse='IMGEOD'
              endif
      ENDIF
      IF(ivecri.ne.0) then
            mvecri=ivecri
            segsup mvecri
            ivecri=0
            if(ktrace.eq.ivecri) then
                ktrace=-ktrace
                msorse='IVECRI'
            endif
      ENDIF
      IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE)
*  si type temporaire, destruction du xmatri du descr et du meleme
      if (mtymat.eq.'TEMPORAI') then
        do iri=1,irigel(/2)
**       meleme=irigel(1,iri)
**       call ooove1(lret,meleme)
**       if (lret.eq.2) segsup meleme
**       descr=irigel(3,iri)
**       call ooove1(lret,descr)
**       if (lret.eq.2) segsup descr
**       xmatri=irigel(4,iri)
**       call ooove1(lret,xmatri)
***      if (lret.eq.2) segsup xmatri
        enddo
      endif
*     if(imlag.ne.0) then
*        meleme=imlag
*  probleme avec imlag, mais de toute facon ce n'est normalement pas gros
***     segsup meleme
*     endif
      IF(ooovp1(mrigid)) THEN
        if(ktrace.eq.mrigid) then
          ktrace=-ktrace
          msorse='MRIGID'
        endif
        nrigel=irigel(/2)
        segadj mrigid
        ichole=0
        IMGEO1 = 0
        ivecri=0
      ENDIF

 1000 continue
      segsup ladet
      IRET=0
      RETURN
      END