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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFIEDO_MT (LFI, KREP, KNUMER, KREC, KTAB, 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 DOnnees du logiciel LFI,
00009 C     *SAUF* pour les articles d'index de type caractere.
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 #ifndef f77
00024 #include "precision.h"
00025 C
00026       TYPE(LFICOM) :: LFI
00027       INTEGER KREP, KNUMER, KREC, KNBECR, KFACTM, KRETIN
00028 C
00029       INTEGER (KIND=JPDBLE)  KTAB (LFI%JPLARD*KFACTM)
00030 #else
00031       INTEGER KTAB (LFI%JPLARD*KFACTM)
00032 #endif
00033 #include "lficom_mt.h"
00034 C
00035 C        ECRITURE .
00036 C
00037       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00038       IF (LHOOK) CALL DR_HOOK('LFIEDO_MT',0,ZHOOK_HANDLE)
00039       WRITE (UNIT=KNUMER,REC=KREC,ERR=901,IOSTAT=KREP) KTAB
00040 C
00041       IF (LFI%LMISOP) THEN
00042         WRITE (UNIT=LFI%NULOUT,FMT=*)
00043      S          '+++++ LFIEDO - WRITE / ',KNUMER,', REC = ',KREC,
00044      S          ' +++++'
00045       ENDIF
00046 C
00047       KNBECR=KNBECR+1
00048       KRETIN=0
00049       GOTO 1001
00050 C
00051   901 CONTINUE
00052       KRETIN=1
00053 C
00054  1001 CONTINUE
00055 C
00056       IF (LHOOK) CALL DR_HOOK('LFIEDO_MT',1,ZHOOK_HANDLE)
00057       END
00058