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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACTUI_MT (FA,  KREP, KRANGC )
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 A USAGE INTERNE AU LOGICIEL. Fait la suppression
00008 C     d'un cadre ( vis-a-vis des tables du logiciel ) .
00009 C        En mode multi-taches, il doit y avoir verrouillage global
00010 C     de la zone d'appel au sous-programme.
00011 C**
00012 C        Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00013 C                    KRANGC (Entree) ==> Rang du cadre dans les tables.
00014 C
00015 #include "precision.h"
00016 C
00017 C
00018       TYPE(FA_COM) :: FA
00019       INTEGER KREP, KRANGC
00020 C
00021       INTEGER J, IPOSCA, INIMES, INUMER
00022 #include "facom_mt.h"
00023 C**
00024 C     1.  -  CONTROLE PREALABLE DE COHERENCE.
00025 C-----------------------------------------------------------------------
00026 C
00027       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00028       IF (LHOOK) CALL DR_HOOK('FACTUI_MT',0,ZHOOK_HANDLE)
00029       IF (KRANGC.LE.0.OR.KRANGC.GT.FA%JPNXFA) THEN
00030         KREP=-66
00031         GOTO 1001
00032       ENDIF
00033 C**
00034 C     2.  -  RECHERCHE DU CADRE DANS LA TABLE "FA%NCAIND".
00035 C-----------------------------------------------------------------------
00036 C
00037       DO 201 J=1,FA%NCADEF
00038 C
00039       IF (FA%NCAIND(J).EQ.KRANGC) THEN
00040         IPOSCA=J
00041         GOTO 202
00042       ENDIF
00043 C
00044   201 CONTINUE
00045 C
00046       KREP=-66
00047       GOTO 1001
00048 C
00049   202 CONTINUE
00050 C
00051       IF (FA%NULCAD(IPOSCA).NE.0) THEN
00052         KREP=-67
00053         GOTO 1001
00054       ENDIF
00055 C**
00056 C     3.  -  MISE A JOUR DES TABLES.
00057 C-----------------------------------------------------------------------
00058 C
00059       FA%CNOMCA(KRANGC)=' '
00060       FA%NCADEF=FA%NCADEF-1
00061 C
00062       DO 301 J=IPOSCA,FA%NCADEF
00063       FA%NCAIND(J)=FA%NCAIND(J+1)
00064   301 CONTINUE
00065 C
00066       KREP=0
00067 C**
00068 C    10.  -  PHASE TERMINALE : MESSAGERIE EVENTUELLE,
00069 C            VIA LE sous-programme "FAIPAR" .
00070 C-----------------------------------------------------------------------
00071 C
00072  1001 CONTINUE
00073 C
00074       LLFATA=KREP.EQ.-66.OR.(KREP.NE.0.AND.FA%NRFAGA.NE.2)
00075 C
00076       IF (FA%LFAMOP.OR.LLFATA) THEN
00077         INIMES=2
00078         CLNSPR='FACTUI'
00079         INUMER=FA%JPNIIL
00080         WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KRANGC='',I4)')
00081      S     KREP,KRANGC
00082         CALL FAIPAR_MT (FA, INUMER,INIMES,KREP,.FALSE.,CLMESS,
00083      S               CLNSPR,CLACTI,.FALSE.)
00084       ENDIF
00085 C
00086       IF (LHOOK) CALL DR_HOOK('FACTUI_MT',1,ZHOOK_HANDLE)
00087       END
00088