lfiedo.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfiedo_fort                                           &
&                     (lfi, krep, knumer, krec, ktab, knbecr,  &
&                      kfactm, ydfic, kretin)
USE lfimod, ONLY : lficom, lficrw
USE parkind1, ONLY : jprb, jpia, jpib, jpim
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Sous-programme charge des Ecritures de DOnnees du logiciel LFI,
!     *SAUF* pour les articles d'index de type caractere.
!**
!     Arguments: KREP   (Sortie) ==> Code-reponse ( zero si OK; code-
!                                    reponse du "WRITE" FORTRAN sinon);
!                KNUMER (Entree) ==> NUMERo d'unite logique FORTRAN;
!                KREC   (Entree) ==> Numero d'enregistrement a ecrire;
!                KTAB   (Sortie) ==> Zone a ecrire, de Longueur
!                                    LFI%JPLARD*KFACTM *mots*;
!                KNBECR (Entree  ==> Compteur d'ECRitures sur l'unite;
!                       +Sortie)
!                KFACTM (Entree) ==> FACteur Multiplicatif LFI de
!                                    l'unite logique;
!                KRETIN (Sortie) ==> Code-retour interne.
!
!
TYPE(lficom) :: LFI
INTEGER (KIND=JPLIKB) KREP, KNUMER, KREC, KNBECR, KFACTM, KRETIN
type(lficrw)         ydfic
!
INTEGER (KIND=JPLIKB), TARGET  :: KTAB (lfi%jplard*kfactm)
!
INTEGER (KIND=JPLIKB), TARGET  :: JTAB (lfi%jplard*kfactm)
INTEGER (KIND=JPLIKB), POINTER :: ITAB (:)
INTEGER (KIND=JPIB)    IREP, ISIZE

!
!        ECRITURE .
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('LFIEDO_FORT',0,zhook_handle)

IF (ydfic%L_C_BTSWAP) THEN
  CALL jswap (jtab, ktab, 8_jplikm, int(SIZE (ktab), jplikm))
  itab => jtab
ELSE
  itab => ktab
ENDIF
IF (knumer > 0) THEN
  WRITE (unit=knumer,rec=krec,err=901,iostat=krep) itab
ELSE
  krep=0
  CALL lfisee (lfi, ydfic%N_C_FPDESC, ydfic%N_C_OFFSET, kfactm, krec, krep)
  IF (krep /= 0) GOTO 901
  isize = int(SIZE (itab) * 8, jplikb)
  CALL fi_fwrite (irep, itab, 1_jplikb, isize, ydfic%N_C_FPDESC)
  IF (irep /= isize) THEN
    krep = 1
    GOTO 901
  ENDIF
  ydfic%N_C_OFFSET = ydfic%N_C_OFFSET + isize
ENDIF

!
IF (lfi%LMISOP) THEN
  WRITE (unit=lfi%NULOUT,fmt=*)                             &
&          '+++++ LFIEDO - WRITE / ',knumer,', REC = ',krec, &
&          ' +++++'
ENDIF
!
knbecr=knbecr+1
kretin=0
GOTO 1001
!
901 CONTINUE
kretin=1
!
1001 CONTINUE
!
IF (lhook) CALL dr_hook('LFIEDO_FORT',1,zhook_handle)
END SUBROUTINE lfiedo_fort