C DETRUI SOURCE CHAT 12/12/10 21:15:00 7599 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) -INC CCOPTIO -INC SMCOORD -INC SMELEME -INC SMLREEL -INC SMLENTI -INC SMLMOTS -INC TMCOLAC -INC SMTABLE -INC CCASSIS CHARACTER*(8) ICARA,ICARB,typobj,charre logical login,logre,logr1 CHARACTER*4 MOTOUT(2) character*6 msorse SAVE KTRACE data KTRACE /-1/ DATA MOTOUT/'TOUT','TRAC'/ icara=' ' call lirabj(ICARA,iob,1,iretou) IF(IRETOU.EQ.0) THEN CALL ERREUR (533) RETURN ENDIF call refus ith=0 call ooonth(ith) 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,ith) icarb=' ' ICOO=0 IF(IPSAUV.NE.0) THEN ICOLAC=IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD 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) typobj=' ' segact mtable ml=mlotab ind=mtabii(2) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, > xvalre,charre,logr1,id1) if (ierr.ne.0) goto 10000 * if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then if (typobj.eq.'MCHAML')then do i=2,ml segact mtable ind=mtabii(i) call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, > xvalre,charre,logr1,id2) if (ierr.ne.0) goto 10000 * if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou) if (typobj.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 DO 1080 I=1,LISOUS(/1) IPT1=LISOUS(I) msorse='MELEME' if( ktrace.eq.ipt1) ktrace=-ktrace SEGSUP IPT1 IF(IPSAUV.NE.0) CALL AJOUN0(ITLACC,IPT1,ILISSE,1) 1080 CONTINUE 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 MOTERR(1:8)=ICARA CALL ERREUR(168) C L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET DE CE TYPE goto 10000 5000 CONTINUE IF(ith.eq.0.and.ICARB.NE.' ') > CALL NOMOBJ('ANNULE ',ICARB,0) IF( IPSAUV.NE.0.AND.ICOO.NE.0) THEN ITLACC = KCOLA(ICOO) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,IRETI,ILISSE,1) SEGDES ITLACC SEGDES ILISSE SEGDES ICOLAC 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 return END