Télécharger dtevol.eso

Retour à la liste

dtevol
C DTEVOL    SOURCE    PV        21/01/21    21:15:08     10862          
      SUBROUTINE DTEVOL(IRET,IRAT)
C
C  =====================================================================
C  =                                                                   =
C  =  DESTRUCTION D'UN OBJET EVOLUTION                                 =
C  =                                                                   =
C  =  IRAT = 0  DESTRUCTION FAIBLE                                     =
C  =       = 1  DESTRUCTION TOTALE                                     =
C  =                                                                   =
C  =  CREATION    06/01/86                                             =
C  =  PROGRAMMEUR GUILBAUD                                             =
C  =                                                                   =
C  =  NB: ON FAIT ATTENTION, LORS D'UNE DESTRUCTION TOTALE, AU CAS OU  =
C  =      DES LISTES D'ABSCISSES SERAIENT IDENTIQUES ET REPRESENTEES   =
C  =      PAR UN MEME "LISTREEL".                                      =
C  =                                                                   =
C  =====================================================================
C
      IMPLICIT INTEGER(I-N)
      integer ICO, IPILE, IPLACE, IRAT, IRET, JG, N, N1, NN
 
-INC PPARAM
-INC CCOPTIO
-INC COCOLL
-INC SMEVOLL
-INC SMLREEL
-INC SMLENTI
-INC TMCOLAC
 
      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
      iun=1
      MEVOLL=IRET
      SEGACT MEVOLL
      N=IEVOLL(/1)
      IF (IRAT .EQ. 1) THEN
         JG = N
         SEGINI,MLENTI
      END IF
C
      DO 10 NN=1,N
         KEVOLL=IEVOLL(NN)
         IF(IRAT.EQ.1) THEN
            SEGACT KEVOLL
            LECT(NN) = IPROGX
            N1 = NN - 1
            CALL PLACE2 (LECT,N1,IPLACE,IPROGX)
            IF(IPLACE .EQ. 0) THEN
               MLREEL=IPROGX
               SEGSUP MLREEL
               IF(IPSAUV.NE.0) THEN
                   ICOLAC = IPSAUV
                   SEGACT ICOLAC
                   ILISSE=ILISSG
                   SEGACT ILISSE*MOD
                   CALL TYPFIL('LISTREEL',ICO)
                   ITLACC = KCOLA(ICO)
                   SEGACT ITLACC*MOD
                   CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
                   SEGDES ITLACC
              ENDIF
C              Suppression du listreel 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
C                       normalement, deja active par detrui
                        segact jcolac
                        jlisse=jcolac.ilissg
C                       normalement, deja active par detrui
                        segact jlisse*mod
                        jtlacc=jcolac.kcola(ico)
                        segact jtlacc*mod
                        call ajoun0(jtlacc,MLREEL,jlisse,iun)
                        segdes jtlacc
                     endif
                  enddo
                  segdes piles
               endif
          ENDIF
            MLREEL=IPROGY
            SEGSUP MLREEL
               IF(IPSAUV.NE.0) THEN
                   ICOLAC = IPSAUV
                   SEGACT ICOLAC
                   ILISSE = ILISSG
                   SEGACT ILISSE*MOD
                   ITLACC = KCOLA(ICO)
                   SEGACT ITLACC*MOD
                   CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
                   SEGDES ITLACC
              ENDIF
C              Suppression du listreel des piles d'objets communiques
               if(piComm.gt.0) then
                  piles=piComm
                  segact piles
                  do ipile=1,piles.proc(/1)
                     jcolac= piles.proc(ipile)
                     if(jcolac.ne.0) then
C                       normalement, deja active par detrui
                        segact jcolac
                        jlisse=jcolac.ilissg
C                       normalement, deja active par detrui
                        segact jlisse*mod
                        jtlacc=jcolac.kcola(ico)
                        segact jtlacc*mod
                        call ajoun0(jtlacc,MLREEL,jlisse,iun)
                        segdes jtlacc
                     endif
                  enddo
                  segdes piles
               endif
         ENDIF
         SEGSUP KEVOLL
   10 CONTINUE
      SEGSUP MEVOLL
      IF (IRAT .EQ. 1)  THEN
            SEGSUP,MLENTI
      ENDIF
      IF(IPSAUV.NE.0) THEN
          CALL TYPFIL('EVOLUTIO',ICO)
          ICOLAC = IPSAUV
          SEGACT ICOLAC
          ILISSE = ILISSG
          SEGACT ILISSE*MOD
          ITLACC = KCOLA(ICO)
          SEGACT ITLACC*MOD
          CALL AJOUN0(ITLACC,MEVOLL,ILISSE,iun)
          SEGDES ITLACC,ILISSE
          SEGDES ICOLAC
      ENDIF
C     Suppression du evol des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('EVOLUTIO',ico)
         do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
C              normalement, deja active par detrui
               segact jcolac
               jlisse=jcolac.ilissg
C              normalement, deja active par detrui
               segact jlisse*mod
               jtlacc=jcolac.kcola(ico)
               segact jtlacc*mod
               call ajoun0(jtlacc,MEVOLL,jlisse,iun)
               segdes jtlacc
               segdes jlisse
               segdes jcolac
            endif
         enddo
         segdes piles
      endif
C
      END
 
 
 
 
 
 
 
 
 
 
 

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