SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/LFI/mt/lfiecc

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIECC_MT (LFI, KREP, KNUMER, KREC, CDTAB, KNBECR, 
00003      S                      KFACTM, KRETIN )
00004       USE LFIMOD, ONLY : LFICOM
00005       USE PARKIND1, ONLY : JPRB
00006       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00007 C****
00008 C        Sous-programme charge des Ecritures de Chaines de Caracteres
00009 C     du logiciel LFI (articles d'index "noms").
00010 C**
00011 C     Arguments: KREP   (Sortie) ==> Code-reponse ( zero si OK; code-
00012 C                                    reponse du "WRITE" FORTRAN sinon);
00013 C                KNUMER (Entree) ==> NUMERo d'unite logique FORTRAN;
00014 C                KREC   (Entree) ==> Numero d'enregistrement a ecrire;
00015 C                KTAB   (Sortie) ==> Zone a ecrire, de Longueur
00016 C                                    LFI%JPLARD*KFACTM *mots*;
00017 C                KNBECR (Entree  ==> Compteur d'ECRitures sur l'unite;
00018 C                       +Sortie)
00019 C                KFACTM (Entree) ==> FACteur Multiplicatif LFI de
00020 C                                    l'unite logique;
00021 C                KRETIN (Sortie) ==> Code-retour interne.
00022 C
00023 C
00024       TYPE(LFICOM) :: LFI
00025       INTEGER KREP, KNUMER, KREC, KNBECR, KFACTM, KRETIN
00026 C
00027       CHARACTER CDTAB (LFI%JPNXNA*KFACTM)*(LFI%JPNCPN)
00028 #include "lficom_mt.h"
00029 C
00030 C        ECRITURE .
00031 C
00032       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00033       IF (LHOOK) CALL DR_HOOK('LFIECC_MT',0,ZHOOK_HANDLE)
00034       WRITE (UNIT=KNUMER,REC=KREC,ERR=901,IOSTAT=KREP) CDTAB
00035 C
00036       IF (LFI%LMISOP) THEN
00037         WRITE (UNIT=LFI%NULOUT,FMT=*)
00038      S          '+++++ LFIECC - WRITE / ',KNUMER,', REC = ',KREC,
00039      S          ' +++++'
00040       ENDIF
00041 C
00042       KNBECR=KNBECR+1
00043       KRETIN=0
00044       GOTO 1001
00045 C
00046   901 CONTINUE
00047       KRETIN=1
00048 C
00049  1001 CONTINUE
00050 C
00051       IF (LHOOK) CALL DR_HOOK('LFIECC_MT',1,ZHOOK_HANDLE)
00052       END
00053