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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FANUCA_MT (FA,  CDNOMC, KRANGC, LDVERR )
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 Cadre de NOM
00008 C     *CDNOMC* dans la table des noms de cadres *FA%CNOMCA*;
00009 C     S'IL N'Y EST PAS TROUVE, LE RESULTAT EST ZERO.
00010 C        Ce sous-programme, appele par plusieurs sous-programmes
00011 C     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 : CDNOMC (Entree) ==> Nom de cadre cherche;
00015 C                   KRANGC (Sortie) ==> Rang dans la table des cadres
00016 C                                       du logiciel FA (0 si absent);
00017 C                   LDVERR (Entree) ==> Sert, en mode multi-taches
00018 C                                       seulement, a savoir si l'on doit
00019 C                                       verrouiller globalement ou pas.
00020 C
00021 #include "precision.h"
00022 C
00023 C
00024       TYPE(FA_COM) :: FA
00025       INTEGER KRANGC
00026 C
00027       INTEGER J, IRESUL
00028 C
00029       CHARACTER CDNOMC*(*)
00030 C
00031       LOGICAL LDVERR, LLVERG
00032 C
00033 C
00034 #include "facom2.h"
00035 #include "facom_mt.h"
00036 C
00037       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00038       IF (LHOOK) CALL DR_HOOK('FANUCA_MT',0,ZHOOK_HANDLE)
00039       IF (FA%FANUCA_LLPREA) THEN
00040         CALL FARINE_MT (FA, 2)
00041         FA%FANUCA_LLPREA=.FALSE.
00042       ENDIF
00043 C
00044 C          VERROUILLAGE GLOBAL (A CAUSE DE L'UTILISATION DE FA%NFIOUV )
00045 C
00046       LLVERG=FA%LFAMUL.AND.LDVERR
00047       IF (LLVERG) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00048 C
00049       DO 10 J=1,FA%NCADEF
00050 C
00051       IF (CDNOMC.EQ.FA%CNOMCA(FA%NCAIND(J))) THEN
00052         IRESUL=FA%NCAIND(J)
00053         GOTO 20
00054       ENDIF
00055 C
00056    10 CONTINUE
00057 C
00058       IRESUL=0
00059 C
00060    20 CONTINUE
00061 C
00062 C          DEVERROUILLAGE GLOBAL
00063 C
00064       IF (LLVERG) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00065       KRANGC=IRESUL
00066 C
00067       IF (LHOOK) CALL DR_HOOK('FANUCA_MT',1,ZHOOK_HANDLE)
00068       END
00069