1 : C DETRUI SOURCE CHAT 12/12/10 21:15:00 7599 2 : SUBROUTINE DETRUI 3 : C 4 : C **** OPERATEUR DETR : DETRUIT UN OBJET DE TYPE SUIVANT: 5 : C **** CHPOINT,RIGIDITE,MCHAML,LISTREEL,LISTENTI,LISTMOTS,SOLUTION, 6 : C **** EVOLUTIO,ELEMENT,ATTACHE 7 : C 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8(A-H,O-Z) 10 : 11 : -INC CCOPTIO 12 : -INC SMCOORD 13 : -INC SMELEME 14 : -INC SMLREEL 15 : -INC SMLENTI 16 : -INC SMLMOTS 17 : -INC TMCOLAC 18 : -INC SMTABLE 19 : -INC CCASSIS 20 : CHARACTER*(8) ICARA,ICARB,typobj,charre 21 : logical login,logre,logr1 22 : CHARACTER*4 MOTOUT(2) 23 : character*6 msorse 24 : SAVE KTRACE 25 : data KTRACE /-1/ 26 : DATA MOTOUT/'TOUT','TRAC'/ 27 : 28 : icara=' ' 28 : call lirabj(ICARA,iob,1,iretou) 29 : IF(IRETOU.EQ.0) THEN 29 : CALL ERREUR (533) 30 : RETURN 31 : ENDIF 31 : call refus 32 : ith=0 32 : call ooonth(ith) 33 : if(ith.ne.0) then 33 : call erreur (1010) 34 : return 35 : endif 36 : * verif que l'objet n'est pas dans les queues d'execution 37 : if (NBESC.NE.0) then 38 : do ithh=1,nbesc 39 : idet=0 40 : mesins= mescl(ithh) 41 : segact mesins*(mod,ecr=1) 42 : do iins=1,nbins 43 : mescla=lismes(iins) 44 : if (mescla.ne.0) then 45 : segact mescla 46 : do im=1,100 47 : if (.not.esoplu(im)) then 48 : if (esopva(im).eq.iob.and.esopty(im).eq.icara) 49 : > idet=nbins-iins+1 50 : endif 51 : enddo 52 : segdes mescla 53 : else 54 : write (6,*) ' mescla nul iins nbins ithh',iins,nbins,ithh 55 : endif 56 : enddo 57 : if (idet.ne.0) then 58 : * objet en queue d'execution. On attend 59 : 20 if(nbins.ge.idet) then 60 : ** write(6,*)'on attend la fin de l''assistant nbins',ithh,nbins 61 : segdes mesins*record 62 : segact mesins*(mod,ecr=1) 63 : go to 20 64 : endif 65 : endif 66 : segdes mesins*record 67 : enddo 68 : * blocage des assistants en fin d'instruction 69 : mestra=imestr 70 : segact mestra*mod 71 : segdes mestra 72 : endif 73 : * plus rien en attente d'execution. on peut detruire 73 : call ooohor(0,ith) 74 : icarb=' ' 75 : ICOO=0 76 : IF(IPSAUV.NE.0) THEN 77 : ICOLAC=IPSAUV 78 : SEGACT ICOLAC 79 : ILISSE=ILISSG 80 : SEGACT ILISSE*MOD 81 : ENDIF 81 : CALL LIRTAB('ESCLAVE',mtable,0,iretou) 82 : if( iretou.ne.0) then 83 : * tc on prefere ne rien faire! 84 : if(iretou.gt.0) goto 10000 84 : call quenom (icarb) 84 : call typfil ( 'TABLE' ,ICOO) 85 : typobj=' ' 86 : segact mtable 87 : ml=mlotab 88 : ind=mtabii(2) 88 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, 89 : > xvalre,charre,logr1,id1) 90 : if (ierr.ne.0) goto 10000 91 : * if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then 92 : if (typobj.eq.'MCHAML')then 93 : do i=2,ml 94 : segact mtable 95 : ind=mtabii(i) 95 : call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,ivalre, 96 : > xvalre,charre,logr1,id2) 97 : if (ierr.ne.0) goto 10000 97 : * if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou) 97 : if (typobj.eq.'MCHAML') call dtchaZ (id2,ktrace,msorse) 98 : enddo 99 : endif 100 : GOTO 5000 101 : endif 101 : CALL LIRMOT(MOTOUT(2),1,ival,0) 102 : if(ival.eq.1) then 102 : call lirent (ival,1,iretou) 103 : if( ierr.ne.0) goto 10000 104 : ktrace=ival 105 : goto 10000 106 : endif 106 : CALL LIROBJ('CHPOINT',IRET,0,IRETOU) 107 : IF (IRETOU.EQ.1) THEN 108 : IRETI=IRET 108 : CALL TYPFIL('CHPOINT ',ICOO) 108 : if(ith.eq.0) CALL QUENOM (ICARB) 108 : CALL DTCHPZ(IRET,ktrace,msorse) 109 : GO TO 5000 110 : ENDIF 110 : CALL LIROBJ('MCHAML ',IRET,0,IRETOU) 111 : IF (IRETOU.EQ.1) THEN 112 : IRETI=IRET 112 : CALL TYPFIL('MCHAML ',ICOO) 112 : if(ith.eq.0) CALL QUENOM (ICARB) 112 : CALL DTCHAZ(IRET,KTRACE,msorse) 113 : GO TO 5000 114 : ENDIF 114 : CALL LIROBJ('RIGIDITE',IRET,0,IRETOU) 115 : IF (IRETOU.EQ.1) THEN 116 : IRETI=IRET 116 : CALL TYPFIL('RIGIDITE',ICOO) 116 : if(ith.eq.0) CALL QUENOM (ICARB) 116 : CALL DTRIGZ(IRET,KTRACE,msorse) 117 : GO TO 5000 118 : ENDIF 118 : CALL LIROBJ('LISTREEL',IRET,0,IRETOU) 119 : IF (IRETOU.EQ.1) THEN 120 : IRETI=IRET 120 : CALL TYPFIL('LISTREEL',ICOO) 120 : if(ith.eq.0) CALL QUENOM (ICARB) 121 : MLREEL=IRET 122 : msorse='MLREEL' 123 : IF(ktrace.eq.mlreel) ktrace=-ktrace 124 : SEGSUP MLREEL 125 : GO TO 5000 126 : ENDIF 126 : CALL LIROBJ('LISTENTI',IRET,0,IRETOU) 127 : IF (IRETOU.EQ.1) THEN 128 : IRETI=IRET 128 : CALL TYPFIL('LISTENTI',ICOO) 128 : if(ith.eq.0) CALL QUENOM (ICARB) 129 : MLENTI=IRET 130 : msorse='MLENTI' 131 : if(ktrace.eq.mlenti) ktrace=-ktrace 132 : SEGSUP MLENTI 133 : GO TO 5000 134 : ENDIF 134 : CALL LIROBJ('LISTMOTS',IRET,0,IRETOU) 135 : IF (IRETOU.EQ.1) THEN 136 : IRETI=IRET 136 : CALL TYPFIL('LISTMOTS',ICOO) 136 : if(ith.eq.0) CALL QUENOM (ICARB) 137 : MLMOTS=IRET 138 : msorse='MLMOTS' 139 : if(ktrace.eq.mlmots) ktrace=-ktrace 140 : SEGSUP MLMOTS 141 : GO TO 5000 142 : ENDIF 142 : CALL LIROBJ('SOLUTION',IRET,0,IRETOU) 143 : IF (IRETOU.EQ.1) THEN 144 : IRETI=IRET 144 : CALL TYPFIL('SOLUTION',ICOO) 144 : if(ith.eq.0) CALL QUENOM (ICARB) 144 : CALL DTSOLZ(IRET,KTRACE,msorse) 145 : GO TO 5000 146 : ENDIF 146 : CALL LIROBJ('EVOLUTIO',IRET,0,IRETOU) 147 : IF (IRETOU.EQ.1) THEN 147 : CALL TYPFIL('EVOLUTIO',ICOO) 147 : if(ith.eq.0) CALL QUENOM (ICARB) 147 : CALL LIRMOT(MOTOUT,1,IRAT,0) 147 : CALL DTEVOZ(IRET,IRAT,KTRACE,msorse) 148 : GO TO 5000 149 : ENDIF 149 : CALL LIROBJ('MAILLAGE',IRET,0,IRETOU) 150 : IF (IRETOU.EQ.1) THEN 151 : IRETI=IRET 151 : CALL TYPFIL('MAILLAGE',ICOO) 151 : if(ith.eq.0) CALL QUENOM (ICARB) 152 : MELEME=IRET 152 : CALL LIRMOT(MOTOUT,1,IRAT,0) 153 : SEGACT MELEME*MOD 154 : IF(IRAT.EQ.1) THEN 155 : NBSOU=LISOUS(/1) 156 : IF(NBSOU.GT.0) THEN 157 : IF(IPSAUV.NE.0) THEN 158 : ICOLAC = IPSAUV 158 : CALL TYPFIL('MAILLAGE',ICO) 159 : ITLACC = KCOLA(ICO) 160 : SEGACT ITLACC*MOD 161 : ENDIF 162 : DO 1080 I=1,LISOUS(/1) 163 : IPT1=LISOUS(I) 164 : msorse='MELEME' 165 : if( ktrace.eq.ipt1) ktrace=-ktrace 166 : SEGSUP IPT1 166 : IF(IPSAUV.NE.0) CALL AJOUN0(ITLACC,IPT1,ILISSE,1) 167 : 1080 CONTINUE 168 : ENDIF 169 : ENDIF 170 : NBNN=0 171 : NBELEM=0 172 : NBREF=0 173 : NBSOUS=0 174 : ITYPEL=0 175 : SEGADJ MELEME 176 : GO TO 5000 177 : ENDIF 177 : CALL LIROBJ('CONFIGUR',IRET,0,IRETOU) 178 : IF (IRETOU.EQ.1) THEN 179 : IRETI=IRET 179 : CALL TYPFIL('CONFIGUR',ICOO) 179 : if(ith.eq.0) CALL QUENOM (ICARB) 180 : II=MCOORD 181 : MCOORD=IRET 182 : IF(IRET.EQ.II) goto 10000 183 : * SEGSUP MCOORD 184 : segdes mcoord 185 : MCOORD=II 186 : GO TO 5000 187 : ENDIF 187 : CALL LIROBJ('ATTACHE ',IRET,0,IRETOU) 188 : IF (IRETOU.EQ.1) THEN 189 : IRETI=IRET 189 : CALL TYPFIL('ATTACHE ',ICOO) 189 : if(ith.eq.0) CALL QUENOM (ICARB) 189 : CALL DTMATZ(IRET,KTRACE,msorse) 190 : GO TO 5000 191 : ENDIF 191 : CALL LIROBJ('SUPERELE',IRET,0,IRETOU) 192 : IF (IRETOU.EQ.1) THEN 193 : IRETI=IRET 193 : CALL TYPFIL('SUPERELE',ICOO) 193 : if(ith.eq.0) CALL QUENOM (ICARB) 193 : CALL DTSUPZ(IRET,KTRACE,msorse) 194 : GO TO 5000 195 : ENDIF 196 : MOTERR(1:8)=ICARA 196 : CALL ERREUR(168) 197 : C L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET DE CE TYPE 198 : goto 10000 199 : 5000 CONTINUE 200 : IF(ith.eq.0.and.ICARB.NE.' ') 200 : > CALL NOMOBJ('ANNULE ',ICARB,0) 201 : IF( IPSAUV.NE.0.AND.ICOO.NE.0) THEN 202 : ITLACC = KCOLA(ICOO) 203 : SEGACT ITLACC*MOD 203 : CALL AJOUN0(ITLACC,IRETI,ILISSE,1) 204 : SEGDES ITLACC 205 : SEGDES ILISSE 206 : SEGDES ICOLAC 207 : ENDIF 208 : if(ktrace.le.-2) then 209 : ktrace = abs(ktrace) 210 : interr(1)=ktrace 211 : moterr(1:8)=icara 212 : moterr(9:14)=msorse 212 : call erreur (1011) 212 : CALL ANABAC 213 : endif 214 : * liberer les assistants 215 : 10000 continue 216 : return 217 : END 218 : 219 : 220 : 221 : 222 : 223 : 224 : 225 :
© Cast3M 2003 - All rights reserved.
Disclaimer