C DETRUI    SOURCE    PASCAL    22/06/10    21:15:02     11377          
      SUBROUTINE DETRUI
C
C  **** OPERATEUR DETR : DETRUIT UN OBJET DE TYPE SUIVANT:
C  **** CHPOINT,RIGIDITE,MCHAML,LISTREEL,LISTENTI,LISTMOTS,SOLUTION,
C  **** EVOLUTIO,ELEMENT,ATTACHE
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      character*(8) icara,typob1,charre
      integer i,ico, icoo, id1, id2, idet, ii, iins, im
      integer ind, iob, ipile, irat, iret, ireti, iretou
      integer ith, ithh, ival, ivalre, ktrace, ml
      integer nbelem,nbnn, nbref, nbsou, nbsous
      real*8 xvalre
      logical logr1
      character*4 motout(2)
      character*6 msorse
      save ktrace


-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-INC COCOLL
-INC CCASSIS
-INC SMCOORD
-INC SMELEME
-INC SMLREEL
-INC SMLENTI
-INC SMLMOTS
-INC TMCOLAC
-INC SMTABLE
-INC SMLOBJE

      character*(LONOM) icarb

      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC

      data KTRACE /-1/
      DATA MOTOUT/'TOUT','TRAC'/

      iun=1
      icara=' '
      call lirabj(ICARA,iob,1,iretou)
      IF(IRETOU.EQ.0) THEN
         CALL ERREUR (533)
         RETURN
      ENDIF
      call refus
      ith=0
      ith=oothrd
      if(ith.ne.0) then
          call erreur (1010)
          return
      endif
*  verif que l'objet n'est pas dans les queues d'execution
      if (NBESC.NE.0) then
         do ithh=1,nbesc
            idet=0
            mesins= mescl(ithh)
            segact mesins*(mod,ecr=1)
            do iins=1,nbins
               mescla=lismes(iins)
               if (mescla.ne.0) then
                  segact mescla
                  do im=1,100
                     if (.not.esoplu(im)) then
                        if (esopva(im).eq.iob.and.esopty(im).eq.icara)
     >                     idet=nbins-iins+1
                     endif
                  enddo
                  segdes mescla
               else
               write(6,*) ' mescla nul iins nbins ithh',iins,nbins,ithh
               endif
            enddo
            if (idet.ne.0) then
* objet en queue d'execution. On attend
20             if(nbins.ge.idet) then
**         write(6,*)'on attend la fin de l''assistant nbins',ithh,nbins
                  segdes mesins*record
                  segact mesins*(mod,ecr=1)
                  go to 20
               endif
            endif
            segdes mesins*record
         enddo
*  blocage des assistants en fin d'instruction
         mestra=imestr
         segact mestra*mod
         segdes mestra
      endif
*  plus rien en attente d'execution. on peut detruire
      call ooohor(0)
      icarb=' '
      ICOO=0
      IF(IPSAUV.NE.0) THEN
         ICOLAC=IPSAUV
         SEGACT ICOLAC
         ILISSE=ILISSG
         SEGACT ILISSE*MOD
      ENDIF
C     Activation des piles de communication si elles existent
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         do ipile=1,piles.proc(/1)
         jcolac= piles.proc(ipile)
         if(jcolac.ne.0) then
            segact jcolac
            jlisse=jcolac.ilissg
            segact jlisse*mod
         endif
         enddo
      endif

      CALL LIRTAB('ESCLAVE',mtable,0,iretou)
      if( iretou.ne.0) then
* tc on prefere ne rien faire!
         if(iretou.gt.0) goto 10000
         call quenom (icarb)
         call typfil ( 'TABLE' ,ICOO)
         typob1=' '
         segact mtable
         ml=mlotab
         ind=mtabii(2)
         call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typob1,
     >    ivalre,xvalre,charre,logr1,id1)
         if (ierr.ne.0) goto 10000
*        if (typob1.eq.'CHPOINT'.or.typob1.eq.'MCHAML')then
         if (typob1.eq.'MCHAML')then
            do i=2,ml
            segact mtable
            ind=mtabii(i)
            call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
     >      typob1,ivalre,xvalre,charre,logr1,id2)
            if (ierr.ne.0) goto 10000
*            if (typob1.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
            if (typob1.eq.'MCHAML') call dtchaZ (id2,ktrace,msorse)
            enddo
         endif
         GOTO 5000
      endif
      CALL LIRMOT(MOTOUT(2),1,ival,0)
      if(ival.eq.1) then
         call lirent (ival,1,iretou)
         if( ierr.ne.0) goto 10000
         ktrace=ival
         goto 10000
      endif
      CALL LIROBJ('CHPOINT',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('CHPOINT ',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTCHPZ(IRET,ktrace,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('MCHAML  ',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('MCHAML  ',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTCHAZ(IRET,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('RIGIDITE',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('RIGIDITE',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTRIGZ(IRET,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('LISTREEL',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('LISTREEL',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         MLREEL=IRET
         msorse='MLREEL'
         IF(ktrace.eq.mlreel) ktrace=-ktrace
         SEGSUP MLREEL
         GO TO 5000
      ENDIF
      CALL LIROBJ('LISTENTI',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('LISTENTI',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         MLENTI=IRET
         msorse='MLENTI'
         if(ktrace.eq.mlenti) ktrace=-ktrace
         SEGSUP MLENTI
         GO TO 5000
      ENDIF
      CALL LIROBJ('LISTMOTS',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('LISTMOTS',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         MLMOTS=IRET
         msorse='MLMOTS'
         if(ktrace.eq.mlmots) ktrace=-ktrace
         SEGSUP MLMOTS
         GO TO 5000
      ENDIF
      CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('SOLUTION',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTSOLZ(IRET,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('EVOLUTIO',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         CALL TYPFIL('EVOLUTIO',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL LIRMOT(MOTOUT,1,IRAT,0)
         CALL DTEVOZ(IRET,IRAT,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('MAILLAGE',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('MAILLAGE',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         MELEME=IRET
         CALL LIRMOT(MOTOUT,1,IRAT,0)
         SEGACT MELEME*MOD
         IF(IRAT.EQ.1) THEN
            NBSOU=LISOUS(/1)
            IF(NBSOU.GT.0) THEN
               IF(IPSAUV.NE.0) THEN
                  ICOLAC = IPSAUV
                  CALL TYPFIL('MAILLAGE',ICO)
                  ITLACC = KCOLA(ICO)
                  SEGACT ITLACC*MOD
               ENDIF
               if(piComm.gt.0) then
                  CALL TYPFIL('MAILLAGE',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
                  endif
                  enddo
               endif

               DO 1080 I=1,LISOUS(/1)
                  IPT1=LISOUS(I)
                  msorse='MELEME'
                  if( ktrace.eq.ipt1) ktrace=-ktrace
                  SEGSUP IPT1
                  IF(IPSAUV.NE.0) then
                     CALL AJOUN0(ITLACC,IPT1,ILISSE,iun)
                     segdes ITLACC
                  endif
C       Suppression du maillage des piles d'objets communiques
                  if(piComm.gt.0) then
                     do ipile=1,piles.proc(/1)
                        jcolac= piles.proc(ipile)
                        if(jcolac.ne.0) then
                           jlisse=jcolac.ilissg
                           jtlacc=jcolac.kcola(ico)
                           call ajoun0(jtlacc,IPT1,jlisse,iun)
                           segdes jtlacc
                        endif
                     enddo
                  endif
1080           CONTINUE
               IF(IPSAUV.NE.0) THEN
                  SEGDES ITLACC
               ENDIF
               if(piComm.gt.0) then
                  do ipile=1,piles.proc(/1)
                  jcolac= piles.proc(ipile)
                  if(jcolac.ne.0) then
                     jlisse=jcolac.ilissg
                     jtlacc=jcolac.kcola(ico)
                     segdes jtlacc
                  endif
                  enddo
               endif

            ENDIF
         ENDIF
         NBNN=0
         NBELEM=0
         NBREF=0
         NBSOUS=0
         ITYPEL=0
         SEGADJ MELEME
         GO TO 5000
      ENDIF
      CALL LIROBJ('CONFIGUR',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('CONFIGUR',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         II=MCOORD
         MCOORD=IRET
         IF(IRET.EQ.II) goto 10000
*        SEGSUP MCOORD
         segdes mcoord
         MCOORD=II
         GO TO 5000
      ENDIF
      CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('ATTACHE ',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTMATZ(IRET,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('SUPERELE',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('SUPERELE',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         CALL DTSUPZ(IRET,KTRACE,msorse)
         GO TO 5000
      ENDIF
      CALL LIROBJ('LISTOBJE',IRET,0,IRETOU)
      IF (IRETOU.EQ.1) THEN
         IRETI=IRET
         CALL TYPFIL('LISTOBJE',ICOO)
         if(ith.eq.0) CALL QUENOM (ICARB)
         MLOBJE=IRET
         msorse='MLOBJE'
         if (ktrace.eq.mlobje) ktrace=-ktrace
         SEGSUP, MLOBJE
         GO TO 5000
      ENDIF

C     L OPERATEUR DETRUIRE IGNORE LES AUTRE TYPES LUS (ENTIER, etc.)
      GOTO 10000

 5000 CONTINUE
      IF(ith.eq.0.and.ICARB.NE.'        ')
     >      CALL NOMOBJ('ANNULE  ',ICARB,0)
      IF( IPSAUV.NE.0) THEN
         IF(ICOO.NE.0) THEN
            ITLACC = KCOLA(ICOO)
            SEGACT ITLACC*MOD
            CALL AJOUN0(ITLACC,IRETI,ILISSE,iun)
            SEGDES ITLACC
         ENDIF
      ENDIF
C     Desactivation des piles de communication si elles existent
      if(piComm.gt.0) then
         if(icoo.ne.0) then
            do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
               jlisse=jcolac.ilissg
               jtlacc=jcolac.kcola(icoo)
               segact jtlacc*mod
               call ajoun0(jtlacc,ireti,jlisse,iun)
               segdes jtlacc
            endif
            enddo
         endif
      endif
      if(ktrace.le.-2) then
         ktrace = abs(ktrace)
         interr(1)=ktrace
         moterr(1:8)=icara
         moterr(9:14)=msorse
         call erreur (1011)
         CALL ANABAC
      endif
*  liberer les assistants
10000 continue
      IF( IPSAUV.NE.0) THEN
         SEGDES ILISSE,ICOLAC
      ENDIF
C     Desactivation des piles de communication si elles existent
      if(piComm.gt.0) then
        do ipile=1,piles.proc(/1)
          jcolac= piles.proc(ipile)
          if(jcolac.ne.0) then
            jlisse=jcolac.ilissg
            segdes jlisse,jcolac
          endif
        enddo
        segdes piles
      endif

      END