C DTSOLU SOURCE PV 21/01/21 21:15:12 10862 SUBROUTINE DTSOLU(IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) character*19 mrota , mrotp character*24 mrots character*22 mtran , mtrap character*27 mtras character*1 ichari,mrotd,mtrad,icharr logical logii,logir integer ico, icoch, icolr, icotb integer ipile, iret, irett, irret integer irotd, irotp, irots integer itabr, itrad, itrap, itras integer itys, ivali, ivalr, kmel1, ksolit integer n, nip, nipo, nn real*8 xvali, xvalr C C ===================================================================== C = DESTRUCTION D'UN OBJET SOLUTION = C = = C = CREATION 06/01/86 = C = PROGRAMMEUR GUILBAUD = C ===================================================================== C -INC PPARAM -INC CCOPTIO -INC COCOLL -INC SMSOLUT -INC SMELEME -INC SMTABLE -INC SMLREEL -INC TMCOLAC pointeur piles.LISPIL pointeur jcolac.ICOLAC pointeur jlisse.ILISSE pointeur jtlacc.ITLACC pointeur pile.ITLACC * DATA MROTA/'ROTATION D ENSEMBLE'/ DATA MROTP/'VITESSE DE ROTATION'/ DATA MROTS/'ACCELERATION DE ROTATION'/ DATA MTRAN/'TRANSLATION D ENSEMBLE'/ DATA MTRAP/'VITESSE DE TRANSLATION'/ DATA MTRAS/'ACCELERATION DE TRANSLATION'/ * iun=1 MSOLUT=IRET irret=0 SEGACT MSOLUT ITYS=0 IF(ITYSOL.NE.'MODE ') GO TO 101 ITYS=1 GO TO 200 101 CONTINUE IF(ITYSOL.NE.'SOLUSTAT'.AND.ITYSOL.NE.'PSEUMODE') GO TO 102 ITYS=2 GOTO 200 102 CONTINUE IF(ITYSOL.NE.'DYNAMIQU') GOTO 103 ITYS=3 GO TO 200 103 MOTERR(1:8)='SOLUTION' MOTERR(9:16)=ITYSOL CALL ERREUR(66) C L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET SOLUTION C COMPORTANT CE SOUS-TYPE SEGDES MSOLUT GOTO 1000 200 NIPO=MSOLIS(/1) MSOLRE=MSOLIS(1) IF(MSOLRE.NE.0) SEGSUP MSOLRE MSOLEN=MSOLIS(2) IF(MSOLEN.NE.0) SEGSUP MSOLEN MELEME=MSOLIS(3) IF(MELEME.NE.0.AND.ITYS.EQ.1) THEN SEGSUP MELEME 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 ENDIF MSOLEN=MSOLIS(4) IF(MSOLEN.NE.0) THEN SEGACT MSOLEN N=ISOLEN(/1) IF(N.NE.0) THEN DO 210 NN=1,N MMODE=ISOLEN(NN) SEGSUP MMODE 210 CONTINUE ENDIF SEGSUP MSOLEN ENDIF DO 230 NIP=5,NIPO MSOLEN=MSOLIS(NIP) IF(MSOLEN.NE.0) THEN SEGACT MSOLEN N=ISOLEN(/1) IF(N.NE.0) THEN KSOLIT=MSOLIT(NIP) DO 220 NN=1,N IRETT=ISOLEN(NN) IF(IRETT.NE.0) THEN IF(KSOLIT.EQ.2) THEN CALL DTCHPO(IRETT) IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD CALL TYPFIL('CHPOINT',ICOCH) ITLACC = KCOLA(ICOCH) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,IRETT,ILISSE,iun) SEGDES ITLACC ENDIF C Suppression du CHPOINT des piles d'objets communiques if(piComm.gt.0) then piles=piComm segact piles call typfil('CHPOINT',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,IRETT,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif ENDIF IF(KSOLIT.EQ.5) THEN CALL DTCHAM(IRETT) IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD CALL TYPFIL('MCHAML ',ICOCH) ITLACC = KCOLA(ICOCH) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,IRETT,ILISSE,iun) SEGDES ITLACC ENDIF C Suppression du MCHAML des piles d'objets communiques if(piComm.gt.0) then piles=piComm segact piles call typfil('MCHAML ',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,IRETT,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif ENDIF IF ( MSOLIT.EQ.10 ) THEN KMEL1 = MSOLIS(3) IF ( NIP.EQ.11 ) THEN CALL ACCTAB(IRRET,'MAILLAGE', * IVALI,XVALI,ICHARI,LOGII,KMEL1, * 'TABLE ', * IVALR,XVALR,ICHARR,LOGIR,ITABR) CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MROTS ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,IROTS) MLREEL = IROTS SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MROTP ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,IROTP) MLREEL = IROTP SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MROTD ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,IROTD) MLREEL = IROTD SEGSUP MLREEL MTABLE = ITABR SEGSUP MTABLE ITABR = 0 CONTINUE MTABLE = IRRET SEGSUP MTABLE IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD CALL TYPFIL('LISTREEL',ICOLR) ITLACC = KCOLA(ICOLR) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,IROTD,ILISSE,iun) CALL AJOUN0(ITLACC,IROTP,ILISSE,iun) CALL AJOUN0(ITLACC,IROTS,ILISSE,iun) SEGDES ITLACC CALL TYPFIL('TABLE ',ICOTB) ITLACC = KCOLA(ICOTB) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,ITABR,ILISSE,iun) CALL AJOUN0(ITLACC,IRRET,ILISSE,iun) SEGDES ITLACC SEGDES ICOLAC,ILISSE ENDIF C Suppression du list reel et table 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 segact jcolac jlisse=jcolac.ilissg segact jlisse*mod jtlacc=jcolac.kcola(ico) segact jtlacc*mod call ajoun0(jtlacc,IROTD,jlisse,iun) call ajoun0(jtlacc,IROTP,jlisse,iun) call ajoun0(jtlacc,IROTS,jlisse,iun) segdes jtlacc endif enddo call typfil('TABLE ',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 call ajoun0(jtlacc,ITABR,jlisse,iun) call ajoun0(jtlacc,IRRET,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif IRRET = 0 ELSE IF ( NIP.EQ.12 ) THEN CALL ACCTAB(IRRET,'MAILLAGE', * IVALI,XVALI,ICHARI,LOGII,KMEL1, * 'TABLE ', * IVALR,XVALR,ICHARR,LOGIR,ITABR) CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MTRAS ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,ITRAS) MLREEL = ITRAS SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MTRAP ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,ITRAP) MLREEL = ITRAP SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MTRAD ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,ITRAD) MLREEL = ITRAD SEGSUP MLREEL MTABLE = ITABR SEGSUP MTABLE CONTINUE MTABLE = IRRET SEGSUP MTABLE IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD ITLACC = KCOLA(ICOLR) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,ITRAD,ILISSE,iun) CALL AJOUN0(ITLACC,ITRAP,ILISSE,iun) CALL AJOUN0(ITLACC,ITRAS,ILISSE,iun) SEGDES ITLACC ITLACC = KCOLA(ICOTB) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,ITABR,ILISSE,iun) CALL AJOUN0(ITLACC,IRRET,ILISSE,iun) SEGDES ITLACC SEGDES ICOLAC,ILISSE ENDIF C Suppression du list reel et table 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 segact jcolac jlisse=jcolac.ilissg segact jlisse*mod jtlacc=jcolac.kcola(ico) segact jtlacc*mod call ajoun0(jtlacc,ITRAD,jlisse,iun) call ajoun0(jtlacc,ITRAP,jlisse,iun) call ajoun0(jtlacc,ITRAS,jlisse,iun) segdes jtlacc endif enddo call typfil('TABLE ',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 call ajoun0(jtlacc,ITABR,jlisse,iun) call ajoun0(jtlacc,IRRET,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif ITABR = 0 IRRET = 0 ENDIF ENDIF ENDIF 220 CONTINUE ENDIF SEGSUP MSOLEN ENDIF 230 CONTINUE 1000 CONTINUE RETURN END