lfimoe.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfimoe_fort                             &
&                     ( lfi, krep, krang, 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
!     MODIFICATION DE L'ARTICLE DOCUMENTAIRE, LIMITEE A 3 ELEMENTS,
!     LORSQUE LE FICHIER A SUBI SA PREMIERE MODIFICATION DEPUIS LA
!     DERNIERE OUVERTURE.
!
!     APPELE PAR LFIECR, LFIREN, LFISUP.
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DU SOUS-PROGRAMME;
!                KRANG  (ENTREE) ==> RANG ( DANS LA TABLE *LFI%NUMERO* )
!                                    DE L'UNITE LOGIQUE CONCERNEE;
!                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) IDESCR (lfi%jplarx)
INTEGER (KIND=JPLIKB) KREP, KRANG, KRETIN, INUMER, IFACTM, IREC
INTEGER (KIND=JPLIKB) IRANG, INAPHY, IRETOU, INIMES, IRETIN
!
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!**
!     1. -  CONTROLES DES PARAMETRES D'APPEL ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIMOE_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
inumer=lfi%NUMERO(irang)
ifactm=lfi%MFACTM(irang)
irec=1
!**
!     2. -  LECTURE/MODIFICATION/REECRITURE DE L'ARTICLE DOCUMENTAIRE.
!-----------------------------------------------------------------------
!
inaphy=irec
CALL lfildo_fort                                   &
&               (lfi, krep,inumer,irec,idescr(1),&
&                lfi%NBREAD(irang),ifactm,       &
&                lfi%YLFIC (irang),iretin)
!
IF (iretin.NE.0) THEN
  GOTO 904
ENDIF
!
idescr(lfi%JPFEAM)=1
CALL lfidah_fort                                             &
&               (lfi, idescr(lfi%JPDMNG),idescr(lfi%JPHMNG))
lfi%MDES1D(ixm(lfi%JPDMNG,irang))=idescr(lfi%JPDMNG)
lfi%MDES1D(ixm(lfi%JPHMNG,irang))=idescr(lfi%JPHMNG)
CALL lfiedo_fort                                    &
&               (lfi, krep,inumer,irec,idescr(1), &
&                lfi%NBWRIT(irang),ifactm,        &
&                lfi%YLFIC (irang),iretin)
!
IF (iretin.NE.0) THEN
  GOTO 903
ENDIF
!
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)
lfi%NUMAPH(irang)=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
  inumer=lfi%NUMERO(krang)
  inimes=2
  clnspr='LFIMOE'
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I3, &
&  '', KRETIN='',I2)')                                    &
&    krep,krang,kretin
  CALL lfiems_fort                                  &
&                 (lfi, inumer,inimes,krep,.false., &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (lhook) CALL dr_hook('LFIMOE_FORT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE lfimoe_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfimoe64             &
&           (krep, krang, 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)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfimoe_fort                     &
&           (lfi, krep, krang, kretin)

END SUBROUTINE lfimoe64

SUBROUTINE lfimoe               &
&           (krep, krang, 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)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfimoe_mt                       &
&           (lfi, krep, krang, kretin)

END SUBROUTINE lfimoe

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

irang      = int(     krang, jplikb)

CALL lfimoe_fort                     &
&           (lfi, irep, irang, iretin)

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

END SUBROUTINE lfimoe_mt

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