lfiree.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfiree_fort                                           &
&                     (lfi, krep, krang, cdnoma, klong, krpiex,  &
&                    kartex,                                     &
&                    klonex, krpiec, kartec, kposec, kdtrou,     &
&                    klonut, kretin )
USE lfimod, ONLY : lficom
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES LFI
!     RECHERCHE D'UN EMPLACEMENT OU ECRIRE UN ARTICLE LOGIQUE, DANS
!     L'UNITE LOGIQUE CONCERNEE.
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
!                KRANG  (ENTREE) ==> RANG ( DANS LA TABLE *LFI%NUMERO* )
!                                    DE L'UNITE LOGIQUE CONCERNEE;
!                CDNOMA (ENTREE) ==> NOM DE L'ARTICLE A RECHERCHER;
!                KLONG  (ENTREE) ==> LONGUEUR DE L'ARTICLE A ECRIRE;
!                KRPIEX (SORTIE) ==> RANG ( DANS LE FICHIER ) DE L'ARTI-
!                                    CLE S'IL EXISTAIT DEJA ( 0 SINON );
!                KARTEX (SORTIE) ==> RANG ( DANS LA PAGE D'INDEX ) DE L'
!                                    ARTICLE S'IL EXISTAIT ( 0 SINON );
!                KLONEX (SORTIE) ==> LONGUEUR DE L'ARTICLE S'IL EXISTAIT
!                                    DEJA ( 0 SINON );
!                KRPIEC (SORTIE) ==> RANG ( DANS LE FICHIER ) DE L'ARTI-
!                                    CLE A ECRIRE;
!                KARTEC (SORTIE) ==> RANG ( DANS LA PAGE D'INDEX ) DE L'
!                                    ARTICLE A ECRIRE;
!                KPOSEC (SORTIE) ==> POSITION ( DANS LE FICHIER ) OU
!                                    COMMENCER A ECRIRE L'ARTICLE;
!                KDTROU (SORTIE) ==> VARIATION DU NOMBRE DE TROUS DANS
!                                    L'INDEX, DUE A CETTE ECRITURE;
!                KLONUT (SORTIE) ==> SI L'ON VA CREER UN TROU DANS L'IN-
!                                    DEX, LONGUEUR TOTALE UTILISABLE DE
!                                    CE TROU;
!                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
!*
!    METHODE: SI L'ARTICLE EXISTE DEJA DANS LE FICHIER, ON ESSAIE AUTANT
!             QUE POSSIBLE DE "REECRIRE" SUR PLACE, CE QUI EST POSSIBLE
!             SI L'ON A UNE LONGUEUR D'ARTICLE INFERIEURE OU EGALE A
!             CELLE EXISTANTE, MAIS EST AUSSI POSSIBLE PAR RECYCLAGE
!             DE "TROUS" DE 2 CATEGORIES: EN FIN D'ARTICLE EXISTANT
!             ( AVANT L'ARTICLE LOGIQUE OU L'ARTICLE D'INDEX SUIVANT ),
!             ET/OU S'IL EXISTE UN "TROU" REPERTORIE DANS L'INDEX CORRE-
!             SPONDANT A UN ARTICLE LOGIQUE JUSTE DERRIERE CELUI EXIS-
!             TANT.
!                SI LA REECRITURE N'EST PAS POSSIBLE, ON ESSAIE ALORS DE
!             REUTILISER UN EVENTUEL "TROU" REPERTORIE DANS L'INDEX;
!             EN DESESPOIR DE CAUSE, ON ECRIT EN FIN DE FICHIER.
!
!
TYPE(lficom) :: LFI
CHARACTER CDNOMA*(*)
!
INTEGER (KIND=JPLIKB) KREP, KRANG, KLONG, KRPIEX, KARTEX 
INTEGER (KIND=JPLIKB) KLONEX, KRPIEC, KARTEC
INTEGER (KIND=JPLIKB) KPOSEC, KDTROU, KLONUT, ILCDNO, IRANG 
INTEGER (KIND=JPLIKB) ILTSUF, INTTRU, J
INTEGER (KIND=JPLIKB) INBALO, INBPIR, IFACTM, ILARPH
INTEGER (KIND=JPLIKB) INTPPI, IRNGSU, INALPP
INTEGER (KIND=JPLIKB) INPPIM, INPIME, INTROU, INPPI1 
INTEGER (KIND=JPLIKB) IDEBEX, IARTIC, IRGPIF
INTEGER (KIND=JPLIKB) INALPI, INPAGE, IRGPIM, IRPIFN 
INTEGER (KIND=JPLIKB) ILFORC, IPOSEX
INTEGER (KIND=JPLIKB) IPOSDX, IRECPI, ILSUIV, IPOSUI 
INTEGER (KIND=JPLIKB) IRGPI, IRPIMS, INPILE
INTEGER (KIND=JPLIKB) IRNGMS, INTRPI, ILTROU, IPTROU 
INTEGER (KIND=JPLIKB) IRPITR, IARTTR, IPOSTR
INTEGER (KIND=JPLIKB) IRPIMD, IRPIFD, INALDP, IRETOU 
INTEGER (KIND=JPLIKB) INIMES, INUMER, IRANGM
INTEGER (KIND=JPLIKB) IEXPLO (lfi%jpnpia+lfi%jpnpis+1) 
INTEGER (KIND=JPLIKB) INDICE (lfi%jpnapx),  &
&        KRETIN, IRETIN
!
LOGICAL LLTSUF, LLTOPT, LLTTRU, LLRCHA
!
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!**
!     1.  -  CONTROLES DES PARAMETRES D'APPEL ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIREE_FORT',0,zhook_handle)
clacti=''
ilcdno=int(len(cdnoma), jplikb)
!
IF (krang.LE.0.OR.krang.GT.lfi%JPNXFI.OR.klong.LE.0.OR.        &
&    ilcdno.LE.0.OR.ilcdno.GT.lfi%JPNCPN.OR.cdnoma.EQ.' ') THEN
  krep=-16
  GOTO 1001
ENDIF
!
irang=krang
krep=0
lltsuf=.false.
lltopt=.false.
kartex=0
kartec=0
krpiec=0
krpiex=0
klonex=0
klonut=lfi%JPNIL
iretou=0
iltsuf=0
inttru=lfi%MDES1D(ixm(lfi%JPNTRU,irang))+lfi%NBTROU(irang)
inbalo=lfi%MDES1D(ixm(lfi%JPNALO,irang))
inbpir=lfi%MDES1D(ixm(lfi%JPNPIR,irang))
llttru=inttru.EQ.0
ifactm=lfi%MFACTM(irang)
ilarph=lfi%JPLARD*ifactm
inalpp=lfi%JPNAPP*ifactm
intppi=(inbalo-1+inalpp)/inalpp
IF (lfi%LMISOP) WRITE (unit=lfi%NULOUT,fmt=*)                      &
&        'INBALO= ',inbalo,', INTTRU= ',inttru,', INTPPI= ',intppi, &
&        ', INBPIR= ',inbpir
!
IF (inbalo.EQ.0) GOTO 240
!
irngsu=0
irpifn=1
inppim=lfi%NPPIMM(irang)
inpime=0
introu=0
!
!**
!     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
!            A LA RECHERCHE DE L'ARTICLE ET/OU D'UN "TROU" DANS L'INDEX,
!            SUFFISANT POUR Y "CASER" L'ARTICLE. ( ON COMMENCE
!            PAR EXPLORER LES PAGES D'INDEX )
!-----------------------------------------------------------------------
!
inppi1=inppim
llrcha=.true.
!
IF (lfi%NPODPI(irang).EQ.2) THEN
  idebex=3
ELSE
  idebex=2
ENDIF
!
IF (llttru) THEN
!
  CALL lfiran_fort                                              &
&                 (lfi, krep,irang,cdnoma,irgpim,iartic,iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.EQ.2) THEN
    GOTO 904
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ELSEIF (iartic.NE.0) THEN
!
!         ARTICLE TROUVE.
!
    irgpif=lfi%MRGPIF(irgpim)
    inalpi=min(inalpp,inbalo-(irgpif-1)*inalpp)
!
!         La ligne ci-dessous sert a eviter les ennuis entre les
!         etiquettes 213 et 215.
!
    inpage=intppi+1
    GOTO 212
  ELSE
!
!         IL VA FALLOIR CREER UN ARTICLE SUPPLEMENTAIRE.
!
    GOTO 240
  ENDIF
!
ENDIF
!
!     ... DEBUT D'UNE STRUCTURE DE TYPE "BOUCLE" SUR INPAGE,
!         QUI NE PEUT PAS (PLUS) ETRE UNE BOUCLE "DO" A PARTIR DU
!         MOMENT OU ON VEUT UTILISER, DES QUE POSSIBLE, "LFIRAN"
!         POUR UNE RECHERCHE D'ARTICLE MOINS COUTEUSE, SURTOUT LORSQUE
!         L'ARTICLE QUE L'ON CHERCHE ETAIT LE DERNIER TRAITE ...
!
inpage=1
!
201 CONTINUE
!
IF (inpage.LE.inppi1) THEN
!
!           IL S'AGIT D'UNE EXPLORATION EN MEMOIRE ( PAGES D'INDEX ) .
!
  irgpim=lfi%MRGPIM(inpage,irang)
  irgpif=lfi%MRGPIF(irgpim)
  inpime=inpime+1
  iexplo(inpime)=irgpif
  IF (irgpif.EQ.(irpifn+1)) irpifn=irgpif
ELSE
!
!           IL S'AGIT D'UNE EXPLORATION "HORS MEMOIRE";
!         ON CHERCHE LA PROCHAINE P.A.I. NON EXPLOREE .
!
  IF (inpage.EQ.inppi1+1) THEN
!
    IF (irngsu.EQ.0) THEN
      irgpif=irpifn
    ELSE
!
!          Cas ou il y a eu, dans la recherche "en memoire",
!        recyclage d'une P.P.I. que l'on avait exploree precedemment.
!          Cette P.P.I. est restee sur place, n'a pas ete exploree,
!        et il serait bete de l'oublier, au risque de la dupliquer...
!
      irgpim=lfi%MRGPIM(irngsu,irang)
      irgpif=lfi%MRGPIF(irgpim)
      inpime=inpime+1
      iexplo(inpime)=irgpif
      IF (irgpif.EQ.(irpifn+1)) irpifn=irgpif
      GOTO 210
    ENDIF
!
  ENDIF
!
202 CONTINUE
  irgpif=irgpif+1
!
  DO j=idebex,inpime
  IF (iexplo(j).EQ.irgpif) GOTO 202
  ENDDO
!
  ilforc=1
  inpile=1
  CALL lfipim_fort                                               &
&                 (lfi, krep,irang,irangm,irgpim,irgpif,ilforc,  &
&                  inpile, iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.EQ.2) THEN
    GOTO 904
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ENDIF
!
  inppim=max(inppim,irangm)
ENDIF
!*
!     2.1 -  "BOUCLE" DE RECHERCHE SUR LES ARTICLES PRESENTS DANS
!             LA (PAIRE DE) PAGE D'INDEX DE RANG IRGPIF DANS LE FICHIER.
!-----------------------------------------------------------------------
!
210 CONTINUE
inalpi=min(inalpp,inbalo-(irgpif-1)*inalpp)
iartic=0
!
IF (llrcha) THEN
!
  DO j=1,inalpi
!
  IF (lfi%CNOMAR(ixc(j,irgpim)).EQ.cdnoma) THEN
    iartic=j
    GOTO 212
  ENDIF
!
  ENDDO
!
ENDIF
!
212 CONTINUE
!
IF (iartic.NE.0) THEN
!
!        ON A TROUVE DANS LE FICHIER UN ARTICLE DE MEME NOM QUE CELUI A
!        ECRIRE.
!
  llrcha=.false.
!
  IF (.NOT.lfi%LPHASP(irgpim)) THEN
!
    CALL lfipha_fort                                &
&                   (lfi, krep,irang,irgpim,iretin)
!
    IF (iretin.EQ.1) THEN
      GOTO 903
    ELSEIF (iretin.EQ.2) THEN
      GOTO 904
    ELSEIF (iretin.NE.0) THEN
      GOTO 1001
    ENDIF
!
  ENDIF
!
  krpiex=irgpif
  klonex=lfi%MLGPOS(ixm(2*iartic-1,irgpim))
  iposex=lfi%MLGPOS(ixm(2*iartic,irgpim))
  kartex=iartic
!
  IF (klong.LE.klonex) THEN
!
!       L'ARTICLE TROUVE EST AU MOINS AUSSI LONG QUE CELUI QUE L'ON VEUT
!       ECRIRE: UNE ECRITURE AU MEME EMPLACEMENT EST DONC POSSIBLE.
!
    krpiec=irgpif
    kartec=iartic
    kposec=iposex
    GOTO 240
  ELSE
!
!     CAS DE REECRITURE + LONGUE QUE L'ARTICLE EXISTANT SUR LE FICHIER.
!
    iposdx=lfi%MLGPOS(ixm(2*iartic,irgpim))+klong-1
!
    IF (iartic.EQ.1.AND.irgpif.GT.inbpir) THEN
!
!            IL Y A EU DEBORDEMENT DES P.A.I. PREALLOUEES, ET IL Y A
!        EN OUTRE UNE P.A.I. SUR LE FICHIER, JUSTE DERRIERE L'ARTICLE
!        LOGIQUE AUQUEL ON S'INTERESSE. ON REGARDE S'IL Y A ASSEZ DE
!        PLACE AVANT LA P.A.I. POUR UNE REECRITURE AU MEME ENDROIT.
!        ( P.A.I. = PAIRE D'ARTICLES D'INDEX )
!
      irecpi=lfi%MDES1D(ixm(ilarph+1-(irgpif-inbpir),irang))
      klonut=ilarph*(irecpi-1)-iposex+1
!
      IF (klong.LE.klonut) THEN
        krpiec=irgpif
        kartec=iartic
        kposec=iposex
        GOTO 240
      ELSE
        GOTO 216
      ENDIF
!
    ELSEIF (iartic.EQ.inalpi.AND.irgpif.EQ.intppi) THEN
!
!           CAS OU L'ARTICLE TROUVE EST LE DERNIER ARTICLE LOGIQUE DE
!        DONNEES, SANS P.A.I. JUSTE DERRIERE. IL Y A DE LA PLACE DONC...
!
      krpiec=irgpif
      kartec=iartic
      kposec=iposex
      GOTO 240
    ENDIF
!
  ENDIF
!
!            EN ARRIVANT ICI, ON EST DONC SUR QUE L'ARTICLE TROUVE
!          N'EST PAS LE DERNIER ARTICLE LOGIQUE.
!
!     ON VA REGARDER SI, PAR CHANCE, L'ARTICLE LOGIQUE SUIVANT N'EST
!     PAS UN TROU SUFFISANT POUR "CASER" L'EXCEDENT DE DONNEES,
!     OU S'IL N'Y A PAS UN TROU DE DONNEES ( NON ASSOCIE A UN TROU DANS
!     LA PARTIE "NOMS" DE L'INDEX ) SUFFISANT EN FIN D'ARTICLE EXISTANT,
!     AVANT L'ARTICLE LOGIQUE SUIVANT...
!
  IF (iartic.NE.inalpi) THEN
!
!             L'ARTICLE SUIVANT EST DANS LA MEME PAGE D'INDEX...
!
    ilsuiv=lfi%MLGPOS(ixm(2*iartic+1,irgpim))
    iposui=lfi%MLGPOS(ixm(2*iartic+2,irgpim))
    klonut=iposui-iposex
!
    IF (klong.LE.klonut) THEN
!
!     ... ET IL Y A UN "TROU" SUFFISANT AVANT CET ARTICLE POUR POUVOIR
!         ECRIRE LES DONNEES EXCEDENTAIRES.
!
      krpiec=irgpif
      kartec=iartic
      kposec=iposex
      GOTO 240
!
    ELSEIF (lfi%CNOMAR(ixc(iartic+1,irgpim)).EQ.' ' &
&            .AND.klong.LE.(klonut+ilsuiv)) THEN
!
!     ... ET C'EST UN TROU QUI PERMET, AVEC L'AIDE EVENTUELLE
!         D'UNE ZONE DE DONNEES "MORTE" ENTRE LES 2 ARTICLES,
!         DE MENAGER UNE PLACE SUFFISANTE POUR L'EXCES DE DONNEES.
!
      lfi%MLGPOS(ixm(2*iartic+1,irgpim))=iposui+ilsuiv-(iposdx+1)
      lfi%MLGPOS(ixm(2*iartic+2,irgpim))=iposdx+1
      lfi%LECRPI(irgpim,2)=.true.
      krpiec=irgpif
      kartec=iartic
      kposec=iposex
!
      IF (lfi%MLGPOS(ixm(2*iartic+1,irgpim)).EQ.0) THEN
        GOTO 230
      ELSE
        GOTO 240
      ENDIF
!
    ENDIF
!
!     ... L'ARTICLE SUIVANT N'EST PAS EXPLOITABLE POUR ECRIRE L'EXCES
!         DE DONNEES.
!
    GOTO 216
  ELSE
!
!     L'ARTICLE TROUVE EST CERTES TROP COURT, MAIS IL EST EN PLUS EN FIN
!     DE PAGE D'INDEX...
!
    DO j=2,inppim
    irgpi=lfi%MRGPIM(j,irang)
!
    IF (lfi%MRGPIF(irgpi).EQ.(irgpif+1)) THEN
!
      irpims=irgpi
!
      IF (.NOT.lfi%LPHASP(irpims)) THEN
!
        CALL lfipha_fort                                &
&                       (lfi, krep,irang,irpims,iretin)
!
        IF (iretin.EQ.1) THEN
          GOTO 903
        ELSEIF (iretin.EQ.2) THEN
          GOTO 904
        ELSEIF (iretin.NE.0) THEN
          GOTO 1001
        ENDIF
!
      ENDIF
!
      GOTO 215
!
    ENDIF
!
    ENDDO
!
!             LA P.A.I. SUIVANTE (EN RANG DANS LE FICHIER) N'EST PAS
!          EN MEMOIRE; DECIDEMENT, CELA SE GATE ! ... ON L'Y MET.
!
!             Noter que ce cas de figure ne peut se presenter q'une
!          seule fois par exploration de l'index.
!
    inpile=2
    CALL lfipim_fort                                                &
&                   (lfi, krep,irang,irngms,irpims,irgpif+1,irgpif, &
&                    inpile, iretin)
!
    IF (iretin.EQ.1) THEN
      GOTO 903
    ELSEIF (iretin.EQ.2) THEN
      GOTO 904
    ELSEIF (iretin.NE.0) THEN
      GOTO 1001
    ENDIF
!
    IF (inpage.LE.inppim) THEN
!
!               On est dans le cadre d'une exploration "en memoire"...
!
      IF (irngms.GT.inppim) THEN
!
!               ... et il y aura une P.P.I. a explorer en plus,
!                   a la fin du balayage "en memoire".
!
        inppi1=inppi1+1
      ELSEIF (irngms.LT.inpage) THEN
!
!               ... et il y aura une P.P.I. a explorer en plus,
!                   mais apres le balayage "en memoire".
!
        irngsu=irngms
      ENDIF
!
    ENDIF
!
    inppim=max(inppim,irngms)
!
215 CONTINUE
!
!            LA PAIRE D'ARTICLES D'INDEX SUIVANTE EST EN MEMOIRE.
!
    ilsuiv=lfi%MLGPOS(ixm(1_jplikb ,irpims))
    iposui=lfi%MLGPOS(ixm(2_jplikb ,irpims))
    klonut=iposui-iposex
!
    IF (klong.LE.klonut) THEN
!
!     ... ET IL Y A UN "TROU" SUFFISANT AVANT CETTE PAIRE POUR POUVOIR
!         ECRIRE LES DONNEES EXCEDENTAIRES.
!
      krpiec=irgpif
      kartec=iartic
      kposec=iposex
      GOTO 240
!
    ELSEIF (lfi%CNOMAR(ixc(1_jplikb ,irpims)).EQ.' ' &
&           .AND.klong.LE.(klonut+ilsuiv)) THEN
!
!     ... ET C'EST UN TROU QUI PERMET, AVEC L'AIDE EVENTUELLE
!         D'UNE ZONE DE DONNEES "MORTE" ENTRE LES 2 ARTICLES,
!         DE MENAGER UNE PLACE SUFFISANTE POUR L'EXCES DE DONNEES.
!
      lfi%MLGPOS(ixm(1_jplikb ,irpims))= &
&              iposui+ilsuiv-(iposdx+1)
      lfi%MLGPOS(ixm(2_jplikb ,irpims))=iposdx+1
      lfi%LECRPI(irpims,2)=.true.
      krpiec=irgpif
      kartec=iartic
      kposec=iposex
!
      IF (lfi%MLGPOS(ixm(1_jplikb ,irpims)).EQ.0) THEN
        GOTO 230
      ELSE
        GOTO 240
      ENDIF
!
    ENDIF
!
!              SI ON ARRIVE ICI, IL FAUT PASSER A LA PAGE SUIVANTE .
!
  ENDIF
!
ENDIF
!
216 CONTINUE
!
!        RECHERCHE EVENTUELLE DE TROUS D'INDEX DE LONGUEUR ADEQUATE.
!
IF (llttru.OR.lltopt) THEN
!
  IF (.NOT.llrcha) THEN
    GOTO 240
  ELSE
    GOTO 229
  ENDIF
!
ELSE
  intrpi=0
!
  DO j=1,inalpi
!
  IF (lfi%CNOMAR(ixc(j,irgpim)).EQ.' ') THEN
    intrpi=intrpi+1
    indice(intrpi)=j
  ENDIF
!
  ENDDO
!
ENDIF
!
IF (intrpi.NE.0) THEN
!
  IF (.NOT.lfi%LPHASP(irgpim)) THEN
!
    CALL lfipha_fort                                &
&                   (lfi, krep,irang,irgpim,iretin)
!
    IF (iretin.EQ.1) THEN
      GOTO 903
    ELSEIF (iretin.EQ.2) THEN
      GOTO 904
    ELSEIF (iretin.NE.0) THEN
      GOTO 1001
    ENDIF
!
  ENDIF
!
  DO j=1,intrpi
  iartic=indice(j)
  iltrou=lfi%MLGPOS(ixm(2*iartic-1,irgpim))
  iptrou=lfi%MLGPOS(ixm(2*iartic,irgpim))
!
  IF (iltrou.GE.klong) THEN
!
!             "TROU" D'INDEX DE LONGUEUR SUFFISANTE POUR L'ARTICLE.
!
    IF (.NOT.lltsuf) THEN
      lltsuf=.true.
      iltsuf=iltrou+1
    ENDIF
!
    IF (iltrou.LT.iltsuf) THEN
      iltsuf=iltrou
      irpitr=irgpif
      iarttr=iartic
      ipostr=iptrou
    ENDIF
!
    lltopt=iltsuf.EQ.klong
  ENDIF
!
  ENDDO
!
  introu=introu+intrpi
  llttru=introu.EQ.inttru
ENDIF
!
!      SI L'ARTICLE A ETE TROUVE PRECEDEMMENT DANS LE FICHIER MAIS TROP
!     COURT, ET SI ON A EXPLORE TOUS LES TROUS REFERENCES DANS L'INDEX,
!     ON ARRETE L'EXPLORATION DE L'INDEX.
!
IF (llttru.AND.kartex.NE.0) GOTO 240
!
!     .... FIN DE "BOUCLE", ON REMONTE POUR UNE EVENTUELLE SUITE ...
!
229 CONTINUE
inpage=inpage+1
!
IF (inpage.LE.intppi) THEN
  GOTO 201
ELSE
  GOTO 240
ENDIF
!
230 CONTINUE
!*
!     2.3 - CAS OU L'ON A CREE UN TROU DE LONGUEUR NULLE DANS L'INDEX
!           ON STOCKE DE QUOI S'EN OCCUPER PLUS TARD, A LA FERMETURE.
!-----------------------------------------------------------------------
!
IF (lfi%NTRULZ(irang).EQ.0) THEN
  lfi%NRFPTZ(irang)=iposex
  lfi%NRFDTZ(irang)=iposex
ELSE
  lfi%NRFPTZ(irang)=min(lfi%NRFPTZ(irang),iposex)
  lfi%NRFDTZ(irang)=max(lfi%NRFDTZ(irang),iposex)
ENDIF
!
lfi%NTRULZ(irang)=lfi%NTRULZ(irang)+1
!
240 CONTINUE
IF (lfi%LMISOP)                                               &
&  WRITE (unit=lfi%NULOUT,fmt=*)'LFIREE - APRES ETIQUETTE 240'
!*
!     2.4 - CALCUL DE LA VARIATION DU NOMBRE DE TROUS REFERENCES
!           DANS L'INDEX.
!-----------------------------------------------------------------------
!
IF (kartex.NE.0.AND.kartec.EQ.0.AND..NOT.lltsuf) THEN
  kdtrou=1
ELSEIF (kartex.EQ.0.AND.lltsuf) THEN
  kdtrou=-1
ELSE
  kdtrou=0
ENDIF
!*
!     2.5  -   QUAND AUCUN EMPLACEMENT CONVENABLE N'A ETE TROUVE,
!              IL RESTE A DEFINIR LE RANG DE L'ARTICLE DANS LE FICHIER,
!              AINSI QUE LA POSITION DU PREMIER MOT DE DONNEES A ECRIRE.
!-----------------------------------------------------------------------
!
IF (kartec.EQ.0) THEN
!
  IF (lltsuf) THEN
    krpiec=irpitr
    kartec=iarttr
    kposec=ipostr
  ELSE
    krpiec=1+inbalo/inalpp
    kartec=inbalo+1-inalpp*(krpiec-1)
!
    IF (lfi%NALDPI(irang).EQ.inalpp                     &
&        .AND.intppi.EQ.(inbpir+ilarph-lfi%JPLDOC)) THEN
      krep=-17
      GOTO 1001
    ENDIF
!
!     DEFINITION DE LA POSITION OU ECRIRE, DANS LE CAS D'UN ARTICLE
!     LOGIQUE SUPPLEMENTAIRE.
!
    IF (inbalo.EQ.0) THEN
      kposec=(1+2*inbpir)*ilarph+1
    ELSE
      irpimd=lfi%MRGPIM(lfi%NPODPI(irang),irang)
      inaldp=lfi%NALDPI(irang)
      kposec=lfi%MLGPOS(ixm(2*inaldp,irpimd))    &
&             +lfi%MLGPOS(ixm(2*inaldp-1,irpimd))
!
      IF (intppi.GT.inbpir) THEN
        irpifd=lfi%MDES1D(ixm(ilarph+1-(intppi-inbpir),irang))+1
        kposec=max(kposec,1+ilarph*irpifd)
      ENDIF
!
    ENDIF
!
  ENDIF
!
ENDIF
!
GOTO 1001
!**
!     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
!      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
!-----------------------------------------------------------------------
!
903 CONTINUE
iretou=1
clacti='WRITE'
GOTO 909
!
904 CONTINUE
iretou=2
clacti='READ'
!
909 CONTINUE
krep=abs(krep)
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE INTERNE EVENTUELLE,
!            VIA LE SOUS-PROGRAMME "LFIEMS", PUIS RETOUR.
!-----------------------------------------------------------------------
!
1001 CONTINUE
llfata=llmoer(krep,krang)
!
IF (krep.EQ.0) THEN
  kretin=0
ELSEIF (krep.GT.0) THEN
  kretin=iretou
ELSE
  kretin=3
ENDIF
!
IF (lfi%LMISOP.OR.llfata) THEN
  inimes=2
  clnspr='LFIREE'
  WRITE (unit=clmess,                                              &
&         fmt='(''ARGUMENTS='',I4,'','',I3,'','''''',               &
&         A,'''''','',I7,'','',I4,'','',I4,'','',I7,'','',I4,'','', &
&         I4,'','',I9,'','',SP,I2,SS,'','',I7,'','',I2)')           &
&  krep,krang,cdnoma,klong,krpiex,kartex,klonex,                    &
&  krpiec,kartec,kposec,kdtrou,klonut,kretin
  inumer=lfi%NUMERO(krang)
  CALL lfiems_fort                                  &
&                 (lfi, inumer,inimes,krep,.false., &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (lhook) CALL dr_hook('LFIREE_FORT',1,zhook_handle)

CONTAINS

#include "lficom2.ixc.h"
#include "lficom2.ixm.h"
#include "lficom2.llmoer.h"

END SUBROUTINE lfiree_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfiree64                                            &
&           (krep, krang, cdnoma, klong, krpiex, kartex, klonex, &
&           krpiec, kartec, kposec, kdtrou, klonut, kretin)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KREP                                   !   OUT
INTEGER (KIND=JPLIKB)  KRANG                                  ! IN   
CHARACTER (LEN=*)      CDNOMA                                 ! IN   
INTEGER (KIND=JPLIKB)  KLONG                                  ! IN   
INTEGER (KIND=JPLIKB)  KRPIEX                                 !   OUT
INTEGER (KIND=JPLIKB)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKB)  KLONEX                                 !   OUT
INTEGER (KIND=JPLIKB)  KRPIEC                                 !   OUT
INTEGER (KIND=JPLIKB)  KARTEC                                 !   OUT
INTEGER (KIND=JPLIKB)  KPOSEC                                 !   OUT
INTEGER (KIND=JPLIKB)  KDTROU                                 !   OUT
INTEGER (KIND=JPLIKB)  KLONUT                                 !   OUT
INTEGER (KIND=JPLIKB)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfiree_fort                                            &
&           (lfi, krep, krang, cdnoma, klong, krpiex, kartex, &
&           klonex, krpiec, kartec, kposec, kdtrou, klonut,   &
&           kretin)

END SUBROUTINE lfiree64

SUBROUTINE lfiree                                              &
&           (krep, krang, cdnoma, klong, krpiex, kartex, klonex, &
&           krpiec, kartec, kposec, kdtrou, klonut, kretin)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KRANG                                  ! IN   
CHARACTER (LEN=*)      CDNOMA                                 ! IN   
INTEGER (KIND=JPLIKM)  KLONG                                  ! IN   
INTEGER (KIND=JPLIKM)  KRPIEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KLONEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KRPIEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KPOSEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KDTROU                                 !   OUT
INTEGER (KIND=JPLIKM)  KLONUT                                 !   OUT
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfiree_mt                                              &
&           (lfi, krep, krang, cdnoma, klong, krpiex, kartex, &
&           klonex, krpiec, kartec, kposec, kdtrou, klonut,   &
&           kretin)

END SUBROUTINE lfiree

SUBROUTINE lfiree_mt                                        &
&           (lfi, krep, krang, cdnoma, klong, krpiex, kartex, &
&           klonex, krpiec, kartec, kposec, kdtrou, klonut,   &
&           kretin)
USE lfimod, ONLY : lficom
USE lfi_precision
IMPLICIT NONE
! Arguments
type(lficom)          lfi                                    ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KRANG                                  ! IN   
CHARACTER (LEN=*)      CDNOMA                                 ! IN   
INTEGER (KIND=JPLIKM)  KLONG                                  ! IN   
INTEGER (KIND=JPLIKM)  KRPIEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KLONEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KRPIEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KPOSEC                                 !   OUT
INTEGER (KIND=JPLIKM)  KDTROU                                 !   OUT
INTEGER (KIND=JPLIKM)  KLONUT                                 !   OUT
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  IRANG                                  ! IN   
INTEGER (KIND=JPLIKB)  ILONG                                  ! IN   
INTEGER (KIND=JPLIKB)  IRPIEX                                 !   OUT
INTEGER (KIND=JPLIKB)  IARTEX                                 !   OUT
INTEGER (KIND=JPLIKB)  ILONEX                                 !   OUT
INTEGER (KIND=JPLIKB)  IRPIEC                                 !   OUT
INTEGER (KIND=JPLIKB)  IARTEC                                 !   OUT
INTEGER (KIND=JPLIKB)  IPOSEC                                 !   OUT
INTEGER (KIND=JPLIKB)  IDTROU                                 !   OUT
INTEGER (KIND=JPLIKB)  ILONUT                                 !   OUT
INTEGER (KIND=JPLIKB)  IRETIN                                 !   OUT
! Convert arguments

irang      = int(     krang, jplikb)
ilong      = int(     klong, jplikb)

CALL lfiree_fort                                            &
&           (lfi, irep, irang, cdnoma, ilong, irpiex, iartex, &
&           ilonex, irpiec, iartec, iposec, idtrou, ilonut,   &
&           iretin)

krep       = int(      irep, jplikm)
krpiex     = int(    irpiex, jplikm)
kartex     = int(    iartex, jplikm)
klonex     = int(    ilonex, jplikm)
krpiec     = int(    irpiec, jplikm)
kartec     = int(    iartec, jplikm)
kposec     = int(    iposec, jplikm)
kdtrou     = int(    idtrou, jplikm)
klonut     = int(    ilonut, jplikm)
kretin     = int(    iretin, jplikm)

END SUBROUTINE lfiree_mt

!INTF KREP            OUT 
!INTF KRANG         IN    
!INTF CDNOMA        IN    
!INTF KLONG         IN    
!INTF KRPIEX          OUT 
!INTF KARTEX          OUT 
!INTF KLONEX          OUT 
!INTF KRPIEC          OUT 
!INTF KARTEC          OUT 
!INTF KPOSEC          OUT 
!INTF KDTROU          OUT 
!INTF KLONUT          OUT 
!INTF KRETIN          OUT