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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FANUMU_MT (FA,  KNUMER, KRANG )
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C        Ce sous-programme calcule le RANG du Numero d'Unite logique
00008 C     *KNUMER* dans la table des unites logiques *FA%NULOGI*;
00009 C     s'il n'y est pas trouve, le resultat est ZERO.
00010 C        Ce sous-programme, appele par tous les sous-programmes
00011 C     "fichier" du Logiciel de Fichiers ARPEGE, se charge lors de son
00012 C     premier appel d'appeler le sous-programme preparatoire FARINE.
00013 C**
00014 C       Arguments : KNUMER (Entree) ==> Numero d'unite logique cherche;
00015 C                   KRANG  (Sortie) ==> Rang dans la table des fichiers
00016 C                                       du logiciel FA (0 si absent).
00017 C
00018 #include "precision.h"
00019 C
00020 C
00021       TYPE(FA_COM) :: FA
00022       INTEGER KNUMER, KRANG
00023 C
00024       INTEGER J, IRESUL
00025 C
00026 C
00027 #include "facom2.h"
00028 #include "facom_mt.h"
00029 C
00030       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00031       IF (LHOOK) CALL DR_HOOK('FANUMU_MT',0,ZHOOK_HANDLE)
00032       IF (FA%FANUMU_LLPREA) THEN
00033         CALL FARINE_MT (FA, 2)
00034         FA%FANUMU_LLPREA=.FALSE.
00035       ENDIF
00036 C
00037 C          VERROUILLAGE GLOBAL (A CAUSE DE L'UTILISATION DE FA%NFIOUV )
00038 C
00039       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00040 C
00041       DO 10 J=1,FA%NFIOUV
00042 C
00043       IF (KNUMER.EQ.FA%NULOGI(FA%NULIND(J))) THEN
00044         IRESUL=FA%NULIND(J)
00045         GOTO 20
00046       ENDIF
00047 C
00048    10 CONTINUE
00049 C
00050       IRESUL=0
00051 C
00052    20 CONTINUE
00053 C
00054 C          DEVERROUILLAGE GLOBAL
00055 C
00056       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00057       KRANG=IRESUL
00058 C
00059       IF (LHOOK) CALL DR_HOOK('FANUMU_MT',1,ZHOOK_HANDLE)
00060       END
00061