C DTSOLZ SOURCE PV 11/03/08 21:15:27 6888 SUBROUTINE DTSOLz(IRET,ktrace,msorse) 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 character*6 msorse LOGICAL LOGII,LOGIR REAL*8 XVALI,XVALR C C ===================================================================== C = DESTRUCTION D'UN OBJET SOLUTION = C = = C = CREATION 06/01/86 = C = PROGRAMMEUR GUILBAUD = C ===================================================================== C -INC CCOPTIO -INC SMSOLUT -INC SMELEME -INC SMTABLE -INC SMLREEL -INC TMCOLAC * 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'/ * MSOLUT=IRET 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 if(ktrace.eq.msolut) then ktrace=-ktrace msorse='MSOLUT' endif 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 if(ktrace.eq.meleme) then ktrace=-ktrace msorse='MELEME' endif 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,1) SEGDES ITLACC,ILISSE SEGDES ICOLAC 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) if(ktrace.eq.mmode) then ktrace=-ktrace msorse='MMODE' endif SEGSUP MMODE 210 CONTINUE ENDIF if(ktrace.eq.msolen) then ktrace=-ktrace msorse='MSOLEN' 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,1) SEGDES ITLACC ENDIF ENDIF IF(KSOLIT.EQ.5) THEN CALL DTCHAz(IRETT,ktrace,msorse) 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,1) SEGDES ITLACC 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 if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MROTP ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,IROTP) MLREEL = IROTP if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MROTD ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,IROTD) MLREEL = IROTD if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL MTABLE = ITABR if(ktrace.eq.mtable) then ktrace=-ktrace msorse='MTABLE' endif SEGSUP MTABLE ITABR = 0 CONTINUE MTABLE = IRRET if(ktrace.eq.mtable) then ktrace=-ktrace msorse='MTABLE' endif 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,1) CALL AJOUN0(ITLACC,IROTP,ILISSE,1) CALL AJOUN0(ITLACC,IROTS,ILISSE,1) SEGDES ITLACC CALL TYPFIL('TABLE ',ICOTB) ITLACC = KCOLA(ICOTB) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,ITABR,ILISSE,1) CALL AJOUN0(ITLACC,IRRET,ILISSE,1) SEGDES ITLACC SEGDES ICOLAC,ILISSE 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 if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MTRAP ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,ITRAP) MLREEL = ITRAP if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL CALL ACCTAB(ITABR,'MOT ', * IVALI,XVALI,MTRAD ,LOGII,KMEL1, * 'LISTREEL', * IVALR,XVALR,ICHARR,LOGIR,ITRAD) MLREEL = ITRAD if(ktrace.eq.mlreel) then ktrace=-ktrace msorse='MLREEL' endif SEGSUP MLREEL MTABLE = ITABR if(ktrace.eq.mtable) then ktrace=-ktrace msorse='MTABLE' endif SEGSUP MTABLE CONTINUE MTABLE = IRRET if(ktrace.eq.mtable) then ktrace=-ktrace msorse='MTABLE' endif 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,1) CALL AJOUN0(ITLACC,ITRAP,ILISSE,1) CALL AJOUN0(ITLACC,ITRAS,ILISSE,1) SEGDES ITLACC ITLACC = KCOLA(ICOTB) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,ITABR,ILISSE,1) CALL AJOUN0(ITLACC,IRRET,ILISSE,1) SEGDES ITLACC SEGDES ICOLAC,ILISSE ENDIF ITABR = 0 IRRET = 0 ENDIF ENDIF ENDIF 220 CONTINUE ENDIF if(ktrace.eq.msolen) then ktrace=-ktrace msorse='MSOLEN' endif SEGSUP MSOLEN ENDIF 230 CONTINUE 1000 CONTINUE RETURN END