Télécharger la plaquette Cast3M


fr en

Télécharger dtevoz.eso

Retour à la liste

Numérotation des lignes : 

dtevoz

  1. C DTEVOZ    SOURCE    PV        21/01/21    21:15:09     10862          
  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.       character*6 msorse
  22.       integer ICO, IPILE, IPLACE, IRAT, IRET, JG, KTRACE
  23.       integer N,N1,NN
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC COCOLL
  28. -INC SMEVOLL
  29. -INC SMLREEL
  30. -INC SMLENTI
  31. -INC TMCOLAC
  32.  
  33.       pointeur piles.LISPIL
  34.       pointeur jcolac.ICOLAC
  35.       pointeur jlisse.ILISSE
  36.       pointeur jtlacc.ITLACC
  37.       iun=1
  38.       MEVOLL=IRET
  39.       SEGACT MEVOLL
  40.       N=IEVOLL(/1)
  41.       IF (IRAT .EQ. 1) THEN
  42.          JG = N
  43.          SEGINI,MLENTI
  44.       END IF
  45. C
  46.       DO 10 NN=1,N
  47.          KEVOLL=IEVOLL(NN)
  48.          IF(IRAT.EQ.1) THEN
  49.             SEGACT KEVOLL
  50.             LECT(NN) = IPROGX
  51.             N1 = NN - 1
  52.             CALL PLACE2 (LECT,N1,IPLACE,IPROGX)
  53.             IF(IPLACE .EQ. 0) THEN
  54.                MLREEL=IPROGX
  55.                if( ktrace.eq.mlreel) then
  56.                  msorse='MLREEL'
  57.                  ktrace=-ktrace
  58.                endif
  59.                SEGSUP MLREEL
  60.                IF(IPSAUV.NE.0) THEN
  61.                    ICOLAC = IPSAUV
  62.                    SEGACT ICOLAC
  63.                    ILISSE=ILISSG
  64.                    SEGACT ILISSE*MOD
  65.                    CALL TYPFIL('LISTREEL',ICO)
  66.                    ITLACC = KCOLA(ICO)
  67.                    SEGACT ITLACC*MOD
  68.                    CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
  69.                    SEGDES ITLACC
  70.               ENDIF
  71. C              Suppression du listreel des piles d'objets communiques
  72.                if(piComm.gt.0) then
  73.                   piles=piComm
  74.                   segact piles
  75.                   call typfil('LISTREEL',ico)
  76.                   do ipile=1,piles.proc(/1)
  77.                      jcolac= piles.proc(ipile)
  78.                      if(jcolac.ne.0) then
  79. C                       normalement, deja active par detrui
  80.                         segact jcolac
  81.                         jlisse=jcolac.ilissg
  82. C                       normalement, deja active par detrui
  83.                         segact jlisse*mod
  84.                         jtlacc=jcolac.kcola(ico)
  85.                         segact jtlacc*mod
  86.                         call ajoun0(jtlacc,MLREEL,jlisse,iun)
  87.                         segdes jtlacc
  88.                      endif
  89.                   enddo
  90.                   segdes piles
  91.                endif
  92.           ENDIF
  93.             MLREEL=IPROGY
  94.             if( ktrace.eq.mlreel) then
  95.               ktrace=-ktrace
  96.               msorse='MLREEL'
  97.             endif
  98.             SEGSUP MLREEL
  99.                IF(IPSAUV.NE.0) THEN
  100.                    ICOLAC = IPSAUV
  101.                    SEGACT ICOLAC
  102.                    ILISSE = ILISSG
  103.                    SEGACT ILISSE*MOD
  104.                    ITLACC = KCOLA(ICO)
  105.                    SEGACT ITLACC*MOD
  106.                    CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
  107.                    SEGDES ITLACC
  108.               ENDIF
  109. C              Suppression du listreel des piles d'objets communiques
  110.                if(piComm.gt.0) then
  111.                   piles=piComm
  112.                   segact piles
  113.                   do ipile=1,piles.proc(/1)
  114.                      jcolac= piles.proc(ipile)
  115.                      if(jcolac.ne.0) then
  116. C                       normalement, deja active par detrui
  117.                         segact jcolac
  118.                         jlisse=jcolac.ilissg
  119. C                       normalement, deja active par detrui
  120.                         segact jlisse*mod
  121.                         jtlacc=jcolac.kcola(ico)
  122.                         segact jtlacc*mod
  123.                         call ajoun0(jtlacc,MLREEL,jlisse,iun)
  124.                         segdes jtlacc
  125.                      endif
  126.                   enddo
  127.                   segdes piles
  128.                endif
  129.          ENDIF
  130.          SEGSUP KEVOLL
  131.    10 CONTINUE
  132.       if( ktrace.eq.mevoll) then
  133.         msorse='MEVOLL'
  134.         ktrace=-ktrace
  135.       endif
  136.       SEGSUP MEVOLL
  137.       IF (IRAT .EQ. 1)  THEN
  138.             SEGSUP,MLENTI
  139.       ENDIF
  140.       IF(IPSAUV.NE.0) THEN
  141.           CALL TYPFIL('EVOLUTIO',ICO)
  142.           ICOLAC = IPSAUV
  143.           SEGACT ICOLAC
  144.           ILISSE = ILISSG
  145.           SEGACT ILISSE*MOD
  146.           ITLACC = KCOLA(ICO)
  147.           SEGACT ITLACC*MOD
  148.           CALL AJOUN0(ITLACC,MEVOLL,ILISSE,iun)
  149.           SEGDES ITLACC,ILISSE
  150.           SEGDES ICOLAC
  151.       ENDIF
  152. C     Suppression du evol des piles d'objets communiques
  153.       if(piComm.gt.0) then
  154.          piles=piComm
  155.          segact piles
  156.          call typfil('EVOLUTIO',ico)
  157.          do ipile=1,piles.proc(/1)
  158.             jcolac= piles.proc(ipile)
  159.             if(jcolac.ne.0) then
  160. C              normalement, deja active par detrui
  161.                segact jcolac
  162.                jlisse=jcolac.ilissg
  163. C              normalement, deja active par detrui
  164.                segact jlisse*mod
  165.                jtlacc=jcolac.kcola(ico)
  166.                segact jtlacc*mod
  167.                call ajoun0(jtlacc,MEVOLL,jlisse,iun)
  168.                segdes jtlacc
  169.             endif
  170.          enddo
  171.          segdes piles
  172.       endif
  173.       RETURN
  174. C
  175.       END
  176.  
  177.  
  178.  
  179.  
  180.  
  181.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales