lfifer.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
! Sep-2012 P. Marguinaud Fix uninitialized variables

SUBROUTINE lfifer_fort                             &
&                     (lfi, krep, knumer, cdsttc )
USE lfimod, ONLY : lficom
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        SOUS-PROGRAMME DE FERMETURE D'UN FICHIER INDEXE AU SENS DU
!     LOGICIEL DE FICHIERS INDEXES LFI.
!        CETTE FERMETURE EST VITALE SI LE FICHIER A ETE MODIFIE DEPUIS
!     LA DERNIERE OUVERTURE, ET EST DE TOUTE MANIERE CHAUDEMENT
!     RECOMMANDEE AVANT DE SORTIR DU PROGRAMME UTILISATEUR.
!
!        De maniere generale, il vaut mieux fermer une unite logique
!     des que l'on n'en a plus besoin, de maniere a ne pas bloquer un
!     espace dans les tables qui pourrait faire defaut lors d'une
!     ouverture ulterieure, particulierement pour un fichier "multiple"
!     qui a besoin d'espace CONTIGU dans les tables des unites logiques.
!     Par ailleurs, tout fichier ouvert (au sens FORTRAN du terme cette
!     fois) "occupe" generalement un morceau de la memoire du programme.
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
!                KNUMER (ENTREE) ==> LFI%NUMERO DE L'UNITE LOGIQUE;
!                CDSTTC (ENTREE) ==> "STATUS" EVENTUEL POUR "CLOSE".
!
!    Modifications:
!
!    02/06/97, Jean Clochard.
!
!              -Modification des impressions pour que l'annee puisse
!               etre imprimee avec 4 chiffres.
!
!
TYPE(lficom) :: LFI
CHARACTER (LEN=*)          CDSTTC
CHARACTER (LEN=LFI%JPLSTX) CLSTTC
CHARACTER (LEN=3)          CLAUXI
!
INTEGER (KIND=JPLIKB) ITAMPO (lfi%jplarx)
INTEGER (KIND=JPLIKB) KREP, KNUMER 
INTEGER (KIND=JPLIKB) IEXPLO (lfi%jpnpia+lfi%jpnpis)
INTEGER (KIND=JPLIKB) ILSTTU, IREPX, INAPHY, IRANG, IREP 
INTEGER (KIND=JPLIKB) ILSTTC, IREC, INPPIM
INTEGER (KIND=JPLIKB) IFACTM, ILARPH, INALPP, INBALO, INTPPI
INTEGER (KIND=JPLIKB) INTRLZ, IDECAL, J
INTEGER (KIND=JPLIKB) IPOTZC, IRGPFC, IRGPMC, ILFORC, INPILE
INTEGER (KIND=JPLIKB) INIMES, IPOTZS, JJ
INTEGER (KIND=JPLIKB) IRGPFS, IPOTZE, IRGPMS, INTCON, IPOSFE
INTEGER (KIND=JPLIKB) JNPAGE, IRGPFE, JR
INTEGER (KIND=JPLIKB) IRGPME, IRANGM, IDECDB, INBARE, IRGPC2
INTEGER (KIND=JPLIKB) IRGPS2, IDECDC
INTEGER (KIND=JPLIKB) INBARC, IDECDS, INBARS, INBART, INTPPN
INTEGER (KIND=JPLIKB) ILOMIN, ILOMAX
INTEGER (KIND=JPLIKB) IRPIFN, INPIME, IDEBEX, IRGPIM, IRGPIF
INTEGER (KIND=JPLIKB) INLNOM, IDEBUT
INTEGER (KIND=JPLIKB) ILONGA, INALDO, IPOSNU, IRANIE, IRETIN
INTEGER (KIND=JPLIKB) IAUXIL
!
LOGICAL LLSTTU, LLVERF, LLVERG, LLECRD, LLIMST
!
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!**
!     1.  -  CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIFER_FORT',0,zhook_handle)
clacti=''
itampo=0

IF (lfi%LMISOP) WRITE (unit=lfi%NULOUT,fmt=*)'DEBUT LFIFER'
clacti=''
clnspr='LFIFER'
ilsttu=min(int(len(clsttc), jplikb),  &
&            int(len(cdsttc), jplikb))
clsttc=cdsttc(:ilsttu)
irepx=0
inaphy=0
llverf=.false.
llverg=.false.
CALL lfinum_fort                    &
&               (lfi, knumer,irang)
!
IF (irang.EQ.0) THEN
  irep=-1
  GOTO 1001
ENDIF
!
 IF (lfi%LMULTI) CALL lfiver_fort                              &
&                                (lfi, lfi%VERRUE(irang),'ON')
llverf=lfi%LMULTI
!
IF (cdsttc.EQ.'KEEP'.AND.lfi%CSTAOP(irang).EQ.'SCRATCH') THEN
  irep=-19
  llfata=llmoer(irep,irang)
!
  IF (llfata) THEN
    GOTO 1001
  ELSE
!
!        SI L'ERREUR (-19) N'EST PAS FATALE, ON FERME L'UNITE LOGIQUE,
!       MAIS SANS PRECISER DE DIRECTIVE "STATUS" DANS LE "CLOSE".
!
    llsttu=.false.
    GOTO 105
  ENDIF
!
ELSE
  llsttu=cdsttc.EQ.'KEEP'.OR.cdsttc.EQ.'DELETE'
!
  IF (llsttu) THEN
    ilsttc=int(index(cdsttc,' '), jplikb)-1
    IF (ilsttc.GT.0) ilsttu=ilsttc
    clsttc=cdsttc(:ilsttu)
  ELSE
    clsttc=lfi%CHINCO(:ilsttu)
  ENDIF
!
ENDIF
!
irep=0
!
105 CONTINUE
irepx=irep
inppim=lfi%NPPIMM(irang)
ifactm=lfi%MFACTM(irang)
ilarph=lfi%JPLARD*ifactm
inalpp=lfi%JPNAPP*ifactm
inbalo=lfi%MDES1D(ixm(lfi%JPNALO,irang))
intppi=(inbalo-1+inalpp)/inalpp
!**
!     2.  -  TRAITEMENT D'EVENTUELS "TROUS" D'INDEX DE LONGUEUR ZERO.
!            CES "PARASITES" PEUVENT AVOIR ETE CREES PAR LE RECYCLAGE
!            DE TROUS DANS LE FICHIER; ON VA LES SUPPRIMER.
!
!         L'ALGORITHME CHOISI N'EST PEUT-ETRE PAS LE PLUS EFFICACE;
!     MAIS A PARTIR DU MOMENT OU LA PROBABILITE DE GENERER DES TROUS
!     DE LONGUEUR NULLE EST FAIBLE, ET OU ON NE LES RETASSE
!     QU'A LA FERMETURE, IL N'Y A PAS LIEU DE RAFFINER A OUTRANCE !
!-----------------------------------------------------------------------
!
intrlz=lfi%NTRULZ(irang)
IF (intrlz.EQ.0) GOTO 300
!
idecal=0
ipotzc=lfi%NRFPTZ(irang)
irgpfc=1+(ipotzc-1)/inalpp
!*
!     2.1 - MISE EN MEMOIRE DE LA PREMIERE P.A.I. AYANT UN TEL TROU.
!-----------------------------------------------------------------------
!
DO j=1,inppim
irgpmc=lfi%MRGPIM(j,irang)
!
IF (lfi%MRGPIF(irgpmc).EQ.irgpfc) THEN
!
IF (.NOT.lfi%LPHASP(irgpmc)) THEN
!
  CALL lfipha_fort                                &
&                 (lfi, irep,irang,irgpmc,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 220
!
ENDIF
!
ENDDO
!
ilforc=irgpfc+1
inpile=2
CALL lfipim_fort                                       &
&               (lfi, irep,irang,irangm,irgpmc,irgpfc, &
&                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)
!
220 CONTINUE
!*
!     2.2 - AMORCAGE DE LA RECHERCHE DU NOMBRE DE TROUS NULS CONSECUTIFS
!           ET DE L'EVENTUEL TROU NUL "SUIVANT" CE PAQUET.
!-----------------------------------------------------------------------
!
ipotzs=ipotzc+idecal
irgpfs=1+(ipotzs-1)/inalpp
ipotze=ipotzs
irgpms=0
!
!       ON ELIMINE LES CAS "TRIVIAUX"
!
IF (intrlz.EQ.1.OR.ipotze+intrlz.GT.inbalo) THEN
  intcon=intrlz
  iposfe=inbalo
  GOTO 250
ENDIF
!*
!     2.3 - DECOMPTE DU NOMBRE DE TROUS NULS CONSECUTIFS.
!-----------------------------------------------------------------------
!
DO jnpage=irgpfs,intppi
irgpfe=jnpage
!
DO j=1,inppim
irgpme=lfi%MRGPIM(j,irang)
!
IF (lfi%MRGPIF(irgpme).EQ.irgpfe) THEN
!
  IF (.NOT.lfi%LPHASP(irgpme)) THEN
!
    CALL lfipha_fort                                &
&                   (lfi, irep,irang,irgpme,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 233
!
ENDIF
!
ENDDO
!
inpile=2
CALL lfipim_fort                                &
&               (lfi, irep,irang,irangm,irgpme, &
&                irgpfe,irgpfc,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)
!
233 CONTINUE
IF (irgpms.EQ.0) irgpms=irgpme
idecdb=ipotze-1-(irgpfe-1)*inalpp
inbare=min(inbalo,irgpfe*inalpp)-ipotze+1
intcon=0
!
DO j=1,inbare
!
IF (lfi%MLGPOS(ixm(2*(j+idecdb)-1,irgpme)).NE.0) THEN
  intcon=intcon+j-1
  GOTO 240
ENDIF
!
ENDDO
!
intcon=intcon+inbare
ipotze=ipotze+inbare
ENDDO
!*
!     2.4 - RECHERCHE DU PROCHAIN TROU NUL, APRES LE PAQUET TROUVE.
!-----------------------------------------------------------------------
!
240 CONTINUE
ipotze=ipotze+intcon
!
!             D'ABORD, ELIMINATION DES CAS "TRIVIAUX"
!
IF (intcon.EQ.intrlz) THEN
!
!        ON A TROUVE TOUS LES TROUS NULS RESTANT.
!
  iposfe=inbalo
ELSEIF (intcon.EQ.(intrlz-1)) THEN
!
!        PLUS QU'UN SEUL TROU NUL... CE SERA DONC CELUI DE RANG MAXIMUM.
!
  iposfe=lfi%NRFDTZ(irang)-1
ELSE
!
!          CAS GENERAL.
!
  DO jnpage=irgpfe,intppi
!
  IF (jnpage.NE.irgpfe) THEN
!
    DO j=1,inppim
    irgpme=lfi%MRGPIM(j,irang)
!
    IF (lfi%MRGPIF(irgpme).EQ.jnpage) THEN
!
      IF (.NOT.lfi%LPHASP(irgpme)) THEN
!
        CALL lfipha_fort                                &
&                       (lfi, irep,irang,irgpme,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 243
!
    ENDIF
!
    ENDDO
!
    inpile=2
    CALL lfipim_fort                                       &
&                   (lfi, irep,irang,irangm,irgpme,jnpage, &
&                    irgpfc,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
!
243 CONTINUE
  idecdb=ipotze-1-(jnpage-1)*inalpp
  inbare=min(inbalo,jnpage*inalpp)-ipotze+1
!
  DO j=1,inbare
!
  IF (lfi%MLGPOS(ixm(2*(j+idecdb)-1,irgpme)).EQ.0) THEN
    iposfe=(jnpage-1)*inalpp+j-1
    GOTO 250
  ENDIF
!
  ENDDO
!
  ENDDO
!
ENDIF
!
250 CONTINUE
!*
!     2.5 - RETASSAGE "A GAUCHE" D'UNE PARTIE DE L'INDEX.
!-----------------------------------------------------------------------
!
idecal=idecal+intcon
!
251 CONTINUE
ipotzs=ipotzc+idecal
irgpc2=1+(ipotzc-1)/inalpp
irgps2=1+(ipotzs-1)/inalpp
!
IF (irgpc2.NE.irgpfc) THEN
  irgpfc=irgpc2
!
  DO j=2,inppim
  irgpmc=lfi%MRGPIM(j,irang)
!
  IF (lfi%MRGPIF(irgpmc).EQ.irgpfc) THEN
!
    IF (.NOT.lfi%LPHASP(irgpmc)) THEN
!
      CALL lfipha_fort                                &
&                     (lfi, irep,irang,irgpmc,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 254
!
  ENDIF
!
  ENDDO
!
  inpile=2
  CALL lfipim_fort                                       &
&                 (lfi, irep,irang,irangm,irgpmc,irgpfc, &
&                  irgps2,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
!
254 CONTINUE
!
IF (irgps2.NE.irgpfs) THEN
  irgpfs=irgps2
!
  DO j=2,inppim
  irgpms=lfi%MRGPIM(j,irang)
!
  IF (lfi%MRGPIF(irgpms).EQ.irgpfs) THEN
!
    IF (.NOT.lfi%LPHASP(irgpms)) THEN
!
      CALL lfipha_fort                                &
&                     (lfi, irep,irang,irgpms,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 257
!
  ENDIF
!
  ENDDO
!
  inpile=2
  CALL lfipim_fort                                       &
&                 (lfi, irep,irang,irangm,irgpms,irgpfs, &
&                  irgpfc,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
!
257 CONTINUE
idecdc=ipotzc-1+(irgpfc-1)/inalpp
inbarc=min(inbalo-idecal,irgpfc*inalpp)-ipotzc+1
idecds=ipotzs-1+(irgpfs-1)/inalpp
inbars=min(inbalo,irgpfs*inalpp)-ipotzs+1
inbart=min(inbarc,inbars)
!
DO j=1,inbart
lfi%CNOMAR(ixc(idecdc+j,irgpmc))=lfi%CNOMAR(ixc(idecds+j,irgpms))
ENDDO
!
DO j=1,2*inbart
lfi%MLGPOS(ixm(2*idecdc+j,irgpmc))=                   &
&                   lfi%MLGPOS(ixm(2*idecds+j,irgpms))
ENDDO
!
ipotzc=ipotzc+inbart
!
IF (ipotzs+inbart.LT.iposfe) THEN
  GOTO 251
ELSEIF (iposfe.LT.inbalo) THEN
  GOTO 220
ENDIF
!*
!     2.6 - MISE A JOUR DE CERTAINES TABLES.
!-----------------------------------------------------------------------
!
lfi%NBTROU(irang)=lfi%NBTROU(irang)-idecal
inbalo=inbalo-idecal
lfi%MDES1D(ixm(lfi%JPNALO,irang))=inbalo
intppn=(inbalo-1+inalpp)/inalpp
lfi%NALDPI(irang)=inbalo-(intppn-1)*inalpp
!
IF (intppn.NE.intppi) THEN
!
!           ON A DONC LAISSE DES P.P.I. "PARASITES" EN MEMOIRE.
!        A PRIORI CE N'EST PAS GENANT, CAR ON VA BIENTOT RELACHER
!        TOUTES CELLES RELATIVES AU FICHIER QUE L'ON TRAITE.
!        NEANMOINS IL EST PREFERABLE DE REDEFINIR LE RANG EN MEMOIRE
!        DE LA DERNIERE P.P.I. DU FICHIER.
!
  lfi%NPODPI(irang)=irgpmc
  intppi=intppn
ENDIF
!
300 CONTINUE
!**
!     3.  -  CAS OU IL FAUT RECALCULER LES LONGUEURS EXTREMES DES
!            ARTICLES DE DONNEES.
!-----------------------------------------------------------------------
!
IF (.NOT.lfi%LMIMAL(irang)) GOTO 400
!*
!     3.1 - EXPLORATION DES P.P.I., PUIS EVENTUELLEMENT DES P.A.I. .
!-----------------------------------------------------------------------
!
ilomin=0
ilomax=0
irpifn=1
inpime=0
!
IF (lfi%NPODPI(irang).EQ.2) THEN
  idebex=3
ELSE
  idebex=2
ENDIF
!
DO jnpage=1,intppi
!
IF (jnpage.LE.inppim) THEN
!
!           IL S'AGIT D'UNE EXPLORATION EN MEMOIRE ( PAGES D'INDEX ).
!
  irgpim=lfi%MRGPIM(jnpage,irang)
  irgpif=lfi%MRGPIF(irgpim)
  inpime=inpime+1
  iexplo(inpime)=irgpif
  IF (irgpif.EQ.(irpifn+1)) irpifn=irgpif
!
  IF (.NOT.lfi%LPHASP(irgpim)) THEN
!
    CALL lfipha_fort                                &
&                   (lfi, irep,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
!
ELSE
!
!           IL S'AGIT D'UNE EXPLORATION "HORS MEMOIRE";
!         ON CHERCHE LA PROCHAINE P.A.I. NON EXPLOREE .
!
  IF (jnpage.EQ.inppim+1) irgpif=irpifn
!
311 CONTINUE
  irgpif=irgpif+1
!
  DO j=idebex,inpime
  IF (iexplo(j).EQ.irgpif) GOTO 311
  ENDDO
!
  ilforc=1
  inpile=2
  CALL lfipim_fort                                       &
&                 (lfi, irep,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
!
ENDIF
!
inbart=min(inalpp,inbalo-(irgpif-1)*inalpp)
!
IF (ilomin.EQ.0) THEN
!
  DO j=1,inbart
!
  IF (lfi%CNOMAR(ixc(j,irgpim)).NE.' ') THEN
    ilomin=lfi%MLGPOS(ixm(2*j-1,irgpim))
    ilomax=ilomin
    idebut=j+1
    GOTO 315
  ENDIF
!
  ENDDO
!
  cycle
ELSE
  idebut=1
ENDIF
!
315 CONTINUE
!
DO j=idebut,inbart
!
IF (lfi%CNOMAR(ixc(j,irgpim)).NE.' ') THEN
  ilonga=lfi%MLGPOS(ixm(2*j-1,irgpim))
  ilomin=min(ilonga,ilomin)
  ilomax=max(ilonga,ilomax)
ENDIF
!
ENDDO
!
ENDDO   
!*
!     3.2 - MISE A JOUR DES TABLES CONCERNEES.
!-----------------------------------------------------------------------
!
lfi%MDES1D(ixm(lfi%JPLNAL,irang))=ilomin
lfi%MDES1D(ixm(lfi%JPLXAL,irang))=ilomax
!
400 CONTINUE
!**
!     4.  -  "VIDAGE" SUR FICHIER DES PAGES RESTANT A ECRIRE.
!-----------------------------------------------------------------------
!*
!     4.1 -  PAGES DE *DONNEES* RESTANT A ECRIRE.
!-----------------------------------------------------------------------
!
DO j=0,lfi%JPNPDF-1
!
IF (lfi%LECRPD(j,irang)) THEN
!
  CALL lfivid_fort                                     &
&                 (lfi, irep,irang,j,itampo(1),iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.EQ.2) THEN
    GOTO 904
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ENDIF
!
ENDIF
!
ENDDO
!*
!     4.2 -  (PAIRES DE) PAGES D'*INDEX* RESTANT A ECRIRE.
!-----------------------------------------------------------------------
!
inppim=lfi%NPPIMM(irang)
!
DO j=1,inppim
irgpim=lfi%MRGPIM(j,irang)
irgpif=lfi%MRGPIF(irgpim)
CALL lfirec_fort                         &
&               (lfi, irgpif,irang,irec)
!
IF (lfi%LECRPI(irgpim,1)) THEN
!
  IF (j.EQ.lfi%NPODPI(irang).AND.lfi%NALDPI(irang).NE.inalpp) THEN
!
!          COMPLEMENT DE LA DERNIERE PAGE D'INDEX NOMS AVEC UN NOM
!        CONVENTIONNEL.
!
    DO jj=lfi%NALDPI(irang)+1,lfi%JPNXNA*ifactm
    lfi%CNOMAR(ixc(jj,irgpim))='**FIN D''INDEX**'
    ENDDO
!
  ENDIF
!
  inaphy=irec
  CALL lfiecc_fort                                      &
&                 (lfi, irep,knumer,irec,             &
&                  lfi%CNOMAR(ixc(1_jplikb ,irgpim)), &
&                  lfi%NBWRIT(irang),ifactm,          &
&                  lfi%YLFIC (irang),iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ENDIF
!
  lfi%LECRPI(irgpim,1)=.false.
ENDIF
!
IF (lfi%LECRPI(irgpim,2).AND.lfi%LPHASP(irgpim)) THEN
!
  IF (j.EQ.lfi%NPODPI(irang).AND.lfi%NALDPI(irang).NE.inalpp) THEN
!
!          COMPLEMENT DE LA DERNIERE PAGE D'INDEX LONGUEUR/POSITION
!        AVEC DES ZEROS.
!
    DO jj=2*lfi%NALDPI(irang)+1,ilarph
    lfi%MLGPOS(ixm(jj,irgpim))=0
    ENDDO
!
  ENDIF
!
  inaphy=irec+1
  CALL lfiedo_fort                                      &
&                 (lfi, irep,knumer,irec+1,           &
&                  lfi%MLGPOS(ixm(1_jplikb ,irgpim)), &
&                  lfi%NBWRIT(irang),ifactm,          &
&                  lfi%YLFIC (irang),iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ENDIF
!
  lfi%LECRPI(irgpim,2)=.false.
ENDIF
!
ENDDO
!*
!     4.3 -  CAS DE L'ARTICLE DOCUMENTAIRE, SI NECESSAIRE.
!-----------------------------------------------------------------------
!
llecrd=lfi%LMODIF(irang).OR.lfi%NBWRIT(irang).NE.0
!
IF (llecrd) THEN
!
!        AU PREALABLE, MISE A JOUR DE CET ARTICLE DOCUMENTAIRE.
!
  iauxil=ixm(lfi%JPNRES,irang)
  lfi%MDES1D(iauxil)=lfi%MDES1D(iauxil)+lfi%NREESP(irang)
  iauxil=ixm(lfi%JPNREC,irang)
  lfi%MDES1D(iauxil)=lfi%MDES1D(iauxil)+lfi%NREECO(irang)
  iauxil=ixm(lfi%JPNREL,irang)
  lfi%MDES1D(iauxil)=lfi%MDES1D(iauxil)+lfi%NREELO(irang)
  iauxil=ixm(lfi%JPNTRU,irang)
  lfi%MDES1D(iauxil)=lfi%MDES1D(iauxil)+lfi%NBTROU(irang)
  CALL lfidah_fort                                         &
&                 (lfi, lfi%MDES1D(ixm(lfi%JPDDMG,irang)), &
&               lfi%MDES1D(ixm(lfi%JPHDMG,irang)))
  irec=1
  inaphy=irec
  CALL lfiedo_fort                                     &
&                 (lfi, irep,knumer,irec,            &
&                  lfi%MDES1D(ixm(1_jplikb ,irang)), &
&                  lfi%NBWRIT(irang),ifactm,         &
&                  lfi%YLFIC (irang),iretin)
!
  IF (iretin.EQ.1) THEN
    GOTO 903
  ELSEIF (iretin.NE.0) THEN
    GOTO 1001
  ENDIF
!
ENDIF
!**
!     5.  -  FERMETURE EFFECTIVE (*CLOSE*) DU FICHIER.
!-----------------------------------------------------------------------
!
inaldo=inbalo-lfi%MDES1D(ixm(lfi%JPNTRU,irang))
inaphy=0
!
IF (llsttu) THEN
  IF (knumer < 0) THEN
    CALL closec (irep, clsttc)
    IF (irep /= 0) GOTO 905
  ELSE
    CLOSE (unit=knumer,status=clsttc,err=905,iostat=irep)
  ENDIF
ELSE
!
  IF (inaldo.EQ.0) THEN
!
!       SI ON SE RETROUVE AVEC UN FICHIER "VIDE" ET QUE L'ON N'A PAS DE
!       PARAMETRE "STATUS" POUR LE "CLOSE", ON VA ESSAYER DE RELACHER LE
!       FICHIER, AFIN DE NE PAS LAISSER TRAINER UN TEL FICHIER "ZOMBIE".
!             ( "VIDE" = SANS ARTICLE LOGIQUE DE DONNEES )
!       ON N'A PAS DE GARANTIE D'Y ARRIVER, DANS LA MESURE OU ON N'EST
!       PAS SUR D'AVOIR DES DROITS D'ACCES SUFFISANTS.
!
    IF (knumer < 0) THEN
      CALL closec (irep, 'DELETE')
      IF (irep /= 0) GOTO 511
    ELSE
      CLOSE (unit=knumer,status='DELETE',err=511)
    ENDIF
    clsttc='DELETE'
    llsttu=.true.
    GOTO 600
  ENDIF
!
511 CONTINUE
!
IF (knumer < 0) THEN
  CALL closec (irep, 'KEEP')
  IF (irep /= 0) GOTO 905
ELSE
  CLOSE (unit=knumer,err=905,iostat=irep)
ENDIF
!
ENDIF
!
600 CONTINUE
!**
!     6.  -  IMPRESSION EVENTUELLE DE STATISTIQUES D'UTILISATION.
!-----------------------------------------------------------------------
!
lfi%NDEROP(irang)=9
lfi%NDERCO(irang)=irep
llimst=lfi%NISTAG.EQ.2.OR.(lfi%NISTAG.EQ.1.AND.lfi%LISTAT(irang))
IF (llimst) CALL lfiist_fort                    &
&                           (lfi, irang,.true.)
!**
!     7.  -  "NETTOYAGE" DES TABLES AYANT PERMIS DE GERER LE FICHIER.
!            ( AU MOINS CELLES AYANT UN CARACTERE "GLOBAL"; A NOTER
!              TOUTEFOIS QU'ON NE TOUCHE PAS AUX CARACTERISTIQUES DES
!              PAGES D'INDEX PREAFFECTEES )
!-----------------------------------------------------------------------
!
 IF (lfi%LMULTI) CALL lfiver_fort                       &
&                                (lfi, lfi%VERGLA,'ON')
llverg=lfi%LMULTI
!
DO j=2,min(inppim,lfi%JPNPIA)
irgpim=lfi%MRGPIM(j,irang)
!
DO jr=irgpim,irgpim+ifactm-1
lfi%MRGPIF(jr)=lfi%JPNIL
ENDDO
!
ENDDO
!
DO j=lfi%JPNPIA+1,inppim
irgpim=lfi%MRGPIM(j,irang)
!
DO jr=irgpim,irgpim+ifactm-1
lfi%MCOPIF(jr)=lfi%JPNIL
lfi%MRGPIF(jr)=lfi%JPNIL
ENDDO
!
ENDDO
!
lfi%NPISAF=lfi%NPISAF-max(0_jplikb ,(inppim-lfi%JPNPIA)*ifactm)
!
DO jr=irang,irang+ifactm-1
lfi%NUMERO(jr)=lfi%JPNIL
ENDDO
!
DO j=1,lfi%NBFIOU
!
IF (lfi%NUMIND(j).EQ.irang) THEN
  iposnu=j
  GOTO 707
ENDIF
!
ENDDO
!
irep=-16
GOTO 1001
!
707 CONTINUE
!
lfi%NBFIOU=lfi%NBFIOU-1
lfi%NFACTM=lfi%NFACTM-ifactm
!
DO j=iposnu,lfi%NBFIOU
lfi%NUMIND(j)=lfi%NUMIND(j+1)
ENDDO
!*
!     7.1 -  ASPECTS SPECIFIQUES AUX TABLES D'IMPORT/EXPORT.
!-----------------------------------------------------------------------
!
IF (lfi%NEXPOR(irang).GT.0.OR.lfi%NIMPOR(irang).GT.0) THEN
  iranie=max(lfi%NEXPOR(irang),lfi%NIMPOR(irang))
  inimes=ixnims(irang)
!
  IF (inimes.GE.1) THEN
    WRITE (unit=clmess,fmt='(''KNUMER='',I3,                    &
&           '', ATTENTION: IMPORT/EXPORT NON TERMINE'')') knumer
    CALL lfiems_fort                                  &
&                   (lfi, knumer,inimes,irep,.false., &
&                    clmess,clnspr,clacti)
  ENDIF
!
  DO j=1,lfi%NUIMEX
!
  IF (lfi%NINIEX(j).EQ.iranie) THEN
    iposnu=j
    GOTO 712
  ENDIF
!
  ENDDO
!
  irep=-16
  GOTO 1001
!
712 CONTINUE
!
  lfi%MNUIEX(irang)=lfi%JPNIL
  lfi%NUIMEX=lfi%NUIMEX-1
!
  DO j=iposnu,lfi%NUIMEX
  lfi%NINIEX(j)=lfi%NINIEX(j+1)
  ENDDO
!
ENDIF
!
 IF (lfi%LMULTI) THEN
   CALL lfiver_fort                               &
&                  (lfi, lfi%VERRUE(irang),'OFF')
   CALL lfiver_fort                               &
&                  (lfi, lfi%VERRUE(irang),'REL')
 ENDIF
!
llverf=.false.
irep=irepx
GOTO 1001
!**
!     9.  - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
!-----------------------------------------------------------------------
!
903 CONTINUE
clacti='WRITE'
GOTO 909
!
904 CONTINUE
clacti='READ'
GOTO 909
!
905 CONTINUE
clacti='CLOSE'
!
909 CONTINUE
IF (inaphy.NE.0) lfi%NUMAPH(irang)=inaphy
!
!      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
!
irep=abs(irep)
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "LFIEMS" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
krep=irep
llfata=llmoer(irep,irang)
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnims(irang)
ENDIF
!
 IF (llverf) CALL lfiver_fort                               &
&                            (lfi, lfi%VERRUE(irang),'OFF')
 IF (llverg) CALL lfiver_fort                        &
&                            (lfi, lfi%VERGLA,'OFF')
!
IF (.NOT.llfata.AND.inimes.EQ.0)  THEN 
  IF (lhook) CALL dr_hook('LFIFER_FORT',1,zhook_handle)
  RETURN
ENDIF
!
IF (inimes.EQ.2) THEN
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3, &
&         '', CDSTTC='''''',A,'''''''')')                  &
&      krep,knumer,clsttc(:ilsttu)
  CALL lfiems_fort                                 &
&                 (lfi, knumer,inimes,irep,llfata, &
&                  clmess,clnspr,clacti)
ENDIF
!
!       LA MESSAGERIE QUI SUIT N'EST PAS EMISE EN CAS D'ERREUR FATALE.
!
IF (inimes.GE.1.AND.(irep.EQ.0.OR.irep.EQ.-19)) THEN
  clauxi='   '
!
  IF (lfi%LFRANC) THEN
    WRITE (unit=clmess,fmt='(''Unite'',I3, &
&           '' traitee, Fichier'',A)')      &
&            knumer,clauxi
  ELSE
    WRITE (unit=clmess,fmt='(''Unit'',I3, &
&           '' processed, File'',A)')      &
&            knumer,clauxi
  ENDIF
!
  idecal=int(index(clmess,clauxi), jplikb)
!
  IF (inbalo.EQ.0) THEN
!
    IF (lfi%LFRANC) THEN
      clmess(idecal+1:)='*VIDE*'//clauxi
    ELSE
      clmess(idecal+1:)='*EMPTY*'//clauxi
    ENDIF
!
    idecal=idecal+int(index(clmess(idecal+1:),clauxi), jplikb)
  ENDIF
!
  IF (lfi%LFRANC) THEN
!
    IF (lfi%LNOUFI(irang)) THEN
      clmess(idecal+1:)='$CREE$ &'//clauxi
    ELSEIF (llecrd) THEN
      clmess(idecal+1:)='$MODIFIE$ &'//clauxi
    ELSE
      clmess(idecal+1:)='non modifie &'//clauxi
    ENDIF
!
    idecal=idecal+int(index(clmess(idecal+1:),clauxi), jplikb)
!
    IF (.NOT.llsttu) THEN
      clmess(idecal+1:)='FERME'//clauxi
    ELSEIF (clsttc.EQ.'KEEP') THEN
      clmess(idecal+1:)='GARDE'//clauxi
    ELSE
      clmess(idecal+1:)='*RELACHE*'//clauxi
    ENDIF
!
    IF (lfi%LNOUFI(irang).OR.llecrd) THEN
      idecal=idecal+int(index(clmess(idecal+1:),clauxi), jplikb)
      WRITE (unit=clmess(idecal+1:),                              &
&             fmt='(''a'',I9.6,''_'',I6.6,                         &
&       '','',I7,'' Articles de donnees,'',I9,'' mots en tout'')') &
&       lfi%MDES1D(ixm(lfi%JPDDMG,irang)),                         &
&       lfi%MDES1D(ixm(lfi%JPHDMG,irang)),                         &
&       inaldo,ilarph*lfi%MDES1D(ixm(lfi%JPNAPH,irang))
    ENDIF
!
  ELSE
!
    IF (lfi%LNOUFI(irang)) THEN
      clmess(idecal+1:)='$CREATED$ &'//clauxi
    ELSEIF (llecrd) THEN
      clmess(idecal+1:)='$MODIFIED$ &'//clauxi
    ELSE
      clmess(idecal+1:)='not modified &'//clauxi
    ENDIF
!
    idecal=idecal+int(index(clmess(idecal+1:),clauxi), jplikb)
!
    IF (.NOT.llsttu) THEN
      clmess(idecal+1:)='CLOSED'//clauxi
    ELSEIF (clsttc.EQ.'KEEP') THEN
      clmess(idecal+1:)='KEPT'//clauxi
    ELSE
      clmess(idecal+1:)='*RELEASED*'//clauxi
    ENDIF
!
    IF (lfi%LNOUFI(irang).OR.llecrd) THEN
      idecal=idecal+int(index(clmess(idecal+1:),clauxi), jplikb)
      WRITE (unit=clmess(idecal+1:),fmt='(''at'',I9.6,''_'',   &
& I6.6,'','',I7,'' data Records,'',I9,'' words for a whole'')') &
&       lfi%MDES1D(ixm(lfi%JPDDMG,irang)),                      &
&       lfi%MDES1D(ixm(lfi%JPHDMG,irang)),                      &
&       inaldo,ilarph*lfi%MDES1D(ixm(lfi%JPNAPH,irang))
    ENDIF
!
  ENDIF
!
  CALL lfiems_fort                                  &
&                 (lfi, knumer,inimes,irep,.false., &
&                  clmess,clnspr,clacti)
!
  IF (lfi%LFRANC) THEN
    inlnom=min(lfi%NLNOMF(irang),lfi%JPLFIX, &
&                int(len(clmess), jplikb)-6)
    clmess='Nom='''//lfi%CNOMFI(irang)(1:inlnom)//''''
  ELSE
    inlnom=min(lfi%NLNOMF(irang),lfi%JPLFIX, &
&                int(len(clmess), jplikb)-7)
    clmess='Name='''//lfi%CNOMFI(irang)(1:inlnom)//''''
  ENDIF
!
  CALL lfiems_fort                                  &
&                 (lfi, knumer,inimes,irep,.false., &
&                  clmess,clnspr,clacti)
!
  IF (lfi%CNOMSY(irang)(1:lfi%NLNOMS(irang)).NE.   &
&      lfi%CNOMFI(irang)(1:lfi%NLNOMF(irang))) THEN
!
    IF (lfi%LFRANC) THEN
      inlnom=min(lfi%NLNOMS(irang),lfi%JPLFIX,  &
&                  int(len(clmess), jplikb)-14)
      clmess='Nom SYSTEME='''//                    &
&                 lfi%CNOMSY(irang)(1:inlnom)//''''
    ELSE
      inlnom=min(lfi%NLNOMS(irang),lfi%JPLFIX,  &
&                  int(len(clmess), jplikb)-14)
      clmess='SYSTEM Name='''//                     &
&                  lfi%CNOMSY(irang)(1:inlnom)//''''
    ENDIF
!
    CALL lfiems_fort                                  &
&                   (lfi, knumer,inimes,irep,.false., &
&                    clmess,clnspr,clacti)
  ENDIF
!
ENDIF
!
IF (lhook) CALL dr_hook('LFIFER_FORT',1,zhook_handle)

CONTAINS

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

SUBROUTINE closec (KREP, CDSTTC)
USE parkind1, ONLY : jpim

INTEGER (KIND=JPLIKB) KREP
CHARACTER (LEN=*)     CDSTTC

INTEGER (KIND=JPIM) IREP4

krep=0

CALL fi_fclose (irep4, lfi%YLFIC (irang)%N_C_FPDESC)
IF (irep4 /= 0) THEN
  CALL fi_errno (irep4)
  krep=irep4
ENDIF

IF (cdsttc .EQ. 'DELETE') CALL fi_unlink (irep4, trim(lfi%CNOMFI(irang)))

lfi%YLFIC (irang)%N_C_FPDESC = 0
lfi%YLFIC (irang)%N_C_OFFSET = 0
lfi%YLFIC (irang)%L_C_BTSWAP = .false.
NULLIFY (lfi%YLFIC (irang)%CNOMFI)

END SUBROUTINE closec

END SUBROUTINE lfifer_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfifer64              &
&           (krep, knumer, cdsttc)
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)  KNUMER                                 ! IN   
CHARACTER (LEN=*)      CDSTTC                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfifer_fort                       &
&           (lfi, krep, knumer, cdsttc)

END SUBROUTINE lfifer64

SUBROUTINE lfifer                &
&           (krep, knumer, cdsttc)
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)  KNUMER                                 ! IN   
CHARACTER (LEN=*)      CDSTTC                                 ! IN   

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfifer_mt                        &
&           (lfi, krep, knumer, cdsttc)

END SUBROUTINE lfifer

SUBROUTINE lfifer_mt                  &
&           (lfi, krep, knumer, cdsttc)
USE lfimod, ONLY : lficom
USE lfi_precision
IMPLICIT NONE
! Arguments
type(lficom)          lfi                                    ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
CHARACTER (LEN=*)      CDSTTC                                 ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
! Convert arguments

inumer     = int(    knumer, jplikb)

CALL lfifer_fort                       &
&           (lfi, irep, inumer, cdsttc)

krep       = int(      irep, jplikm)

END SUBROUTINE lfifer_mt

!INTF KREP            OUT 
!INTF KNUMER        IN    
!INTF CDSTTC        IN