/home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/LFI/mt/lfirac_mt.F

Go to the documentation of this file.

C Jan-2011 P. Marguinaud Thread-safe LFI
      SUBROUTINE LFIRAC_MT (LFI, KNOMAR, KNALPI, KCLE, KINDIC, KNBVAL )
      USE LFIMOD, ONLY : LFICOM
      USE PARKIND1, ONLY : JPRB
      USE YOMHOOK , ONLY : LHOOK, DR_HOOK
C****
C        SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES *LFI*;
C     RECHERCHE, DANS UNE PAGE D'INDEX "NOMS", DES OCCURENCES D'UN NOM
C     D'ARTICLE DONNE. CE SOUS-PROGRAMME NE PEUT MARCHER QUE SI LES NOMS
C     D'ARTICLES OCCUPENT UN NOMBRE ENTIER DE MOTS, ET RAISONNE EN
C     TERME DE MOTS; CE QUI SUPPOSE AUSSI QU'UN ARGUMENT D'APPEL DE TYPE
C     "CHARACTER" OCCUPANT UN NOMBRE ENTIER DE MOTS PUISSE ETRE TRAITE
C     COMME UN TABLEAU D'ENTIERS PAR LE SOUS-PROGRAMME APPELE.
C        DE PLUS, LE SOUS-PROGRAMME "WHENEQ" DOIT ETRE UTILISABLE...
C     BREF, CE SOUS-PROGRAMME NE DOIT ETRE APPELE QUE SI LE PARAMETER
C     "LPRECH" EST VRAI.
C**
C    ARGUMENTS : KNOMAR (ENTREE) ==> PAGE D'INDEX "NOMS" A EXLORER;
C                KNALPI (ENTREE) ==> NOMBRE D'ARTICLES DANS CETTE PAGE;
C                KCLE   (ENTREE) ==> NOM D'ARTICLE A RECHERCHER;
C                KINDIC (SORTIE) ==> INDICES DES NOMS TROUVES;
C                KNBVAL (SORTIE) ==> NOMBRE D'OCCURENCES DU NOM .
C*
C          Noter que la Page d'Index "Noms" peut etre multiple.
C
C
C
      TYPE(LFICOM) :: LFI
#ifndef f77
#include "precision.h"
C
      INTEGER (KIND=JPDBLE) KNOMAR (LFI%JPNMPN,LFI%JPNAPX),
     S                      KCLE (LFI%JPNMPN)
      INTEGER (KIND=JPDBLE) INOMAR (LFI%JPNAPX,
     S                           LFI%LFIRAC_JPDEBN:LFI%JPNMPN,2)
#else
      INTEGER KNOMAR (LFI%JPNMPN,LFI%JPNAPX), KCLE (LFI%JPNMPN)
      INTEGER INOMAR (LFI%JPNAPX,LFI%LFIRAC_JPDEBN:LFI%JPNMPN,2)
#endif
      INTEGER KNALPI, KNBVAL, KINDIC (LFI%JPNAPX), 
     S        INDICE (LFI%JPNAPX,LFI%JPNMPN+1)
      INTEGER INBVAL, IRECH, INARTI, J, IRECHS, JF, ISTOCK, JFOIS
#include "lficom_mt.h"
C**
C     1.  -  OCCURRENCES DU PREMIER MOT DE KCLE DANS LA PAGE D'INDEX.
C-----------------------------------------------------------------------
C
      REAL(KIND=JPRB) :: ZHOOK_HANDLE
      IF (LHOOK) CALL DR_HOOK('LFIRAC_MT',0,ZHOOK_HANDLE)
      IF (LFI%JPNMPN.EQ.1) THEN
        CALL WHENEQ (KNALPI,KNOMAR,LFI%JPNMPN,KCLE(1),KINDIC,KNBVAL)
        IF (LHOOK) CALL DR_HOOK('LFIRAC_MT',1,ZHOOK_HANDLE)
        RETURN
      ELSE
        KNBVAL=0
        CALL WHENEQ (KNALPI,KNOMAR,LFI%JPNMPN,KCLE(1), 
     S               INDICE(1,1),INBVAL)
        IF (INBVAL.EQ.0.OR.INBVAL.GT.KNALPI)  THEN 
          IF (LHOOK) CALL DR_HOOK('LFIRAC_MT',1,ZHOOK_HANDLE)
          RETURN
        ENDIF
      ENDIF
C**
C     2.  -  LE DEBUT DE KCLE A ETE TROUVE; EXTRACTION D'UNE PARTIE DE
C            LA PAGE DANS UN TABLEAU DE TRAVAIL AVANT DE POURSUIVRE .
C-----------------------------------------------------------------------
C
      IRECH=1
      INARTI=INBVAL
C
      DO 201 JFOIS=2,LFI%JPNMPN
      DO 201 J=1,INARTI
      INOMAR(J,JFOIS,IRECH)=KNOMAR(JFOIS,INDICE(J,1))
  201 CONTINUE
C**
C     3.  -  RECHERCHE DANS LES AUTRES MOTS DECRIVANT LES NOMS D'ARTICLE
C-----------------------------------------------------------------------
C
      DO 302 JFOIS=2,LFI%JPNMPN
      CALL WHENEQ (INARTI,INOMAR(1,JFOIS,IRECH),1,KCLE(JFOIS),
     S             INDICE(1,JFOIS),INBVAL)
      IF (INBVAL.EQ.0.OR.INBVAL.GT.INARTI)  THEN 
        IF (LHOOK) CALL DR_HOOK('LFIRAC_MT',1,ZHOOK_HANDLE)
        RETURN
      ENDIF
      INARTI=INBVAL
      IRECHS=3-IRECH
C
      DO 301 JF=JFOIS+1,LFI%JPNMPN
CDIR$ IVDEP
      DO 301 J=1,INARTI
      INOMAR(J,JF,IRECHS)=INOMAR(INDICE(J,JFOIS),JF,IRECH)
  301 CONTINUE
C
      IRECH=IRECHS
  302 CONTINUE
C**
C     4.  -  "COMPOSITION" DES INDICES POUR EXPRIMER LE RESULTAT EN
C            INDICES DANS LA PAGE (KNOMAR) .
C-----------------------------------------------------------------------
C
      KNBVAL=INARTI
      ISTOCK=LFI%JPNMPN
C
      DO 402 JFOIS=LFI%JPNMPN,3,-1
CDIR$ IVDEP
      DO 401 J=1,INARTI
      INDICE(J,JFOIS+1)=INDICE(INDICE(J,ISTOCK),JFOIS-1)
  401 CONTINUE
C
      ISTOCK=JFOIS+1
  402 CONTINUE
C
      DO 403 J=1,INARTI
      KINDIC(J)=INDICE(INDICE(J,ISTOCK),1)
  403 CONTINUE
C
      IF (LHOOK) CALL DR_HOOK('LFIRAC_MT',1,ZHOOK_HANDLE)
      END