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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FANION_MT (FA,  KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, 
00003      S                      LDEXIS,
00004      S                      LDCOSP, KNGRIB, KNBITS, KSTRON, KPUILA )
00005       USE FA_MOD, ONLY : FA_COM
00006       USE PARKIND1, ONLY : JPRB
00007       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00008 C****
00009 C      Sous-programme renseignant sur l'EXISTENCE et les CARACTERISTI-
00010 C     QUES eventuelles d'un Article de type CHAMP dans un Fichier ARPEGE
00011 C       ( LDEXIS est le "fanion" leve si l'article existe )
00012 C**
00013 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00014 C                KNUMER (Entree) ==> Numero de l'unite logique;
00015 C                CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
00016 C                KNIVAU (Entree) ==> Niveau vertical eventuel;
00017 C                CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
00018 C                LDEXIS (Sortie) ==> Vrai si l'article de type CHAMP
00019 C                                    existe bien dans le Fichier;
00020 C                LDCOSP (Sortie) ==> Vrai si le champ est represente
00021 C                                    par des coefficients spectraux;
00022 C                KNGRIB (Sortie) ==> Niveau de codage GRIB;
00023 C                KNBITS (Sortie) ==> Nombre de bits de codage eventuel;
00024 C                KSTRON (Sortie) ==> Sous-troncature non codee   " -le;
00025 C                KPUILA (Sortie) ==> Puissance de laplacien eventuelle.
00026 C
00027 C        KNBITS n'a de sens que si l'article existe et a ete code;
00028 C     de meme pour KSTRON et KPUILA, qui ne sont applicables qu'a un
00029 C     champ represente en coefficients spectraux.
00030 C        Les arguments de sortie n'ayant pas de sens sont mis a
00031 C     0 pour les entiers, .FALSE. pour les logiques.
00032 C
00033 #include "precision.h"
00034 C
00035 C
00036       TYPE(FA_COM) :: FA
00037       INTEGER KREP, KNUMER, KNIVAU, KNGRIB, KNBITS, KSTRON, KPUILA
00038 C
00039       INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANG, INIMES
00040       INTEGER ILPREF, ILSUFF, IPOFIN, IPOSEX, IRANGC, ILCHAM
00041 C
00042       INTEGER (KIND=JPDBLE) IVALCO (5)
00043       INTEGER  IB1PAR (3)
00044 C
00045       LOGICAL LLVERF, LLRLFI, LDCOSP, LDEXIS, LLTEMP, LLNOMU, LLMLAM
00046 C
00047       CHARACTER CDPREF*(*), CDSUFF*(*)
00048       CHARACTER CLPREF*(FA%JPXNOM), CLSUFF*(FA%JPXSUF)
00049 C
00050 #include "facom2.h"
00051 #include "facom_mt.h"
00052 C**
00053 C     1.  -  CONTROLES ET INITIALISATIONS.
00054 C-----------------------------------------------------------------------
00055 C
00056       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00057       IF (LHOOK) CALL DR_HOOK('FANION_MT',0,ZHOOK_HANDLE)
00058       IREP=0
00059       LLVERF=.FALSE.
00060       LLTEMP=.FALSE.
00061       LLRLFI=.FALSE.
00062       LLNOMU=.FALSE.
00063       ILPRFU=LEN (CDPREF)
00064       ILSUFU=LEN (CDSUFF)
00065       LDEXIS=.FALSE.
00066       LDCOSP=.FALSE.
00067       KNGRIB=0
00068       KNBITS=0
00069       KSTRON=0
00070       KPUILA=0
00071       CALL FANUMU_MT (FA, KNUMER,IRANG)
00072 C
00073       IF (IRANG.EQ.0) THEN
00074         IREP=-51
00075         GOTO 1001
00076       ENDIF
00077 C
00078 C         Verrouillage eventuel du fichier.
00079 C
00080       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'ON')
00081       LLVERF=FA%LFAMUL
00082 C
00083       IF (FA%LCREAF(IRANG)) GOTO 1001
00084 C**
00085 C     2.  -  FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
00086 C            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
00087 C-----------------------------------------------------------------------
00088 C
00089       CALL FANFAR_MT (FA, IREP,IRANG,CDPREF,KNIVAU,CDSUFF,CLNOMA,
00090      S                IB1PAR,ILPRFU,ILSUFU,ILNOMU)
00091       IF (IREP.NE.0) GOTO 1001
00092       LLNOMU=.TRUE.
00093 C**
00094 C     3.  -  RECHERCHE DE L'ARTICLE SUR LE FICHIER, LECTURE PARTIELLE.
00095 C-----------------------------------------------------------------------
00096 C
00097       CALL LFINFO_MT (FA%LFI, IREP,KNUMER,CLNOMA(1:ILNOMU),
00098      S             ILONGA,IPOSEX)
00099       LLRLFI=IREP.NE.0
00100       IF (LLRLFI.OR.ILONGA.EQ.0) GOTO 1001
00101       LDEXIS=.TRUE.
00102 C
00103       IF (ILONGA.GT.FA%JPXCHA+2) THEN
00104         IREP=-90
00105         GOTO 1001
00106       ENDIF
00107 C
00108       IF (FA%LERRFA(IRANG)) THEN
00109 C
00110 C        Le fichier est gere en mode "toute erreur est fatale".
00111 C     Ce mode etant normalement couple au mode correspondant du logiciel
00112 C     LFI, on va temporairement annuler l'option LFI afin de pouvoir
00113 C     faire une lecture partielle de l'entete de l'article Champ.
00114 C
00115         CALL LFIERF_MT (FA%LFI, IREP,KNUMER,.FALSE.)
00116         LLRLFI=IREP.NE.0
00117         IF (LLRLFI) GOTO 1001
00118         LLTEMP=.TRUE.
00119       ENDIF
00120 C
00121       CALL LFILEC_MT (FA%LFI, IREP,KNUMER,CLNOMA(1:ILNOMU),IVALCO,5)
00122 C
00123       IF (IREP.EQ.0) THEN
00124         IREP=-93
00125         GOTO 1001
00126       ELSEIF (IREP.NE.-21) THEN
00127         LLRLFI=.TRUE.
00128         GOTO 1001
00129       ELSEIF (IVALCO(1).LT.-1 .OR. IVALCO(1).GT.3 .OR.
00130      S        IVALCO(2).LT.0  .OR. IVALCO(2).GT.1 .OR.
00131      S  (IVALCO(1).GT.0 .AND. IVALCO(2).EQ.1 .AND. IVALCO(4).LT.0)) THEN
00132         IREP=-91
00133         GOTO 1001
00134       ELSE
00135         IREP=0
00136         KNGRIB=IVALCO(1)
00137         LDCOSP=IVALCO(2).EQ.1
00138       ENDIF
00139 C
00140       IRANGC=FA%NUCADR(IRANG)
00141       LLMLAM=FA%LIMLAM(IRANGC)
00142 C
00143       IF (LDCOSP) THEN
00144         IF (LLMLAM) THEN
00145            ILCHAM=FA%NSFLAM(IRANGC)
00146         ELSE
00147            IF (KNGRIB.EQ.3 .OR. KNGRIB.EQ.-1) THEN
00148              ILCHAM=(1+FA%MTRONC(IRANGC))*(2+FA%MTRONC(IRANGC))
00149            ELSE
00150              ILCHAM=(1+FA%MTRONC(IRANGC))**2
00151            ENDIF
00152         ENDIF
00153       ELSE
00154         ILCHAM=FA%NVAPDG(IRANGC)
00155       ENDIF
00156 C
00157       IF (KNGRIB.EQ.-1 .OR. KNGRIB.EQ.0) THEN
00158 C
00159 C          Cas ou il n'y a aucun codage... controle longueur d'article
00160 C
00161         IF (ILONGA.LT.(ILCHAM+2)) THEN
00162           IREP=-93
00163           GOTO 1001
00164         ELSEIF (ILONGA.GT.(ILCHAM+2)) THEN
00165           IREP=-94
00166           IF (LLMOER(IREP,IRANG)) GOTO 1001
00167         ENDIF
00168 C
00169       ELSE
00170 C
00171 C        Cas avec codage GRIB (standard ou non).
00172 C
00173         KNBITS=IVALCO(3)
00174 C
00175         IF (LDCOSP) THEN
00176           KSTRON=IVALCO(4)
00177           KPUILA=IVALCO(5)
00178 C
00179           IF (KNGRIB.EQ.2.AND.ILONGA.LT.(5+(1+KSTRON)**2)) THEN
00180             IREP=-93
00181             GOTO 1001
00182           ENDIF
00183 C
00184         ENDIF
00185 C
00186       ENDIF
00187 C**
00188 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00189 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00190 C-----------------------------------------------------------------------
00191 C
00192  1001 CONTINUE
00193 C
00194       IF (LLTEMP) THEN
00195 C
00196 C         On remet le fichier en mode "toute erreur fatale" au niveau
00197 C     du logiciel LFI.
00198 C
00199         CALL LFIERF_MT (FA%LFI, IREP,KNUMER,.TRUE.)
00200         LLRLFI=IREP.NE.0
00201       ENDIF
00202 C
00203       KREP=IREP
00204       LLFATA=LLMOER (IREP,IRANG)
00205 C
00206 C        Deverrouillage eventuel du fichier.
00207 C
00208       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00209 C
00210       IF (LLFATA) THEN
00211         INIMES=2
00212       ELSE
00213         INIMES=IXNVMS(IRANG)
00214       ENDIF
00215 C
00216       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00217         IF (LHOOK) CALL DR_HOOK('FANION_MT',1,ZHOOK_HANDLE)
00218         RETURN
00219       ENDIF
00220 C
00221       CLNSPR='FANION'
00222 C
00223       IF (ILPRFU.GE.1) THEN
00224         ILPREF=MIN (ILPRFU,LEN (CLPREF))
00225         CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
00226       ELSE
00227         ILPREF=8
00228         CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF)
00229       ENDIF
00230 C
00231       IF (ILSUFU.GE.1) THEN
00232         ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
00233         CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
00234       ELSE
00235         ILSUFF=8
00236         CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF)
00237       ENDIF
00238 C
00239       IF (.NOT.LLNOMU) THEN
00240         ILNOMU=MIN (ILPREF,FA%NCPCAD)
00241         CLNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
00242       ENDIF
00243 C
00244       WRITE (UNIT=CLMESS,
00245      S       FMT='(''ARGUMENTS:'',I4,'','',I3,'','''''
00246 ',A,     S       '''''','',I6,'','''''',A,'''''', LDEXIS= '
00247 ',L1,     S       '', LDCOSP= '',L1,'', KNGRIB='',I2,'', KNBITS='
00248 ',I3,     S       '',KSTRON='',I3,'',KPUILA='',I6)')
00249      S   KREP,KNUMER,CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF),LDEXIS,
00250      S   LDCOSP,KNGRIB,KNBITS,KSTRON,KPUILA
00251       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00252      S                CLNSPR,CLNOMA(1:ILNOMU),LLRLFI)
00253 C
00254       IF (LHOOK) CALL DR_HOOK('FANION_MT',1,ZHOOK_HANDLE)
00255       END
00256