Sources Esope | Cast3M

ooomtx
C OOOMTX    SOURCE    PV090527  26/04/24    08:23:17     12524          
      SUBROUTINE OOOMTX (IZ,IS,LS,LSG,iro)
C-------------------------------------------------------------------            
C                                                                               
C                     TASSER UNE PORTION DE MEMOIRE                             
C                                                                               
C     IZ   INDICE DE LA ZONE MEMOIRE                                            
C     IS   INDICE DU DEBUT DE LA PORTION A TASSER                               
C     LS   LONGUEUR DE LA PORTION                                               
C     LSG  LONGUEUR DU TROU RECHERCHE                                           
C     LSO  LONGUEUR DU TROU OBTENU
C                                                                               
C   ->IS   INDICE DU TROU RESULTANT                                             
C   ->LS   LONGUEUR DU TROU RESULTANT                                           
C                                                                               
C                                                                               
C     LE TASSEMENT DES BLOCS ATTRIBUES SE FAIT AVEC MISE A JOUR DU              
C     PREMIER MOT DES DESCRIPTEURS . IL SE FAIT EN DEPLACANT LES BLOCS          
C     ATTRIBUES VERS LES ADRESSES BASSES POUR ASSURER LA FIXITE DU              
C     SEGMENT DES DESCRIPTEURS                                                  
C                                                                               
C          HYPOTHESE :                                                          
C                                                                               
C     IL N'Y A PAS DE SEGMENTS FIXES DANS LA PORTION DE MEMOIRE                 
C                                                                               
C     ON S'ARRETE DES QUE ON A PU CREER UN TROU SUFFISANT                       
C                                                                               
C-----------------------------------------------------------------------        
C                                                                               
C                        PRINCIPALES VARIABLES:                                 
C                                                                               
C     IS   POSITION ATTEINTE APRES TASSEMENT DU PAQUET DE SGM PRECEDENT         
C          (EN FINALE INDICE DU TROU RESTANT)                                   
C     JS   INDICE DU 1EME SEGMENT DU PAQUET QUI SUIT LE TROU QUI VIENT          
C           D'ETRE TASSE                                                        
C     KS   INDICE DE DEBUT DES SEGMENTS DU PAQUET A TASSER                      
C           (EN FIN DE PAQUET-->INDICE DU TROU QUI SUIT LE PAQUET)              
C     LS   CUMUL DES LG DES TROUS=VALEUR DE LA TRANSLATION A FAIRE              
C           SUBIRE EN MEMOIRE AU PAQUET DE SEGM A TASSER                        
C           (EN FINALE-->LG DU TROU RESULTANT)                                  
C           (AU DEBUT LG DU TROU A CREER)                                       
*  iro = 0 on deplace les segments actifs
*  iro = 1 on ne deplace pas les segments actifs
C-----------------------------------------------------------------------        
C                                                                               
%INC IOOADR                                                                     
%INC IOOADZ                                                                     
%INC IOODES                                                                     
%INC IOOTRO                                                                     
%INC IOOSGM                                                                     
%INC IOOTF2
%INC IOOSAF
      INTEGER BLKMSK1,BLKMSK2
*
*  recuperer le masque des threads bloques
      blkmsk1=0
      blkmsk2=0
      call ooombl(blkmsk1,blkmsk2)
      if (oothrd+1.lt.64) blkmsk1=ibset(blkmsk1,oothrd+1)
      if (oothrd+1.ge.64) blkmsk2=ibset(blkmsk2,oothrd+1-64)
*     write(6,'(A16,Z16)') 'blkmsk ooomtx ',blkmsk
 
C                                                                               
C******  DEBUT:IS POINTE SUR DEBUT DE LA PORTION MEMOIRE:                       
C                                                                               
*     write (6,*) ' mtx appele iro ',iro
      IPASS=1
      ISMAX = IS+LS                                                             
      IS=MZPRTR
      LS    = 0                                                                 
      LSX   = 0                                                                 
C                                                                               
C******  DEBUT TRAITEMENT D'UN PAQUET DE SGM:                                   
C                                                                               
 10   JS = IS+LS                                                                
      ifix=0
 
      if(iro.ne.0) then
      iro=0
**    write (6,*) 'ooomta lnsf',(lnsf(i),i=0,64)
      do i=0,128
       if (i.ne.oothrd) then
**       if (lnsf(i).eq.1) write(6,*) 'i lnsf ',i,lnsf(i)
**       if (lnsf(i).eq.1) lnsf(-2**55)=2
         iro=max(iro,lnsf(i))
       endif
      enddo
      endif
**    write(6,*) 'iro dans ooomtx',iro,js
 
 
 
      KS = JS                                                                   
        IF (KS.GE.ISMAX.AND.IPASS.EQ.2)            GO TO 50
C******** DEBUT TRT D' UN SGM DU PAQUET                                         
C            A T ON ATTEINT UN TROU ou un segment inamovible?
      DO WHILE (.NOT. MTROU(KS).AND.KS.NE.ISMAX)
* on peut tasser si on est le seul a lire le segment
       if(ls.ne.0..and.iro.eq.1.and.
     >    ((and(mdro1(mside(ks)),not(blkmsk1)).ne.0).or.
     >     (and(mdro2(mside(ks)),not(blkmsk2)).ne.0))) ifix=1
        LSX=MSLS1(KS)                                                           
        if (lsx.eq.0) write (6,*) ' lsx=0 dans ooomtx ks= ',ks
        if (lsx.eq.0) stop 12
        KS=KS+LSX                                                               
        IF (KS.GE.ISMAX.AND.IPASS.EQ.2)            GO TO 50
        if (ks.gt.ismax) write (6,*) ' ooomtx ks ismax ',ks,ismax
      ENDDO                                                                     
      if (ifix.eq.1) write(6,*)  'segment fixe dans ooomtx'
 
 
* si pas assez de gain
**    if (ls+lsx.lt.(ks-js)/250.and.is.eq.js) then
**      write (6,*) ' ooomtx trou paquet ',ls+lsx,ks-js
**      ifix=1
**    endif
 
 
 
 
 
C                                                                               
C************ TASSEMENT D'UN PAQUET DE SGM                                      
C                                                                               
      if (ifix.eq.0) then
       MTITS(MTITP(KS))=MTITS(KS)
       MTITP(MTITS(KS))=MTITP(KS)
C              SI LS=0,TASSEMENT INUTILE                                        
       IF (LS.NE.0)                                   THEN
        I2=KS-JS                                                                
        if (is.ne.js) then
          call OOOZMV  (JSG(JS+1),JSG(IS+1),I2)
*      write (6,*) ' ooomtx paquet deplace ',
*    >    i2,ls
          MZJSM(DEPLACES) = MZJSM(DEPLACES)+I2
        endif
        ISF = IS+I2                                                             
        ISX = IS                                                                
        DO WHILE (ISX.LT.ISF)                                                   
          LSX = MSLS1(ISX)                                                      
          IDX = MSIDE(ISX)                                                      
          MDISG(IDX) = ISX                                                      
          if (is.ne.js) MZJSS(DEPLACES)=MZJSS(DEPLACES)+1
          ISX=ISX+LSX                                                           
        ENDDO                                                                   
       ENDIF
      else
*  virer le trou puisqu'on ecrira dedans
         LSX=-MTLT1(KS)
         ISX=KS
         MTITS(MTITP(KS))=MTITS(KS)
         MTITP(MTITS(KS))=MTITP(KS)
*  insertion d'un trou avant le paquet inamovible
*      write (6,*) ' ooomtx paquet inamovible ',
*    >    is,ls
       if (ls.ne.0) then
         CALL OOOZMR (JSG(IS+1),LS)
         MZITS0(IZ,ZMEMDYN)=MZIT0(IZ,ZMEMDYN)
         MTF2 , IZ(ZMEMDYN,IS,LS)
         MZITS0(IZ,ZMEMDYN)=IS
       endif
         LS=LSX
         IS=ISX
         goto 10
      endif
C                                                                               
C******        REVALUATION DE IS ET LS POUR LE PAQUET SUIVANT                   
C                                                                               
      IS=KS-LS                                                                  
      LS=LS-MTLT1(KS)                                                           
        IF (KS.GE.ISMAX)    THEN
 
        IF (LS.NE.0)                                     THEN
         CALL OOOZMR (JSG(IS+1),LS)
         MZITS0(IZ,ZMEMDYN)=MZIT0(IZ,ZMEMDYN)
         MTF2 , IZ(ZMEMDYN,IS,LS)
         MZITS0(IZ,ZMEMDYN)=IS
        ENDIF
           IPASS=2
           IS=MZIS0(IZA)
           LS=0
           GOTO 10
        ENDIF
      IF (LS.LT.LSG)                                   GO TO 10
*  on essaye de faire un trou un peu plus grand pour faire moins souvent des tassements
**    IF (mod(IS-MZPRTR,mzlen(IZA)).LT.int(MZLEN(IZA)*0.1)) GO TO 10
      IF (LS.LT.int(MZLEN(IZA)*0.05).and.ipass.lt.2) GO TO 10
C                                                                               
C****** RAZ TROU RESULTANT DU TASSEMENT                                         
C                                                                               
 50   CONTINUE
      MZPRTR=IS+LS
      IF (LS.NE.0)                                     THEN                     
         CALL OOOZMR (JSG(IS+1),LS)
        MZITS0(IZ,ZMEMDYN)=MZIT0(IZ,ZMEMDYN)                                    
        MTF2 , IZ(ZMEMDYN,IS,LS)                                                
        MZITS0(IZ,ZMEMDYN)=IS                                                   
      ENDIF                                                                     
                                                       RETURN                   
      END