Télécharger ooodrd.eso

Retour à la liste

ooodrd
C OOODRD    SOURCE    PV090527  26/04/24    08:23:06     12524          
      SUBROUTINE OOODRD (PTRK,ITRK,BUFFET,NBMOTS)
C--------------------------------------------------------------------
C
C               LECTURE  DE : (BUFFET(I),I=1,NBMOTS)
C
C     PTRK      DESIGNE LE SEGMENT DE GESTION : ESPACE FICHIER
C     ITRK      NUMERO DU PREMIER BLOC DU CHAINAGE DE BLOC A LIRE
C   ->BUFFET    LES  NBMOTS  MOTS LUS
C     NBMOTS    NOMBRE DE MOTS A LIRE
C
C PROGRAMMEUR : MOUGIN
C       MODIF : 02/01/89    SUPPRIMER : L'ARGUMENT LRET
C       MODIF : 04/02/89    REGROUPER AVEC  OOODWD  ET  OOODLB
C       MODIF : 03/04/89    SUPPRIMER LE MESSAGE FICHIER PLEIN
C
C--------------------------------------------------------------------
C
C%IF WIN32
C      Include fait pour l'interfaçage FORTRAN - C avec Microsoft Visual C
C      INCLUDE 'esope.fi'
C%ENDIF
%INC IOOADR
%INC IOOPTRK
%INC IOOWCOM
%INC IOOUNIT
C
      INTEGER BUFFET(*)
C
      save itrb
      LTRK = PTRK.LLTRK
      ITRC = ITRK
      IF (TESOOO) PRINT * ,'    OOODRD : LIRE    LE BLOC : ',ITRC
     1                    ,'    NBMOTS = ',NBMOTS
      DO    KA = 1,NBMOTS,LTRK
        IF (TESOOO)                                    THEN
          IF (KA.GT.1)                                 THEN
            PRINT *       ,'                             : ',ITRC
          ENDIF
        ENDIF
        if (itrc.ne.0) then
C       if (itrc.eq.itrb)write (JLST,*) ' lecture en sequence ',ka
C       if (itrc.ne.itrb)write (JLST,*) ' lecture hors sequence ',ka
        endif
        CALL OOOZRD (LRET,ITRC,BUFFET(KA),MIN(LTRK,NBMOTS+1-KA))
        IF (LRET.EQ.1)                                 STOP 16
        itrb=itrc+1
        ITRC=PTRK.JTRK(ITRC)
      ENDDO
      MZJSS(LUS) = MZJSS(LUS)+(NBMOTS+LTRK-1)/LTRK
      MZJSM(LUS) = MZJSM(LUS)+ NBMOTS
                                                       RETURN
C--------------------------------------------------------------------
C
C              ECRITURE DE : (BUFFET(I),I=1,NBMOTS)
C
C     PTRK     DESIGNE LE SEGMENT DE GESTION : ESPACE FICHIER
C   ->ITRK     NUMERO DU PREMIER BLOC   UTILISE
C     BUFFET   CONTIENT LES  NBMOTS  MOTS A ECRIRE
C     NBMOTS   NOMBRE DE MOTS A ECRIRE
C
      ENTRY      OOODWD (PTRK,ITRK,BUFFET,NBMOTS)
C
C   ->ITR1    LE DERNIER  BLOC UTILISE
C   ->ITR2    LE PROCHAIN BLOC UTILISE
C
C  on alloue des blocs consecutifs pour l'enregistrement
C
      LTRK = PTRK.LLTRK
      ITR1 = -777777
      ITR2 = PTRK.NTRL
      IF (TESOOO) PRINT * ,'    OOODWD : ECRIRE  LE BLOC : ',ITR2
     1                    ,'    NBMOTS = ',NBMOTS
      DO    KA=1,NBMOTS,LTRK
        IF (TESOOO)                                    THEN
          IF (KA.GT.1)                                 THEN
            PRINT       * ,'                             : ',ITR2
          ENDIF
        ENDIF
        IF (ITR2.EQ.0)                                 THEN
          ITRK = 0
                                                       RETURN
        ENDIF
C  Modif PV pour ecrire juste la bonne longueur
C       CALL OOOZWD (LRET,ITR2,BUFFET(KA),LTRK)
        CALL OOOZWD (LRET,ITR2,BUFFET(KA),MIN(LTRK,NBMOTS+1-KA))
C  fin modif
        IF (LRET.EQ.1)                                 STOP 16
        ITR1 = ITR2
        ITR2 = PTRK.JTRK(ITR1)
C       if (itr2.eq.itr1+1)write (JLST,*) ' ecriture en sequence ',ka
C       if (itr2.ne.itr1+1)write (JLST,*) ' ecriture hors sequence ',ka
      ENDDO
C*    nbloc=(nbmots-1)/ltrk+1
C  recherche d'un trou de taille suffisante
C*    itr1=ptrk.ntrl
C*    itr2=itr1
C*10  continue
C*    itrp=itr2
C*    itr0=itr1
C*    do j=2,nbloc
C*     itr2=itr1
C*     itr1=ptrk.jtrk(itr1)
C*     if (itr1.ne.itr2+1) goto 10
C*     if (itr1.eq.0) then
C*      itrk=0
C*      return
C*     endif
C*    enddo
C  ecriture longue
C    write (JLST,*) ' ecriture position longueur ',itr0,nbmots
C*    call ooozwd(lret,itr0,buffet(1),nbmots)
C*    itrk=itr0
C  mise a jour des chainages
C*    if (itr0.ne.ptrk.ntrl) then
C*      ptrk.jtrk(itrp)=ptrk.jtrk(itr1)
C*    else
C*      ptrk.ntrl=ptrk.jtrk(itr1)
C*    endif
C*    ptrk.jtrk(itr1)=0
C
C****** FIN DE CHAINAGE ET STATISTIQUE
C
      ITRK            = PTRK.NTRL
       PTRK.NTRL       = PTRK.JTRK(ITR1)
       PTRK.JTRK(ITR1) = 0
      MZJSS(ECRIS)    = MZJSS(ECRIS)+(NBMOTS+LTRK-1)/LTRK
      MZJSM(ECRIS)    = MZJSM(ECRIS)+ NBMOTS
                                                       RETURN
C--------------------------------------------------------------------
C
C                  LIBERATION D'ESPACE SUR FICHIER
C
C     PTRK    DESIGNE LE SEGMENT DE GESTION : ESPACE FICHIER
C     ITRK    NUMERO DU PREMIER BLOC DU CHAINAGE DE BLOCS A LIBERER
C
C
C
C  on suppose que la chaine des blocs libres est ordonnee et on
C  la maintient ordonnee
      ENTRY      OOODLB (PTRK,ITRK)
C
      IF (TESOOO)   PRINT * ,'    OOODLB : LIBERER LE BLOC : ',ITRK
      IF (ITRK.NE.0)                                   THEN
        ITRC=ITRK
        DO WHILE (ITRC.NE.0)
        ITRCN  =PTRK.JTRK(ITRC)
        IF (TESOOO) PRINT * ,'                             : ',ITRC
        itrbp=0
        itrb=ptrk.ntrl
        do while (itrb.le.itrc)
         itrbp=itrb
         itrb=ptrk.jtrk(itrb)
        enddo
        if (itrbp.ne.0) then
         ptrk.jtrk(itrbp)=itrc
        else
         ptrk.ntrl=itrc
        endif
         ptrk.jtrk(itrc)=itrb
        ITRC=ITRCN
        ENDDO
      ENDIF
 
      END
 
 

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