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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe LFI
00002       SUBROUTINE LFISFM_MT (LFI, KREP, KNUMER )
00003       USE LFIMOD, ONLY : LFICOM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        Sous-Programme Suprimant un Facteur Multiplicatif
00008 C     d'une Unite Logique FORTRAN, qui a ete fermee PRECEDEMMENT
00009 C     par le Logiciel de Fichiers Indexes *LFI* .
00010 C     (ou du moins, n'est pas ouverte pour ce logiciel)
00011 C
00012 C        Ce sous-programme permet de faire de la place dans les tables
00013 C     decrivant les associations Unite Logique/facteur Multiplicatif.
00014 C**
00015 C    ARGUMENTS : KREP   (Sortie) ==> Code-REPonse du sous-programme;
00016 C                KNUMER (Entree) ==> NUMERo de l'unite logique.
00017 C
00018 #ifndef f77
00019 #include "precision.h"
00020 #endif
00021 C
00022       TYPE(LFICOM) :: LFI
00023       INTEGER KREP, KNUMER, IRANG, IREP, IRANFM, INIMES, IFACTM, J
00024 C
00025       LOGICAL LLVERG, LLEXUL
00026 C
00027 #include "lficom2.h"
00028 #include "lficom_mt.h"
00029 C**
00030 C     1.  -  CONTROLES DES PARAMETRES D'APPEL, INITIALISATIONS.
00031 C-----------------------------------------------------------------------
00032 C
00033 C        Appel a LFINUM, permettant (le cas echeant) l'initialisation
00034 C     variables globales du logiciel a la 1ere utilisation.
00035 C
00036       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00037       IF (LHOOK) CALL DR_HOOK('LFISFM_MT',0,ZHOOK_HANDLE)
00038       IFACTM=0
00039       LLVERG=.FALSE.
00040       CALL LFINUM_MT (LFI, KNUMER,IRANG)
00041 C
00042       IF (IRANG.NE.0) THEN
00043         IREP=-5
00044         GOTO 1001
00045       ENDIF
00046 C
00047 C        Controle de validite FORTRAN du Numero d'Unite Logique.
00048 C
00049       INQUIRE (UNIT=KNUMER,EXIST=LLEXUL,ERR=901,IOSTAT=IREP)
00050 C
00051       IF (.NOT.LLEXUL) THEN
00052         IREP=-30
00053         GOTO 1001
00054       ENDIF
00055 C
00056 C              Verrouillage Global eventuel.
00057 C
00058        IF (LFI%LMULTI) CALL LFIVER_MT (LFI, LFI%VERGLA,'ON')
00059       LLVERG=LFI%LMULTI
00060 C**
00061 C     2.  -  TRAVAIL EFFECTIF SUR LES TABLES DECRIVANT LES ASSOCIATIONS
00062 C            UNITES LOGIQUES/FACTEURS.
00063 C-----------------------------------------------------------------------
00064 C
00065       CALL LFIFMP_MT (LFI, KNUMER,IRANFM)
00066 C
00067       IF (IRANFM.EQ.0) THEN
00068 C
00069 C          Unite logique non trouvee dans la table *LFI%MULOFM*.
00070 C
00071         IREP=-31
00072         GOTO 1001
00073       ENDIF
00074 C
00075       IFACTM=LFI%MFACTU(IRANFM)
00076       LFI%NULOFM=LFI%NULOFM-1
00077 C
00078       DO 201 J=IRANFM,LFI%NULOFM
00079       LFI%MFACTU(J)=LFI%MFACTU(J+1)
00080       LFI%MULOFM(J)=LFI%MULOFM(J+1)
00081   201 CONTINUE
00082 C
00083       IREP=0
00084       GOTO 1001
00085 C**
00086 C     9.  - CI-DESSOUS, ETIQUETTE DE BRANCHEMENT EN CAS D'ERREUR INQUIRE
00087 C-----------------------------------------------------------------------
00088 C
00089   901 CONTINUE
00090       CLACTI='INQUIRE'
00091 C
00092 C      AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
00093 C
00094       IREP=IABS (IREP)
00095 C**
00096 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00097 C            VIA LE SOUS-PROGRAMME "LFIEMS" .
00098 C-----------------------------------------------------------------------
00099 C
00100  1001 CONTINUE
00101       KREP=IREP
00102       LLFATA=LLMOER (IREP,IRANG)
00103 C
00104       IF (LLVERG) CALL LFIVER_MT (LFI, LFI%VERGLA,'OFF')
00105 C
00106       IF (LLFATA) THEN
00107         INIMES=2
00108       ELSEIF (IRANG.EQ.0) THEN
00109         INIMES=LFI%NIMESG
00110       ELSE
00111         INIMES=IXNIMS (IRANG)
00112       ENDIF
00113 C
00114       IF (INIMES.EQ.0)  THEN 
00115         IF (LHOOK) CALL DR_HOOK('LFISFM_MT',1,ZHOOK_HANDLE)
00116         RETURN
00117       ENDIF
00118       CLNSPR='LFISFM'
00119 C
00120       IF (INIMES.EQ.2) THEN
00121         WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='',I3)')
00122      S       KREP,KNUMER
00123         CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,LLFATA,
00124      S                  CLMESS,CLNSPR,CLACTI)
00125       ENDIF
00126 C
00127       IF (LFI%LFRANC) THEN
00128         WRITE (UNIT=CLMESS,FMT=
00129      S         '(''Suppression du Facteur Multiplicatif'
00130 ',I3,     S           '', Unite Logique'',I3)') IFACTM,KNUMER
00131       ELSE
00132         WRITE (UNIT=CLMESS,FMT=
00133      S         '(''Multiply Factor'
00134 ',I3,     S           '' suppressed, Logical Unit'',I3)') IFACTM,KNUMER
00135       ENDIF
00136 C
00137       CALL LFIEMS_MT (LFI, KNUMER,INIMES,IREP,.FALSE.,
00138      S                CLMESS,CLNSPR,CLACTI)
00139 C
00140       IF (LHOOK) CALL DR_HOOK('LFISFM_MT',1,ZHOOK_HANDLE)
00141       END
00142