Télécharger menage.eso

Retour à la liste

menage
C MENAGE    SOURCE    GOUNAND   25/07/15    21:15:04     12323          
C  SUPPRIMER LES SEGMENTS INDESIRABLES
C
      SUBROUTINE MENAGE(IAUTOM)
*
      IMPLICIT INTEGER(I-N)
      integer iautom
      integer icolac
      integer iplaob, iplaoc
      integer iretou
      integer nomlus
 
-INC PPARAM
-INC CCOPTIO
-INC CCASSIS
-INC CCNOYAU
-INC SMELEME
-INC SMTABLE
-INC SMLENTI
-INC SMCOORD
 
-INC CCREEL
      INTEGER NACTI
      INTEGER NTAACT
      INTEGER MACTIP
      INTEGER MTOTAP
      INTEGER MTOTA
      INTEGER MSEGMP
      INTEGER MACTI
 
      SAVE NACTI
      SAVE NTAACT
      SAVE MACTIP
      SAVE MTOTAP
      SAVE MTOTA
      SAVE MSEGMP
      SAVE MACTI
      data nacti/0/
 
      SEGMENT ITLAC(0)
      INTEGER OOOVAL
*
      CHARACTER*4 CMOT
      REAL*8 XPLTOT
*
       if (nacti.eq.0) then
C  place totale disponible
      XPLTOT=(1.D0*OOOVAL(1,3) * OOOVAL(1,4))/2.D0+OOOVAL(1,1)
      IPLTOT=INT(MIN(XPLTOT,2.D9))
      MTOTA=IPLTOT
         NACTI  = OOOVAL(2,3)
         NTAACT = OOOVAL(3,3)
C     initialisations pour le non menage
         MACTIP = OOOVAL(3,3)
         MTOTAP = OOOVAL(3,1)
         MSEGMP = OOOVAL(2,1)
         MACTI  = OOOVAL(1,1)
       endif
      segdes mcoord
      cmot=' '
      call lircha(cmot, 0,iretou)
      if( iretou.ne.0) then
        if( cmot .eq.'OBLI')go to 1
        call refus
      endif
C  autres criteres de menage :
        IFMEN=0
C  + de 10% de la memoire active depuis la derniere fois
        MACTIC=OOOVAL(3,3)
        IF (MACTIC-MACTIP.gt.MACTI*0.1) IFMEN=1
C  + de 20% de la memoire totale depuis la derniere fois
        MTOTAC=OOOVAL(3,1)
        IF (MTOTAC-MTOTAP.gt.MTOTA*0.20) IFMEN=2
C  + de 15% de la memoire active en memoire totale depuis la derniere fois
        IF (MTOTAC-MTOTAP.gt.MACTI*0.15) IFMEN=3
C  + de 100000 segments depuis la derniere fois
        MSEGMC=OOOVAL(2,1)
        IF (MSEGMC-MSEGMP.gt.32000*max(1,nbescr))      IFMEN=4
        IF (IFMEN.LE.0.and.iautom.eq.0) RETURN
        if (iimpi.ne.0) write (6,*) 'menage ',ifmen
 
 
 
   1  CONTINUE
*  horodatage
      call ooohor(0)
      SEGDES,IPILOC,mcoord
 
C *   attention aux assistants ....
      if (NBESC.NE.0.and.imestr.ne.0) then
          if (iimpi .eq. 1234)
     &  write(ioimp,*) ' il faut bloquer les assistants'
        mestra=imestr
        SEGACT MESTRA*MOD
          if (iimpi .eq. 1234)
     &  write(ioimp,*) ' assistants en attente'
*  on passe en mode force
         call ooofrc(1)
*       lodesl=.true.
        call setass(1)
      end if
 
      call chleha(1,0,0,0,0)
*     On met IONIVE a quelque chose de grand s'il est nul car 0 est
*     desormais le niveau courant par defaut mais la programmation du
*     menage est faite en supposant que IONIVE est incremente a chaque
*     changement
      IONIVS=IONIVE
      IF (IONIVE.EQ.0) IONIVE=IGRAND-10
*  on met NOMLU a 1 pour bloquer le decodage des instructions
      NOMLUS=NOMLU
      nomlu=1
      segini itlac
      call ecrcha('NOOP')
      call tasspo(itlac,icolac,meleme,1,0)
      segdes meleme
      call oooprl(1)
*
*  icolac ,cree dans tasspo  pointe sur les piles d'objets accessibles
*
      CALL MENAG5(ICOLAC,0)
*
*  QUELLE PLACE RESTE T'IL MAINTENANT
        IF(IIMPI.NE.0) write(IOIMP,12) mactip,mactic
         MACTIP=OOOVAL(3,3)
         MTOTAP=OOOVAL(3,1)
         MSEGMP=OOOVAL(2,1)
 12   FORMAT( ' place occupée avant apres ',3I14)
*      CALL PLAC
*      CALL LIRENT(IPLRES,1,IRETOU)
*  EST-CE SUFFISANT ??
*      INTERR(1)=IPLRES
*      IF (IPLADE.NE.0.AND.IPLRES.LT.IPLADE) CALL ERREUR(436)
*  restauration de nomlu
      NOMLU=NOMLUS
* restauration de ionive
      IONIVE=IONIVS
*  retassement memoire y compris segment actifs
* ??  call ooomta(lret,mtota)
 
C *   attention aux assistants ....
      if (NBESC.NE.0.and.imestr.ne.0) then
C *     il faut liberer le segment de dialogue
        mestra=imestr
*  repasser en mode normal
        call ooofrc(0)
        SEGDES MESTRA
*       lodesl=.false.
        call setass(0)
      end if
C JYY
      SEGDES MCOORD
      segact ipiloc
      call oooprl(0)
      END
 
 

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