lficaq.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lficaq_fort                                            &
&                     (lfi, krep, krang, krgpim, kartex, 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 DE L'ARTICLE LOGIQUE *DE DONNEES* PRECEDENT, DANS UNE
!     UNITE LOGIQUE DONNEE.
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
!                KRANG  (ENTREE) ==> RANG ( DANS LA TABLE *LFI%NUMERO* )
!                                    DE L'UNITE LOGIQUE CONCERNEE;
!                KRGPIM (SORTIE) ==> RANG DANS LES TABLES LFI%CNOMAR,LFI%MLGPOS,
!                                    ETC. DE LA P.P.I OU FIGURE
!                                    L'ARTICLE ( 0 SI PAS TROUVE );
!                KARTEX (SORTIE) ==> RANG ( DANS LA PAGE D'INDEX ) DE L'
!                                    ARTICLE S'IL EXISTE ( 0 SINON );
!                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KREP, KRANG, KRGPIM, KARTEX 
INTEGER (KIND=JPLIKB) IRANG, INBALO, INALPP, INTPPI
INTEGER (KIND=JPLIKB) INPPIM, IDERGF, IRANGF, IRGPIF 
INTEGER (KIND=JPLIKB) IRGPIM, IRANGM, ILFORC, J
INTEGER (KIND=JPLIKB) INPILE, IARTIK, IARTIC, IRETOU 
INTEGER (KIND=JPLIKB) INIMES, INUMER, KRETIN
INTEGER (KIND=JPLIKB) IRETIN
!
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('LFICAQ_FORT',0,zhook_handle)
clacti=''
iretou=0
!
IF (krang.LE.0.OR.krang.GT.lfi%JPNXFI) THEN
  krep=-16
  GOTO 1001
ENDIF
!
irang=krang
krep=0
krgpim=0
kartex=0
inbalo=lfi%MDES1D(ixm(lfi%JPNALO,irang))
inalpp=lfi%JPNAPP*lfi%MFACTM(irang)
intppi=(inbalo-1+inalpp)/inalpp
inppim=lfi%NPPIMM(irang)
!
IF (lfi%NPRECF(irang).EQ.lfi%JPNIL) THEN
!
!           ON N'A DONC PAS ENCORE APPELE CE SOUS-PROGRAMME POUR
!        RECHERCHER CET ARTICLE ( A PRIORI, VIA *LFICAP* ) .
!
  IF (lfi%NDERGF(irang).EQ.lfi%JPNIL) THEN
    idergf=inbalo+1
  ELSE
    idergf=lfi%NDERGF(irang)
  ENDIF
!
  IF (idergf.LE.1) THEN
    lfi%NPRECF(irang)=0
    GOTO 1001
  ENDIF
!
  irangf=idergf-1
!
ELSEIF (lfi%NPRECF(irang).EQ.0) THEN
!
!        PLUS D'ARTICLE LOGIQUE "PRECEDENT" A LIRE .
!
  GOTO 1001
ELSEIF (lfi%NDERGF(irang).EQ.lfi%JPNIL.OR.           &
&        lfi%NPRECF(irang).LT.lfi%NDERGF(irang)) THEN
  irangf=lfi%NPRECF(irang)
ELSE
  krep=-16
  GOTO 1001
ENDIF
!**
!     2.  -  EXPLORATION DES (PAIRES DE) PAGES ET ARTICLES D'INDEX,
!            A LA RECHERCHE DE L'ARTICLE LOGIQUE DEMANDE,
!            DEFINI PAR SON RANG "A PRIORI" DANS LE FICHIER.
!            ( MAIS IL FAUT "SAUTER" LES TROUS )
!-----------------------------------------------------------------------
!*
!     2.1 -  RECHERCHE DANS LES PAGES D'INDEX .
!-----------------------------------------------------------------------
!
irgpif=1+(irangf-1)/inalpp
!
211 CONTINUE
!
IF (irangf.LE.inalpp) THEN
  irgpim=lfi%MRGPIM(1,irang)
  GOTO 215
ELSEIF (irangf.GT.inalpp*(intppi-1)) THEN
  irgpim=lfi%MRGPIM(lfi%NPODPI(irang),irang)
  GOTO 215
ENDIF
!
DO j=2,inppim
irgpim=lfi%MRGPIM(j,irang)
IF (lfi%MRGPIF(irgpim).EQ.irgpif) GOTO 215
ENDDO
!
!        MISE EN MEMOIRE DE L'ARTICLE D'INDEX "NOMS" CHERCHE.
!
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)
!
215 CONTINUE
iartik=irangf-inalpp*(irgpif-1)
!
!         ON CHERCHE LE PREMIER ARTICLE LOGIQUE *DE DONNEES* DE LA PAGE
!       D'INDEX, A PARTIR DU RANG *IARTIK* DANS CETTE PAGE.
!
DO j=iartik,1,-1
!
IF (lfi%CNOMAR(ixc(j,irgpim)).NE.' ') THEN
  iartic=j
  GOTO 220
ENDIF
!
ENDDO
!
!        CHOU BLANC POUR CETTE PAGE... A PRIORI, ON VA CHERCHER DANS
!     LA P.A.I. PRECEDENTE, EN RANG DANS LE FICHIER.
!
IF (irgpif.GT.1) THEN
  irgpif=irgpif-1
  irangf=inalpp*irgpif
  GOTO 211
ENDIF
!
!    SI ON ARRIVE ICI, C'EST QUE LE PREMIER ARTICLE LOGIQUE EST UN TROU
!
lfi%NPRECF(irang)=0
GOTO 1001
!*
!     2.2 -  ARTICLE DE DONNEES REPERE, ON RENVOIE SES CARACTERISTIQUES.
!-----------------------------------------------------------------------
!
220 CONTINUE
krgpim=irgpim
kartex=iartic
lfi%NPRECF(irang)=(irgpif-1)*inalpp+iartic
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
  inumer=lfi%NUMERO(krang)
  inimes=2
  clnspr='LFICAQ'
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I3,       &
&         '', KRGPIM='',I3,'', KARTEX='',I5,'', KRETIN='',I2)') &
&    krep,krang,krgpim,kartex,kretin
  CALL lfiems_fort                                  &
&                 (lfi, inumer,inimes,krep,.false., &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (lhook) CALL dr_hook('LFICAQ_FORT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE lficaq_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lficaq64                             &
&           (krep, krang, krgpim, kartex, 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   
INTEGER (KIND=JPLIKB)  KRGPIM                                 !   OUT
INTEGER (KIND=JPLIKB)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKB)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lficaq_fort                                     &
&           (lfi, krep, krang, krgpim, kartex, kretin)

END SUBROUTINE lficaq64

SUBROUTINE lficaq                               &
&           (krep, krang, krgpim, kartex, 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   
INTEGER (KIND=JPLIKM)  KRGPIM                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lficaq_mt                                       &
&           (lfi, krep, krang, krgpim, kartex, kretin)

END SUBROUTINE lficaq

SUBROUTINE lficaq_mt                                 &
&           (lfi, krep, krang, krgpim, kartex, 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   
INTEGER (KIND=JPLIKM)  KRGPIM                                 !   OUT
INTEGER (KIND=JPLIKM)  KARTEX                                 !   OUT
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  IRANG                                  ! IN   
INTEGER (KIND=JPLIKB)  IRGPIM                                 !   OUT
INTEGER (KIND=JPLIKB)  IARTEX                                 !   OUT
INTEGER (KIND=JPLIKB)  IRETIN                                 !   OUT
! Convert arguments

irang      = int(     krang, jplikb)

CALL lficaq_fort                                     &
&           (lfi, irep, irang, irgpim, iartex, iretin)

krep       = int(      irep, jplikm)
krgpim     = int(    irgpim, jplikm)
kartex     = int(    iartex, jplikm)
kretin     = int(    iretin, jplikm)

END SUBROUTINE lficaq_mt

!INTF KREP            OUT 
!INTF KRANG         IN    
!INTF KRGPIM          OUT 
!INTF KARTEX          OUT 
!INTF KRETIN          OUT