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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FAUTIF_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 permettant de donner un NOM a l'Identificateur
00008 C     d'un fichier ARPEGE.
00009 C       ( l'Utilisateur Traite son 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 (Entree) ==> Nom de l'identificateur.
00014 C
00015 C       Une messagerie de niveau 1 est emise dans les cas "normaux"
00016 C
00017 #include "precision.h"
00018 C
00019 C
00020       TYPE(FA_COM) :: FA
00021       INTEGER KREP, KNUMER
00022 C
00023       INTEGER IREP, ILIDEN, IRANG, INIMES, ILACTI
00024 C
00025       LOGICAL LLVERF, LLRLFI
00026 C
00027       CHARACTER CDIDEN*(*)
00028 C
00029 #include "facom2.h"
00030 #include "facom_mt.h"
00031 C**
00032 C     1.  -  CONTROLES ET INITIALISATIONS.
00033 C-----------------------------------------------------------------------
00034 C
00035       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00036       IF (LHOOK) CALL DR_HOOK('FAUTIF_MT',0,ZHOOK_HANDLE)
00037       LLVERF=.FALSE.
00038       LLRLFI=.FALSE.
00039       ILIDEN=LEN (CDIDEN)
00040       CALL FANUMU_MT (FA, KNUMER,IRANG)
00041 C
00042       IF (IRANG.EQ.0) THEN
00043         IREP=-51
00044         GOTO 1001
00045       ELSEIF (ILIDEN.LE.0) THEN
00046         IREP=-65
00047         GOTO 1001
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       CLNOMA=FA%CIDENT(IRANG)
00055 C
00056       IF (CDIDEN.EQ.FA%CPCACH.OR.CDIDEN.EQ.FA%CPCADI.OR.
00057      S    CDIDEN.EQ.FA%CPCAFS.OR.CDIDEN.EQ.FA%CPCARP.OR.
00058      S    CDIDEN.EQ.FA%CPDATE) THEN
00059         IREP=-111
00060         GOTO 1001
00061       ENDIF
00062 C**
00063 C     2.  -  ON RENOMME L'ARTICLE IDENTIFICATEUR, QUI EXISTE TOUJOURS SI
00064 C            LE FICHIER EST OUVERT, AU MOINS AVEC UN NOM PAR DEFAUT.
00065 C-----------------------------------------------------------------------
00066 C
00067       IF (CDIDEN.NE.FA%CIDENT(IRANG)) THEN
00068         CALL LFIREN_MT (FA%LFI, IREP,KNUMER,FA%CIDENT(IRANG),CDIDEN)
00069         LLRLFI=IREP.NE.0
00070         IF (.NOT.LLRLFI) FA%CIDENT(IRANG)=CDIDEN
00071       ELSE
00072         IREP=0
00073       ENDIF
00074 C**
00075 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00076 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00077 C-----------------------------------------------------------------------
00078 C
00079  1001 CONTINUE
00080       KREP=IREP
00081       LLFATA=LLMOER (IREP,IRANG)
00082 C
00083 C        Deverrouillage eventuel du fichier.
00084 C
00085       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00086 C
00087       IF (LLFATA) THEN
00088         INIMES=2
00089       ELSE
00090         INIMES=IXNVMS(IRANG)
00091       ENDIF
00092 C
00093       IF (.NOT.LLFATA.AND.INIMES.EQ.0)  THEN 
00094         IF (LHOOK) CALL DR_HOOK('FAUTIF_MT',1,ZHOOK_HANDLE)
00095         RETURN
00096       ENDIF
00097 C
00098       CLNSPR='FAUTIF'
00099 C
00100       IF (IREP.NE.-65) THEN
00101         ILACTI=FA%NCPCAD
00102         CLACTI(1:ILACTI)=CDIDEN(1:MIN (ILIDEN,ILACTI))
00103       ELSE
00104         ILACTI=8
00105         CLACTI(1:ILACTI)=FA%CHAINC(:ILACTI)
00106       ENDIF
00107 C
00108       IF (INIMES.EQ.2) THEN
00109         WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00110 ',I3,     S         '', CDIDEN='''''',A,'''''''')')
00111      S   KREP,KNUMER,CLACTI(1:ILACTI)
00112         CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,
00113      S               CLMESS,CLNSPR,
00114      S               CLACTI(1:ILACTI),LLRLFI)
00115       ENDIF
00116 C
00117 C        La messagerie qui suit n'est pas emise en cas d'erreur fatale.
00118 C
00119       IF (INIMES.GE.1.AND.IRANG.NE.0) THEN
00120         WRITE (UNIT=CLMESS,FMT=
00121      S  '(''Ancien Identificateur de l''''unite logique'
00122 ',I3,     S    '' : '''''',A,'''''', Nouveau: '''''',A,'''''''')')
00123      S  KNUMER,CLNOMA,FA%CIDENT(IRANG)
00124         CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,.FALSE.,CLMESS,
00125      S                  CLNSPR,CLACTI(1:ILACTI),.FALSE.)
00126       ENDIF
00127 C
00128       IF (LHOOK) CALL DR_HOOK('FAUTIF_MT',1,ZHOOK_HANDLE)
00129       END
00130