lfivid.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfivid_fort                                            &
&                     (lfi, krep, krang, knumpd, ktampo, 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
!     "VIDAGE" SUR FICHIER D'UNE PAGE DE DONNEES, APRES L'AVOIR DUMENT
!     COMPLETEE SI NECESSAIRE ( AVEC LES DONNEES DEJA PRESENTES SUR
!     FICHIER, OU AVEC DES ZEROS DANS LE CAS DU DERNIER ARTICLE ).
!**
!    ARGUMENTS : KREP   (SORTIE) ==> CODE-REPONSE DE L'ECRITURE FORTRAN;
!                KRANG  (ENTREE) ==> RANG EN MEMOIRE DE L'UNITE LOGIQUE;
!                KNUMPD (ENTREE) ==> LFI%NUMERO DE LA PAGE DE DONNEES;
!                KTAMPO (ENTREE) ==> ZONE SERVANT A RELIRE L'ARTICLE
!                                    PHYSIQUE CORRESPONDANT SUR FICHIER,
!                                    SI NECESSAIRE. (LONGUEUR: LFI%JPLARX)
!                KRETIN (SORTIE) ==> CODE-RETOUR INTERNE.
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KREP, KRANG, KNUMPD, KRETIN
INTEGER (KIND=JPLIKB)  KTAMPO (lfi%jplarx)
INTEGER (KIND=JPLIKB) INUMER, ILONPD, INUMAE, IFACTM 
INTEGER (KIND=JPLIKB) ILARPH, JD, INAPHY, IRETOU
INTEGER (KIND=JPLIKB) INIMES, IRETIN
!
LOGICAL LLADON
!
CHARACTER(LEN=LFI%JPLSPX) CLNSPR
CHARACTER(LEN=LFI%JPLMES) CLMESS
CHARACTER(LEN=LFI%JPLFTX) CLACTI
LOGICAL LLFATA

!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIVID_FORT',0,zhook_handle)
clacti=''
IF (krang.LE.0.OR.krang.GT.lfi%JPNXFI) THEN
  inumer=lfi%JPNIL
ELSE
  inumer=lfi%NUMERO(krang)
  krep=0
ENDIF
!
iretou=0
!
IF (inumer.EQ.lfi%JPNIL) THEN
  krep=-14
  GOTO 1001
ENDIF
!
ilonpd=lfi%NLONPD(knumpd,krang)
inumae=lfi%NUMAPD(knumpd,krang)
ifactm=lfi%MFACTM(krang)
ilarph=lfi%JPLARD*ifactm
!**
!     2.  -  COMPLEMENT EVENTUEL DE LA PAGE DE DONNEES A TRAITER.
!-----------------------------------------------------------------------
!
IF (ilonpd.NE.ilarph) THEN
!
!             PAGE DE DONNEES INSUFFISAMMENT REMPLIE.
!
  IF (inumae.GT.lfi%MDES1D(ixm(lfi%JPAXPD,krang))) THEN
!*
!     2.1 -  PAS D'ARTICLE PHYSIQUE ASSOCIE SUR FICHIER,
!            ON LA COMPLETE AVEC DES ZEROS.
!-----------------------------------------------------------------------
!
    DO jd=ilonpd+1,ilarph
    lfi%MTAMPD(ixt(jd,knumpd,krang))=0
    ENDDO
!
  ELSE
!*
!     2.2 -  NECESSITE D'ALLER RELIRE L'ARTICLE PHYSIQUE DE DONNEES
!            SUR FICHIER, ET DE "RECOLLER LES MORCEAUX".
!-----------------------------------------------------------------------
!
    inaphy=inumae
    CALL lfildo_fort                                  &
&                   (lfi, krep,inumer,inumae,ktampo,&
&                    lfi%NBREAD(krang),ifactm,      &
&                    lfi%YLFIC (krang),iretin)
!
    IF (iretin.NE.0) THEN
      GOTO 904
    ENDIF
!
    DO jd=ilonpd+1,ilarph
    lfi%MTAMPD(ixt(jd,knumpd,krang))=ktampo(jd)
    ENDDO
!
  ENDIF
!
ENDIF
!**
!     3.  -  ECRITURE OU REECRITURE DE LA PAGE DE DONNEES COMPLETE
!            OU COMPLETEE SUR FICHIER.
!-----------------------------------------------------------------------
!
lladon=.true.
inaphy=0
CALL lfiecx_fort                                          &
&               (lfi,krep,krang,inumae,                   &
&                lfi%MTAMPD(ixt(1_jplikb ,knumpd,krang)), &
&                lladon,iretin)
!
IF (iretin.EQ.1) THEN
  GOTO 903
ELSEIF (iretin.EQ.2) THEN
  GOTO 904
ELSEIF (iretin.NE.0) THEN
  GOTO 1001
ENDIF
!
lfi%LECRPD(knumpd,krang)=.false.
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)
IF (inaphy.NE.0) 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='LFIVID'
  WRITE (unit=clmess,fmt='(''KREP='',I4,'', KRANG='',I3, &
&         '', KNUMPD='',I3,'', KRETIN='',I2)')            &
&     krep,krang,knumpd,kretin
  CALL lfiems_fort                                  &
&                 (lfi, inumer,inimes,krep,.false., &
&                  clmess,clnspr,clacti)
ENDIF
!
IF (lhook) CALL dr_hook('LFIVID_FORT',1,zhook_handle)

CONTAINS

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

END SUBROUTINE lfivid_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE lfivid64                             &
&           (krep, krang, knumpd, ktampo, 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)  KNUMPD                                 ! IN   
INTEGER (KIND=JPLIKB)  KTAMPO     (*)                ! IN   
INTEGER (KIND=JPLIKB)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfivid_fort                                     &
&           (lfi, krep, krang, knumpd, ktampo, kretin)

END SUBROUTINE lfivid64

SUBROUTINE lfivid                               &
&           (krep, krang, knumpd, ktampo, 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)  KNUMPD                                 ! IN   
INTEGER (KIND=JPLIKB)  KTAMPO     (*)                ! IN   
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT

IF (.NOT. lficom_default_init) CALL new_lfi_default ()

CALL lfivid_mt                                       &
&           (lfi, krep, krang, knumpd, ktampo, kretin)

END SUBROUTINE lfivid

SUBROUTINE lfivid_mt                                 &
&           (lfi, krep, krang, knumpd, ktampo, 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)  KNUMPD                                 ! IN   
INTEGER (KIND=JPLIKB)  KTAMPO     (lfi%jplarx)                ! IN   
INTEGER (KIND=JPLIKM)  KRETIN                                 !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  IRANG                                  ! IN   
INTEGER (KIND=JPLIKB)  INUMPD                                 ! IN   
INTEGER (KIND=JPLIKB)  IRETIN                                 !   OUT
! Convert arguments

irang      = int(     krang, jplikb)
inumpd     = int(    knumpd, jplikb)

CALL lfivid_fort                                     &
&           (lfi, irep, irang, inumpd, ktampo, iretin)

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

END SUBROUTINE lfivid_mt

!INTF KREP            OUT                                                              
!INTF KRANG         IN                                                                 
!INTF KNUMPD        IN                                                                 
!INTF KTAMPO        IN    DIMS=LFI%JPLARX                KIND=JPLIKB                   
!INTF KRETIN          OUT