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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACTUM_MT (FA,  CDNOMC )
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 supprimer un cadre.
00008 C     ( Cadre a TUer Methodiquement ? )
00009 C**
00010 C        Argument : CDNOMC (Entree) ==> Nom symbolique du cadre.
00011 C
00012 #include "precision.h"
00013 C
00014 C
00015       TYPE(FA_COM) :: FA
00016       INTEGER ILCDNO, IREP, IRANGC, ILNOMC, INIMES, INUMER, J
00017 C
00018       LOGICAL LLVERG
00019 C
00020       CHARACTER CDNOMC*(*)
00021 C
00022 C
00023 C
00024 #include "facom2.h"
00025 #include "facom_mt.h"
00026 C**
00027 C     1.  -  INITIALISATIONS ET CONTROLES SOMMAIRES.
00028 C-----------------------------------------------------------------------
00029 C
00030       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00031       IF (LHOOK) CALL DR_HOOK('FACTUM_MT',0,ZHOOK_HANDLE)
00032       IF (FA%FACTUM_LLPREA) THEN
00033 C
00034 C         Initialisation eventuelle des variables globales du logiciel.
00035 C
00036         CALL FARINE_MT (FA, 2)
00037         FA%FACTUM_LLPREA=.FALSE.
00038       ENDIF
00039 C
00040       LLVERG=.FALSE.
00041       ILCDNO=LEN (CDNOMC)
00042 C
00043       IF (ILCDNO.LE.0) THEN
00044         IREP=-65
00045         GOTO 1001
00046       ELSEIF (CDNOMC.EQ.' ') THEN
00047         IREP=-68
00048         GOTO 1001
00049       ENDIF
00050 C
00051       DO 101 J=ILCDNO,1,-1
00052 C
00053       IF (CDNOMC(J:J).NE.' ') THEN
00054         ILNOMC=J
00055         GOTO 102
00056       ENDIF
00057 C
00058   101 CONTINUE
00059 C
00060   102 CONTINUE
00061 C
00062       IF (ILNOMC.GT.FA%NCPCAD) THEN
00063         IREP=-65
00064         GOTO 1001
00065       ENDIF
00066 C             Verrouillage global, si necessaire.
00067 C
00068       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'ON')
00069       LLVERG=FA%LFAMUL
00070 C
00071 C          Controle d'existence du cadre specifie.
00072 C
00073       CALL FANUCA_MT (FA, CDNOMC,IRANGC,.FALSE.)
00074 C
00075       IF (IRANGC.EQ.0) THEN
00076         IREP=-51
00077         GOTO 1001
00078       ENDIF
00079 C**
00080 C     2.  -  SUPPRESSION PROPREMENT DITE VIA LE SOUS-PROGRAMME "FACTUI".
00081 C-----------------------------------------------------------------------
00082 C
00083       CALL FACTUI_MT (FA, IREP,IRANGC)
00084 C**
00085 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00086 C            VIA LE sous-programme "FAIPAR" .
00087 C-----------------------------------------------------------------------
00088 C
00089  1001 CONTINUE
00090 C
00091 C          Deverrouillage global eventuel.
00092 C
00093       IF (LLVERG) CALL LFIVER_MT (FA%LFI, FA%VRGLAS,'OFF')
00094 C
00095       LLFATA=LLMOER(IREP,0)
00096 C
00097       IF (.NOT.LLFATA.OR.FA%NIMSGA.NE.2)  THEN 
00098         IF (LHOOK) CALL DR_HOOK('FACTUM_MT',1,ZHOOK_HANDLE)
00099         RETURN
00100       ENDIF
00101 C
00102       INIMES=2
00103       CLNSPR='FACTUM'
00104 C
00105       IF (IREP.EQ.-65.AND.ILCDNO.LE.0) THEN
00106         ILNOMC=8
00107         CLACTI(1:ILNOMC)=FA%CHAINC(:ILNOMC)
00108       ELSE
00109         ILNOMC=MIN (LEN (CLACTI),ILNOMC)
00110         CLACTI=CDNOMC(1:ILNOMC)
00111       ENDIF
00112 C
00113       WRITE (UNIT=CLMESS,FMT='(''CDNOMC='''''',A,'''''''')')
00114      S     CLACTI(1:ILNOMC)
00115       INUMER=FA%JPNIIL
00116       CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,LLFATA,CLMESS,
00117      S                CLNSPR, CLACTI(1:ILNOMC),.FALSE.)
00118 C
00119       IF (LHOOK) CALL DR_HOOK('FACTUM_MT',1,ZHOOK_HANDLE)
00120       END
00121