Télécharger la plaquette Cast3M


fr en

Télécharger menag7.eso

Retour à la liste

Numérotation des lignes : 

menag7

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

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