Télécharger dtevol.eso

Retour à la liste

Numérotation des lignes :

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

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