lfirec.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfirec_fort                            &
&                     (lfi, krgpif, krang, krec )
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
!     DETERMINATION DU LFI%NUMERO D'ENREGISTREMENT D'UNE PAIRE D'ARTICLES
!     D'INDEX ( LFI%NUMERO DE L'ARTICLE "NOMS", EN FAIT ) .
!**
!    ARGUMENTS : KRGPIF (ENTREE) ==> RANG DE LA P.P.I. DANS LE FICHIER;
!                KRANG  (ENTREE) ==> RANG DE L'UNITE DANS LFI%NUMERO.
!                KREC   (SORTIE) ==> LFI%NUMERO D'ENREGISTREMENT DE LA P.A.I
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KRGPIF, KRANG, KREC, INBPIR 
INTEGER (KIND=JPLIKB) INBALO, IFACTM, INALPP
INTEGER (KIND=JPLIKB) ILARPH, INTPPI, IREP, INIMES, INUMER
!
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIREC_FORT',0,zhook_handle)
clacti=''
inbpir=lfi%MDES1D(ixm(lfi%JPNPIR,krang))
inbalo=lfi%MDES1D(ixm(lfi%JPNALO,krang))
ifactm=lfi%MFACTM(krang)
inalpp=lfi%JPNAPP*ifactm
ilarph=lfi%JPLARD*ifactm
intppi=(inbalo-1+inalpp)/inalpp
!
IF (krgpif.LE.inbpir) THEN
  krec=2*krgpif
ELSEIF (krgpif.LE.intppi) THEN
!
!     CAS OU LES ARTICLES D'INDEX "RESERVES" A LA CREATION DU FICHIER
!     N'ONT PAS SUFFI A STOCKER TOUS LES DESCRIPTEURS D'ARTICLES LOGI-
!     QUES: L'EMPLACEMENT DES PAIRES D'ARTICLES D'INDEX EXCEDENTAIRES
!     EST ALORS STOCKE DANS L'ARTICLE DOCUMENTAIRE, APRES LES VALEURS
!     "UTILES" (LFI%JPLDOC MOTS), EN COMMENCANT PAR LA FIN DE CET ARTICLE.
!       ( CECI POUR MENAGER UNE EVENTUELLE AUGMENTATION DE *LFI%JPLDOC*,
!         EN CAS D'EVOLUTION DU LOGICIEL )
!
  krec=lfi%MDES1D(ixm(ilarph+1-(krgpif-inbpir),krang))
ELSE
!
!          CAS OU IL Y A INCOHERENCE ENTRE TABLES ET ARGUMENTS D'APPEL
!
  krec=0
  irep=-16
!
!        MESSAGERIE EVENTUELLE, AVEC ABORT SI NECESSAIRE .
!
  llfata=llmoer(irep,krang)
!
  IF (llfata.OR.lfi%NIMESG.NE.0) THEN
    inimes=2
    clnspr='LFIREC'
    inumer=lfi%NUMERO(krang)
!
    IF (lfi%LFRANC) THEN
      WRITE (unit=clmess,fmt='(''KRGPIF='',I4,'', KRANG='',I3, &
&             '', KREC='',I6,'', CODE "INTERNE"='',I4)')        &
&        krgpif,krang,krec,irep
    ELSE
      WRITE (unit=clmess,fmt='(''KRGPIF='',I4,'', KRANG='',I3, &
&             '', KREC='',I6,'', "INTERNAL" CODE='',I4)')       &
&        krgpif,krang,krec,irep
    ENDIF
!
    CALL lfiems_fort                                 &
&                   (lfi, inumer,inimes,irep,llfata, &
&                    clmess,clnspr,clacti)
  ENDIF
!
ENDIF
!
IF (lhook) CALL dr_hook('LFIREC_FORT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE lfirec_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfirec64             &
&           (krgpif, krang, krec)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KRGPIF                                 ! IN   
INTEGER (KIND=JPLIKB)  KRANG                                  ! IN   
INTEGER (KIND=JPLIKB)  KREC                                   !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfirec_fort                     &
&           (lfi, krgpif, krang, krec)

END SUBROUTINE lfirec64

SUBROUTINE lfirec               &
&           (krgpif, krang, krec)
USE lfimod, ONLY : lfi => lficom_default, &
&                   lficom_default_init,   &
&                   new_lfi_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KRGPIF                                 ! IN   
INTEGER (KIND=JPLIKM)  KRANG                                  ! IN   
INTEGER (KIND=JPLIKM)  KREC                                   !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfirec_mt                       &
&           (lfi, krgpif, krang, krec)

END SUBROUTINE lfirec

SUBROUTINE lfirec_mt                 &
&           (lfi, krgpif, krang, krec)
USE lfimod, ONLY : lficom
USE lfi_precision
IMPLICIT NONE
! Arguments
type(lficom)          lfi                                    ! INOUT
INTEGER (KIND=JPLIKM)  KRGPIF                                 ! IN   
INTEGER (KIND=JPLIKM)  KRANG                                  ! IN   
INTEGER (KIND=JPLIKM)  KREC                                   !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IRGPIF                                 ! IN   
INTEGER (KIND=JPLIKB)  IRANG                                  ! IN   
INTEGER (KIND=JPLIKB)  IREC                                   !   OUT
! Convert arguments

irgpif     = int(    krgpif, jplikb)
irang      = int(     krang, jplikb)

CALL lfirec_fort                     &
&           (lfi, irgpif, irang, irec)

krec       = int(      irec, jplikm)

END SUBROUTINE lfirec_mt

!INTF KRGPIF        IN    
!INTF KRANG         IN    
!INTF KREC            OUT