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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFICHI_MT (LFI, KREP, CDSTRU, KVAL, KPOSC2 )
00003       USE LFIMOD, ONLY : LFICOM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        SOUS-PROGRAMME *INTERNE* DU LOGICIEL DE FICHIERS INDEXES LFI;
00008 C     permet de decoder une valeur entiere (CHIffres)
00009 C     dans une chaine de caracteres.
00010 C**
00011 C    ARGUMENTS : KREP   (Sortie) ==> Code-Reponse du sous-programme;
00012 C                CDSTRU (Entree) ==> Chaine a decoder;
00013 C                KVAL   (Sortie) ==> Valeur entiere decodee;
00014 C                KPOSC2 (Sortie) ==> Position du dernier chiffre.
00015 C
00016       TYPE(LFICOM) :: LFI
00017       CHARACTER CDSTRU*(*), CLFORM*7
00018 C
00019       INTEGER KREP, KVAL, KPOSC2
00020       INTEGER ILUSTR, J, IPOSC1, IPOSC2
00021 #include "lficom_mt.h"
00022 C
00023       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00024       IF (LHOOK) CALL DR_HOOK('LFICHI_MT',0,ZHOOK_HANDLE)
00025       KREP=0
00026       ILUSTR=LEN (CDSTRU)
00027 C
00028       DO 222 J=1,ILUSTR
00029 C
00030       IF (CDSTRU(J:J).NE.' ') THEN
00031 C
00032         IPOSC1=INDEX (LFI%LFICHI_CLCHIF,CDSTRU(J:J))
00033 C
00034         IF (IPOSC1.EQ.0) THEN
00035           KREP=-40
00036           GOTO 1001
00037         ENDIF
00038 C
00039         IPOSC1=J
00040         GOTO 223
00041 C
00042       ENDIF
00043 C
00044   222 CONTINUE
00045 C
00046       IPOSC1=1
00047 C
00048   223 CONTINUE
00049 C
00050       DO 224 J=IPOSC1+1,ILUSTR
00051 C
00052       IF (INDEX (LFI%LFICHI_CLCHIF,CDSTRU(J:J)).EQ.0) THEN
00053         IPOSC2=J-1
00054         GOTO 225
00055       ENDIF
00056 C
00057   224 CONTINUE
00058 C
00059       IPOSC2=ILUSTR
00060 C
00061   225 CONTINUE
00062 C
00063       WRITE (UNIT=CLFORM,FMT='(''(BN,I'',I1,'')'')') IPOSC2-IPOSC1+1
00064       READ (UNIT=CDSTRU(IPOSC1:IPOSC2),FMT=CLFORM,ERR=226) KVAL
00065       KPOSC2=IPOSC2
00066       GOTO 1001
00067 C
00068   226 CONTINUE
00069 C
00070       KREP=-40
00071 C
00072  1001 CONTINUE
00073 C
00074       IF (LHOOK) CALL DR_HOOK('LFICHI_MT',1,ZHOOK_HANDLE)
00075       END
00076