lfiecc.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe LFI
SUBROUTINE lfiecc_fort                                            &
&                     (lfi, krep, knumer, krec, cdtab, 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 Chaines de Caracteres
!     du logiciel LFI (articles d'index "noms").
!**
!     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
INTEGER (KIND=JPLIKB) KNBECR, KFACTM, KRETIN
type(lficrw)         ydfic
!
CHARACTER CDTAB (lfi%jpnxna*kfactm)*(lfi%jpncpn)
!
INTEGER (KIND=JPIB)   IREP, ISIZE
!
!        ECRITURE .
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('LFIECC_FORT',0,zhook_handle)

IF (knumer > 0) THEN
  WRITE (unit=knumer,rec=krec,err=901,iostat=krep) cdtab
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 (cdtab) * len(cdtab), jplikb)
  CALL fi_fwrite (irep, cdtab, 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=*)                             &
&          '+++++ LFIECC - WRITE / ',knumer,', REC = ',krec, &
&          ' +++++'
ENDIF
!
knbecr=knbecr+1
kretin=0
GOTO 1001
!
901 CONTINUE
kretin=1
!
1001 CONTINUE
!
IF (lhook) CALL dr_hook('LFIECC_FORT',1,zhook_handle)
END SUBROUTINE lfiecc_fort