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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACAGE_MT (FA,  CDNOMC, LDGARD )
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 servant a redefinir l'option de conservation
00008 C     d'un cadre preexistant ( CAdre a Garder Eventuellement... )
00009 C**
00010 C        Arguments : CDNOMC ==> Nom symbolique du cadre;
00011 C  (tous d'Entree)   LDGARD ==> Vrai si le cadre doit etre conserve meme
00012 C                               apres la fermeture du dernier fichier
00013 C                               qui s'y rattache.
00014 C
00015 #include "precision.h"
00016 C
00017 C
00018       TYPE(FA_COM) :: FA
00019       INTEGER ILCDNO, ILNOMC, J, IRANGC, IREP, INIMES, INUMER
00020 C
00021       LOGICAL LLVERG, LDGARD
00022 C
00023       CHARACTER CDNOMC*(*)
00024 #include "facom_mt.h"
00025 C
00026 C
00027 C**
00028 C     0.  -  SI PREMIERE UTILISATION, APPEL AU SOUS-PROGRAMME "FARINE".
00029 C-----------------------------------------------------------------------
00030 C
00031       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00032       IF (LHOOK) CALL DR_HOOK('FACAGE_MT',0,ZHOOK_HANDLE)
00033       IF (FA%FACAGE_LLPREA) THEN
00034         CALL FARINE_MT (FA, 2)
00035         FA%FACAGE_LLPREA=.FALSE.
00036       ENDIF
00037 C**
00038 C     1.  -  CONTROLE DE L'ARGUMENT "CDNOMC".
00039 C-----------------------------------------------------------------------
00040 C
00041       LLVERG=.FALSE.
00042       ILCDNO=LEN (CDNOMC)
00043       ILNOMC=1
00044 C
00045       IF (ILCDNO.LE.0) THEN
00046         IREP=-65
00047         GOTO 1001
00048       ELSEIF (CDNOMC.EQ.' ') THEN
00049         IREP=-68
00050         GOTO 1001
00051       ENDIF
00052 C
00053       DO 101 J=ILCDNO,1,-1
00054 C
00055       IF (CDNOMC(J:J).NE.' ') THEN
00056         ILNOMC=J
00057         GOTO 102
00058       ENDIF
00059 C
00060   101 CONTINUE
00061 C
00062   102 CONTINUE
00063 C
00064       IF (ILNOMC.GT.FA%NCPCAD) THEN
00065         IREP=-65
00066         GOTO 1001
00067       ENDIF
00068 C**
00069 C     2.  -  RECHERCHE DU CADRE DANS LES TABLES.
00070 C-----------------------------------------------------------------------
00071 C
00072 C             Verrouillage global prealable, si necessaire.
00073 C
00074       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00075       LLVERG=FA%LFAMUL
00076 C
00077       CALL FANUCA_MT (FA, CDNOMC,IRANGC,.FALSE.)
00078 C
00079       IF (IRANGC.EQ.0) THEN
00080         IREP=-51
00081         GOTO 1001
00082       ENDIF
00083 C**
00084 C     3.  -  MISE A JOUR DU NIVEAU DE CONSERVATION.
00085 C-----------------------------------------------------------------------
00086 C
00087       IF (LDGARD) THEN
00088         FA%NGARDE(IRANGC)=2
00089       ELSE
00090         FA%NGARDE(IRANGC)=0
00091       ENDIF
00092 C
00093       IREP=0
00094 C**
00095 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00096 C            VIA LE sous-programme "FAIPAR" .
00097 C-----------------------------------------------------------------------
00098 C
00099  1001 CONTINUE
00100 C
00101 C          Deverrouillage global eventuel.
00102 C
00103       IF (LLVERG) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00104 C
00105       LLFATA=IREP.NE.0.AND.FA%NRFAGA.NE.2
00106 C
00107       IF (LLFATA.OR.FA%NIMSGA.EQ.2) THEN
00108         INIMES=2
00109         CLNSPR='FACAGE'
00110 C
00111         IF (IREP.EQ.-65.AND.ILCDNO.LE.0) THEN
00112           ILNOMC=8
00113           CLACTI(1:ILNOMC)=FA%CHAINC(:ILNOMC)
00114         ELSE
00115           ILNOMC=MIN (LEN (CLACTI),ILNOMC)
00116           CLACTI(1:ILNOMC)=CDNOMC(1:ILNOMC)
00117         ENDIF
00118 C
00119         ILNOMC=MIN (ILNOMC,FA%NCPCAD)
00120         WRITE (UNIT=CLMESS,
00121      S         FMT='(''CDNOMC= '''''',A,'''''', LDGARD= '
00122 ',     S         L1,'', CODE INTERNE='',I4)') 
00123      S         CLACTI(1:ILNOMC),LDGARD,IREP
00124         INUMER=FA%JPNIIL
00125         CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,LLFATA,CLMESS,
00126      S               CLNSPR,CLACTI(1:ILNOMC),.FALSE.)
00127       ENDIF
00128 C
00129       IF (LHOOK) CALL DR_HOOK('FACAGE_MT',1,ZHOOK_HANDLE)
00130       END
00131