Esope source files

   1 : C MENAG7    SOURCE    PV        10/06/15    21:15:21     6692           
   2 :       SUBROUTINE MENAG7(ICOLAC)
   3 : C
   4 : C elimine des itlac deja sauves ceux qui n'existent plus
   5 : C
   6 :       IMPLICIT INTEGER(I-N)
   7 : -INC CCOPTIO
   8 : -INC TMCOLAC
   9 :       segment iliss1
  10 :        integer ilise1(nliss1)
  11 :       endsegment
  12 :       IF(IPSAUV.EQ.0) RETURN
  12 : C      call imppil ( ipsauv,0)
  12 : C      call imppil (icolac,0)
  13 :        ICOLA1=IPSAUV
  14 :        SEGACT ICOLAC,ICOLA1
  15 :        ILISSE=ICOLA1.ILISSG
  16 :        SEGACT ILISSE*MOD
  17 :       NITLAC=ICOLA1.KCOLA(/1)
  18 :       nliss1=0
  19 :       segini iliss1
  20 :       DO 1 K=1,NITLAC
  21 :       IF(K.GE.24.AND.K.LE.28) GO TO 1
  22 :       IF(K.EQ.32) GO TO 1
  23 :       IF(K.EQ.36) GO TO 1
  24 :       ITLAC1=ICOLA1.KCOLA(K)
  25 :       ITLACC=KCOLA(K)
  26 :       SEGACT ITLAC1*MOD
  27 :       SEGACT ITLACC
  28 :       IFI= ITLAC(/1)
  29 :       IFI1=ITLAC1.ITLAC(/1)
  30 :       IF( IFI1.EQ.0) GO TO 10
  31 : *     write (6,*) 'ifi*ifi1 ',ifi,ifi1,ifi*ifi1
  32 :       lsf=0
  33 : *     if (ifi*ifi1.gt.65535) then
  34 :       if (ifi*ifi1.gt.16384) then
  35 :        lsf=1
  36 :        do 31 i=1,ifi
  37 :         ima=itlac(i)
  38 :         if (ima.gt.nliss1) then
  39 :          nliss1=ima*1.2
  40 :          segadj iliss1
  41 :         endif
  42 :         ilise1(ima)=i
  43 :   31   continue
  44 :        else
  45 :         lsf=0
  46 :        endif
  47 : *       if(K.eq.41) write(6,*) 'menag7 traitement pile',K,ifi,ifi1
  48 :       DO 2 I=1,IFI1
  49 :        IMA = ITLAC1.ITLAC(I)
  50 :        IF(IMA.EQ.0) go to 2
  51 :       if (lsf.eq.0) then
  52 :       DO 3 J=1,IFI
  53 :        IF(IMA.EQ.ITLAC(J)) GO TO 2
  54 :    3  CONTINUE
  55 :       else
  56 :        if (ima.le.ilise1(/1)) then
  57 :         j=ilise1(ima)
  58 :         if (j.ne.0) then
  59 :          IF(IMA.EQ.ITLAC(J)) GO TO 2
  60 :         endif
  61 :        endif
  62 :       endif
  63 : *      write(6,*) ' suppression de ',IMA
  64 :        ITLAC1.ITLAC(I)=0
  65 :       ILISEG(((IMA-1)/npgcd))=0
  66 :     2 CONTINUE
  67 :    10 CONTINUE
  68 :       SEGDES ITLACC,ITLAC1
  69 :     1 CONTINUE
  70 :       segsup iliss1
  71 :       SEGDES ICOLA1,ICOLAC,ILISSE
  72 :       RETURN
  73 :       END
  74 :  
  75 :  
  76 :  
  77 :  
  78 :  
  79 :  
  80 :  
  81 :  
  82 :  
  83 :