1 : C DTEVOZ SOURCE CHAT 09/09/21 21:16:30 6511 2 : SUBROUTINE DTEVOZ(IRET,IRAT,ktrace,msorse) 3 : C 4 : C ===================================================================== 5 : C = = 6 : C = DESTRUCTION D'UN OBJET EVOLUTION = 7 : C = = 8 : C = IRAT = 0 DESTRUCTION FAIBLE = 9 : C = = 1 DESTRUCTION TOTALE = 10 : C = = 11 : C = CREATION 06/01/86 = 12 : C = PROGRAMMEUR GUILBAUD = 13 : C = = 14 : C = NB: ON FAIT ATTENTION, LORS D'UNE DESTRUCTION TOTALE, AU CAS OU = 15 : C = DES LISTES D'ABSCISSES SERAIENT IDENTIQUES ET REPRESENTEES = 16 : C = PAR UN MEME "LISTREEL". = 17 : C = = 18 : C ===================================================================== 19 : C 20 : IMPLICIT INTEGER(I-N) 21 : -INC CCOPTIO 22 : -INC SMEVOLL 23 : -INC SMLREEL 24 : -INC SMLENTI 25 : -INC TMCOLAC 26 : character*6 msorse 27 : MEVOLL=IRET 28 : SEGACT MEVOLL 29 : N=IEVOLL(/1) 30 : IF (IRAT .EQ. 1) THEN 31 : JG = N 32 : SEGINI,MLENTI 33 : END IF 34 : C 35 : DO 10 NN=1,N 36 : KEVOLL=IEVOLL(NN) 37 : IF(IRAT.EQ.1) THEN 38 : SEGACT KEVOLL 39 : LECT(NN) = IPROGX 40 : N1 = NN - 1 40 : CALL PLACE2 (LECT,N1,IPLACE,IPROGX) 41 : IF(IPLACE .EQ. 0) THEN 42 : MLREEL=IPROGX 43 : if( ktrace.eq.mlreel) then 44 : msorse='MLREEL' 45 : ktrace=-ktrace 46 : endif 47 : SEGSUP MLREEL 48 : IF(IPSAUV.NE.0) THEN 49 : ICOLAC = IPSAUV 50 : SEGACT ICOLAC 51 : ILISSE=ILISSG 52 : SEGACT ILISSE*MOD 52 : CALL TYPFIL('LISTREEL',ICO) 53 : ITLACC = KCOLA(ICO) 54 : SEGACT ITLACC*MOD 54 : CALL AJOUN0(ITLACC,MLREEL,ILISSE,1) 55 : SEGDES ITLACC 56 : ENDIF 57 : ENDIF 58 : MLREEL=IPROGY 59 : if( ktrace.eq.mlreel) then 60 : ktrace=-ktrace 61 : msorse='MLREEL' 62 : endif 63 : SEGSUP MLREEL 64 : IF(IPSAUV.NE.0) THEN 65 : ICOLAC = IPSAUV 66 : SEGACT ICOLAC 67 : ILISSE = ILISSG 68 : SEGACT ILISSE*MOD 69 : ITLACC = KCOLA(ICO) 70 : SEGACT ITLACC*MOD 70 : CALL AJOUN0(ITLACC,MLREEL,ILISSE,1) 71 : SEGDES ITLACC 72 : ENDIF 73 : ENDIF 74 : SEGSUP KEVOLL 75 : 10 CONTINUE 76 : if( ktrace.eq.mevoll) then 77 : msorse='MEVOLL' 78 : ktrace=-ktrace 79 : endif 80 : SEGSUP MEVOLL 81 : IF (IRAT .EQ. 1) THEN 82 : SEGSUP,MLENTI 83 : ENDIF 84 : IF(IPSAUV.NE.0) THEN 84 : CALL TYPFIL('EVOLUTIO',ICO) 85 : ICOLAC = IPSAUV 86 : SEGACT ICOLAC 87 : ILISSE = ILISSG 88 : SEGACT ILISSE*MOD 89 : ITLACC = KCOLA(ICO) 90 : SEGACT ITLACC*MOD 90 : CALL AJOUN0(ITLACC,MEVOLL,ILISSE,1) 91 : SEGDES ITLACC,ILISSE 92 : SEGDES ICOLAC 93 : ENDIF 94 : RETURN 95 : C 96 : END 97 :
© Cast3M 2003 - All rights reserved.
Disclaimer