C DTEVOZ    SOURCE    OF166741  25/02/20    21:16:05     12165          
                SUBROUTINE DTEVOZ(IRET,IRAT,ktrace,msorse)
C
C  =====================================================================
C  =                                                                   =
C  =  DESTRUCTION D'UN OBJET EVOLUTION                                 =
C  =                                                                   =
C  =  IRAT = 0  DESTRUCTION FAIBLE                                     =
C  =       = 1  DESTRUCTION TOTALE                                     =
C  =                                                                   =
C  =  CREATION    06/01/86                                             =
C  =  PROGRAMMEUR GUILBAUD                                             =
C  =                                                                   =
C  =  NB: ON FAIT ATTENTION, LORS D'UNE DESTRUCTION TOTALE, AU CAS OU  =
C  =      DES LISTES D'ABSCISSES SERAIENT IDENTIQUES ET REPRESENTEES   =
C  =      PAR UN MEME "LISTREEL".                                      =
C  =                                                                   =
C  =====================================================================
C
      IMPLICIT INTEGER(I-N)
      character*6 msorse
      integer ICO, IPILE, IPLACE, IRAT, IRET, JG, KTRACE
      integer N,N1,NN

-INC PPARAM
-INC CCOPTIO
-INC COCOLL
-INC SMEVOLL
-INC SMLREEL
-INC SMLENTI
-INC TMCOLAC

      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
      iun=1
      MEVOLL=IRET
      SEGACT MEVOLL
      N=IEVOLL(/1)
      IF (IRAT .EQ. 1) THEN
         JG = N
         SEGINI,MLENTI
      END IF
C
      DO 10 NN=1,N
         KEVOLL=IEVOLL(NN)
         IF(IRAT.EQ.1) THEN
            SEGACT KEVOLL
            LECT(NN) = IPROGX
            N1 = NN - 1
            CALL PLACE2 (LECT,N1,IPLACE,IPROGX)
            IF(IPLACE .EQ. 0) THEN
               MLREEL=IPROGX
               if( ktrace.eq.mlreel) then
                 msorse='MLREEL'
                 ktrace=-ktrace
               endif
               SEGSUP MLREEL
               IF(IPSAUV.NE.0) THEN
                   ICOLAC = IPSAUV
                   SEGACT ICOLAC
                   ILISSE=ILISSG
                   SEGACT ILISSE*MOD
                   CALL TYPFIL('LISTREEL',ICO)
                   ITLACC = KCOLA(ICO)
                   SEGACT ITLACC*MOD
                   CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
                   SEGDES ITLACC
              ENDIF
C              Suppression du listreel des piles d'objets communiques
               if(piComm.gt.0) then
                  piles=piComm
                  segact piles
                  call typfil('LISTREEL',ico)
                  do ipile=1,piles.proc(/1)
                     jcolac= piles.proc(ipile)
                     if(jcolac.ne.0) then
C                       normalement, deja active par detrui
                        segact jcolac
                        jlisse=jcolac.ilissg
C                       normalement, deja active par detrui
                        segact jlisse*mod
                        jtlacc=jcolac.kcola(ico)
                        segact jtlacc*mod
                        call ajoun0(jtlacc,MLREEL,jlisse,iun)
                        segdes jtlacc
                     endif
                  enddo
                  segdes piles
               endif
          ENDIF
            MLREEL=IPROGY
            if( ktrace.eq.mlreel) then
              ktrace=-ktrace
              msorse='MLREEL'
            endif
            SEGSUP MLREEL
               IF(IPSAUV.NE.0) THEN
                   ICOLAC = IPSAUV
                   SEGACT ICOLAC
                   ILISSE = ILISSG
                   SEGACT ILISSE*MOD
                   ITLACC = KCOLA(ICO)
                   SEGACT ITLACC*MOD
                   CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
                   SEGDES ITLACC
              ENDIF
C              Suppression du listreel des piles d'objets communiques
               if(piComm.gt.0) then
                  piles=piComm
                  segact piles
                  do ipile=1,piles.proc(/1)
                     jcolac= piles.proc(ipile)
                     if(jcolac.ne.0) then
C                       normalement, deja active par detrui
                        segact jcolac
                        jlisse=jcolac.ilissg
C                       normalement, deja active par detrui
                        segact jlisse*mod
                        jtlacc=jcolac.kcola(ico)
                        segact jtlacc*mod
                        call ajoun0(jtlacc,MLREEL,jlisse,iun)
                        segdes jtlacc
                     endif
                  enddo
                  segdes piles
               endif
         ENDIF
         SEGSUP KEVOLL
   10 CONTINUE
      if( ktrace.eq.mevoll) then
        msorse='MEVOLL'
        ktrace=-ktrace
      endif
      SEGSUP MEVOLL
      IF (IRAT .EQ. 1)  THEN
            SEGSUP,MLENTI
      ENDIF
      IF(IPSAUV.NE.0) THEN
          CALL TYPFIL('EVOLUTIO',ICO)
          ICOLAC = IPSAUV
          SEGACT ICOLAC
          ILISSE = ILISSG
          SEGACT ILISSE*MOD
          ITLACC = KCOLA(ICO)
          SEGACT ITLACC*MOD
          CALL AJOUN0(ITLACC,MEVOLL,ILISSE,iun)
          SEGDES ITLACC,ILISSE
          SEGDES ICOLAC
      ENDIF
C     Suppression du evol des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('EVOLUTIO',ico)
         do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
C              normalement, deja active par detrui
               segact jcolac
               jlisse=jcolac.ilissg
C              normalement, deja active par detrui
               segact jlisse*mod
               jtlacc=jcolac.kcola(ico)
               segact jtlacc*mod
               call ajoun0(jtlacc,MEVOLL,jlisse,iun)
               segdes jtlacc
            endif
         enddo
         segdes piles
      endif
      RETURN
C
      END