C MENAG7 SOURCE CB215821 21/06/10 21:15:36 11029 SUBROUTINE MENAG7(icolac,jcolac) C C elimine des itlac deja sauves ceux qui n'existent plus C implicit integer(i-n) integer i, ifi, ifi1, ima, j, k integer jcolac integer lsf, nitlac, nliss1 -INC PPARAM -INC CCOPTIO -INC TMCOLAC segment iliss1 integer ilise1(nliss1) endsegment if(jcolac.eq.0) return C call imppil ( ipsauv,0) * call imppil (jcolac,0) icola1=jcolac segact icolac C write(6,*) "jcolac",jcolac segact icola1 ilisse=icola1.ilissg C write(6,*) "ilisse",ilisse segact ilisse*mod nitlac=icola1.kcola(/1) nliss1=0 segini iliss1 do 1 k=1,nitlac if(k.ge.24.and.k.le.28) go to 1 if(k.eq.32) go to 1 if(k.eq.36) go to 1 itlac1=icola1.kcola(k) itlacc=kcola(k) segact itlac1*mod segact itlacc ifi= itlac(/1) ifi1=itlac1.itlac(/1) if( ifi1.eq.0) go to 10 * write (6,*) 'ifi*ifi1 ',ifi,ifi1,ifi*ifi1 lsf=0 * if (ifi*ifi1.gt.65535) then if (ifi*ifi1.gt.16384) then lsf=1 ** do i=1,ilise1(/1) ** ilise1(i)=0 ** enddo if(nliss1 .GT. 0) call ooozmr(ilise1(1),nliss1) do 31 i=1,ifi ima=itlac(i) if(ima.eq.0) goto 31 iman=(ima-1)/npgcd if (iman.gt.nliss1) then nliss1=iman*1.2 segadj iliss1 endif ilise1(iman)=i 31 continue else lsf=0 endif * write(6,*) 'menag7 traitement pile',k,ifi,ifi1 do 2 i=1,ifi1 ima = itlac1.itlac(i) iman=(ima-1)/npgcd if(ima.eq.0) go to 2 if (lsf.eq.0) then do 3 j=1,ifi if(ima.eq.itlac(j)) go to 2 3 continue else if (iman.le.ilise1(/1)) then j=ilise1(iman) if (j.ne.0) then if(ima.eq.itlac(j)) go to 2 write(6,*) 'menag7 probleme ',ima,itlac(j) endif endif endif * write(6,*) ' suppression de ',ima itlac1.itlac(i)=0 iliseg(iman)=0 2 continue 10 continue segdes itlacc,itlac1 1 continue segsup iliss1 segdes icola1,icolac,ilisse return END