SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/FA/mt/falsif

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FALSIF_MT (FA,  KREP, KNUMER, CDIDEN )
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        Sous-programme renvoyant le NOM de l'Identificateur
00008 C     d'un fichier ARPEGE.
00009 C       ( Lecture Specifique de l'Identificateur de Fichier )
00010 C**
00011 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00012 C                KNUMER (Entree) ==> Numero de l'unite logique;
00013 C                CDIDEN (Sortie) ==> Nom de l'identificateur.
00014 C
00015 #include "precision.h"
00016 C
00017 C
00018       TYPE(FA_COM) :: FA
00019       INTEGER KREP, KNUMER
00020 C
00021       INTEGER IREP, ILIDEN, IRANG, J, ILONGN, INIMES, ILACTI
00022 C
00023       LOGICAL LLVERF, LLRLFI
00024 C
00025       CHARACTER CDIDEN*(*)
00026 C
00027 #include "facom2.h"
00028 #include "facom_mt.h"
00029 C**
00030 C     1.  -  CONTROLES ET INITIALISATIONS.
00031 C-----------------------------------------------------------------------
00032 C
00033       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00034       IF (LHOOK) CALL DR_HOOK('FALSIF_MT',0,ZHOOK_HANDLE)
00035       LLVERF=.FALSE.
00036       LLRLFI=.FALSE.
00037       ILIDEN=LEN (CDIDEN)
00038       CALL FANUMU_MT (FA, KNUMER,IRANG)
00039 C
00040       IF (IRANG.EQ.0) THEN
00041         IREP=-51
00042         GOTO 1001
00043       ELSEIF (ILIDEN.LE.0) THEN
00044         IREP=-65
00045         GOTO 1001
00046       ELSE
00047         IREP=0
00048       ENDIF
00049 C
00050 C         Verrouillage eventuel du fichier.
00051 C
00052       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'ON')
00053       LLVERF=FA%LFAMUL
00054 C**
00055 C     2.  -  ON RENVOIE LE NOM D'IDENTIFICATEUR, APRES CONTROLE EVENTUEL
00056 C            D'UNE VARIABLE CARACTERE SUFISAMMENT LONGUE.
00057 C-----------------------------------------------------------------------
00058 C
00059       IF (ILIDEN.GE.FA%NCPCAD) THEN
00060         CDIDEN=FA%CIDENT(IRANG)
00061       ELSE
00062 C
00063         DO 201 J=FA%NCPCAD,1,-1
00064 C
00065         IF (FA%CIDENT(IRANG)(J:J).NE.' ') THEN
00066           ILONGN=J
00067           GOTO 202
00068         ENDIF
00069 C
00070   201   CONTINUE
00071 C
00072         IREP=-66
00073         GOTO 1001
00074 C
00075   202   CONTINUE
00076 C
00077         IF (ILONGN.GT.ILIDEN) THEN
00078           IREP=-69
00079         ELSE
00080           CDIDEN=FA%CIDENT(IRANG)(1:ILONGN)
00081         ENDIF
00082 C
00083       ENDIF
00084 C**
00085 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00086 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00087 C-----------------------------------------------------------------------
00088 C
00089  1001 CONTINUE
00090       KREP=IREP
00091       LLFATA=LLMOER (IREP,IRANG)
00092 C
00093 C        Deverrouillage eventuel du fichier.
00094 C
00095       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00096 C
00097       IF (LLFATA) THEN
00098         INIMES=2
00099       ELSE
00100         INIMES=IXNVMS(IRANG)
00101       ENDIF
00102 C
00103       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00104         IF (LHOOK) CALL DR_HOOK('FALSIF_MT',1,ZHOOK_HANDLE)
00105         RETURN
00106       ENDIF
00107 C
00108       CLNSPR='FALSIF'
00109 C
00110       IF (IREP.EQ.0.OR.IREP.EQ.-69) THEN
00111         ILACTI=FA%NCPCAD
00112         CLACTI=FA%CIDENT(IRANG)(1:ILACTI)
00113       ELSE
00114         ILACTI=8
00115         CLACTI(1:ILACTI)=FA%CHAINC(:ILACTI)
00116       ENDIF
00117 C
00118       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00119 ',I3,     S       '', CDIDEN='''''',A,'''''''')')
00120      S   KREP,KNUMER,CLACTI(1:ILACTI)
00121       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00122      S                CLNSPR,CLACTI(1:ILACTI),LLRLFI)
00123 C
00124       IF (LHOOK) CALL DR_HOOK('FALSIF_MT',1,ZHOOK_HANDLE)
00125       RETURN
00126       END
00127