Télécharger menag7.eso

Retour à la liste

Numérotation des lignes :

  1. C MENAG7 SOURCE PV 17/12/05 21:16:51 9646
  2. SUBROUTINE MENAG7(icolac,jcolac)
  3. C
  4. C elimine des itlac deja sauves ceux qui n'existent plus
  5. C
  6. implicit integer(i-n)
  7. integer i, ifi, ifi1, ima, j, k
  8. integer jcolac
  9. integer lsf, nitlac, nliss1
  10. -INC CCOPTIO
  11. -INC TMCOLAC
  12. segment iliss1
  13. integer ilise1(nliss1)
  14. endsegment
  15. if(jcolac.eq.0) return
  16. C call imppil ( ipsauv,0)
  17. * call imppil (jcolac,0)
  18. icola1=jcolac
  19. segact icolac
  20. C write(6,*) "jcolac",jcolac
  21.  
  22. segact icola1
  23. ilisse=icola1.ilissg
  24. C write(6,*) "ilisse",ilisse
  25. segact ilisse*mod
  26. nitlac=icola1.kcola(/1)
  27. nliss1=0
  28. segini iliss1
  29. do 1 k=1,nitlac
  30. if(k.ge.24.and.k.le.28) go to 1
  31. if(k.eq.32) go to 1
  32. if(k.eq.36) go to 1
  33. itlac1=icola1.kcola(k)
  34. itlacc=kcola(k)
  35. segact itlac1*mod
  36. segact itlacc
  37. ifi= itlac(/1)
  38. ifi1=itlac1.itlac(/1)
  39. if( ifi1.eq.0) go to 10
  40. * write (6,*) 'ifi*ifi1 ',ifi,ifi1,ifi*ifi1
  41. lsf=0
  42. * if (ifi*ifi1.gt.65535) then
  43. if (ifi*ifi1.gt.16384) then
  44. lsf=1
  45. do 31 i=1,ifi
  46. ima=itlac(i)
  47. if (ima.gt.nliss1) then
  48. nliss1=ima*1.2
  49. segadj iliss1
  50. endif
  51. ilise1(ima)=i
  52. 31 continue
  53. else
  54. lsf=0
  55. endif
  56. * if(k.eq.41) write(6,*) 'menag7 traitement pile',k,ifi,ifi1
  57. do 2 i=1,ifi1
  58. ima = itlac1.itlac(i)
  59. if(ima.eq.0) go to 2
  60. if (lsf.eq.0) then
  61. do 3 j=1,ifi
  62. if(ima.eq.itlac(j)) go to 2
  63. 3 continue
  64. else
  65. if (ima.le.ilise1(/1)) then
  66. j=ilise1(ima)
  67. if (j.ne.0) then
  68. if(ima.eq.itlac(j)) go to 2
  69. endif
  70. endif
  71. endif
  72. * write(6,*) ' suppression de ',ima
  73. itlac1.itlac(i)=0
  74. iliseg(((ima-1)/npgcd))=0
  75. 2 continue
  76. 10 continue
  77. segdes itlacc,itlac1
  78. 1 continue
  79. segsup iliss1
  80. segdes icola1,icolac,ilisse
  81. return
  82. END
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  
  94.  
  95.  
  96.  

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