lfipha.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfipha_fort                                    &
&                     (lfi, krep, krang, krgpim, 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
!     PHASAGE D'UNE PAGE D'INDEX "LONGUEUR/POSITION"
!     AVEC LA PAGE D'INDEX "NOMS" CORRESPONDANTE.
!        IL EST ABSOLUMENT NECESSAIRE QUE LA PAGE D'INDEX "NOMS" SOIT
!     EFFECTIVEMENT ALIMENTEE AVANT L'APPEL DE CE SOUS-PROGRAMME...
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DE LA LECTURE DE PAGE;
!                KRANG  (ENTREE) ==> RANG DE L'UNITE LOGIQUE CONCERNEE;
!                KRGPIM (ENTREE) ==> LFI%NUMERO DE LA PAGE CONCERNEE;
!                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KREP, KRANG, KRGPIM, KRETIN, INUMER 
INTEGER (KIND=JPLIKB) IREC, INAPHY, INIMES
INTEGER (KIND=JPLIKB) IRETOU, IRETIN
!
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('LFIPHA_FORT',0,zhook_handle)
clacti=''
iretou=0
inumer=lfi%NUMERO(krang)
CALL lfirec_fort                                     &
&               (lfi, lfi%MRGPIF(krgpim),krang,irec)
inaphy=irec+1
CALL lfildo_fort                                         &
&               (lfi, krep,inumer,irec+1,              &
&                lfi%MLGPOS(ixm(1_jplikb ,krgpim)),    &
&                lfi%NBREAD(krang),lfi%MFACTM(krang),  &
&                lfi%YLFIC (krang),iretin)
!
IF (iretin.NE.0) THEN
  GOTO 904
ENDIF
!
lfi%LPHASP(krgpim)=.true.
GOTO 1001
!
904 CONTINUE
iretou=2
clacti='READ'
!
!      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
!
krep=abs(krep)
lfi%NUMAPH(krang)=inaphy
!**
!    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='LFIPHA'
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I3, &
&         '', KRGPIM='',I3,'', KRETIN='',I2)')            &
&    krep,krang,krgpim,kretin
  CALL lfiems_fort                                  &
&                 (lfi, inumer,inimes,krep,.false., &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (lhook) CALL dr_hook('LFIPHA_FORT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE lfipha_fort



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

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfipha_fort                             &
&           (lfi, krep, krang, krgpim, kretin)

END SUBROUTINE lfipha64

SUBROUTINE lfipha                       &
&           (krep, krang, krgpim, 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                                 ! IN   
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfipha_mt                               &
&           (lfi, krep, krang, krgpim, kretin)

END SUBROUTINE lfipha

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

irang      = int(     krang, jplikb)
irgpim     = int(    krgpim, jplikb)

CALL lfipha_fort                             &
&           (lfi, irep, irang, irgpim, iretin)

krep       = int(      irep, jplikm)
kretin     = int(    iretin, jplikm)

END SUBROUTINE lfipha_mt

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