Télécharger dtevoz.eso

Retour à la liste

Numérotation des lignes :

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

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