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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FADECO_MT (FA,  KREP,   KNUMER, CDPREF, KNIVAU, CDSUFF,
00003      S                    LDCOSP, CDNOMA, KLNOMA, KVALCO, KLONGD,
00004      S                    PCHAMP )
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 de controle et de DECODAGE d'un CHAMP HORIZONTAL
00010 C      venant d'etre lu sur un fichier ARPEGE/ALADIN.
00011 C       ( DECOdage de donnees )
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                LDCOSP (Entree) ==> Vrai si le champ est represente
00019 C                                    par des coefficients spectraux;
00020 C                CDNOMA (Sortie) ==> Nom de l'article-champ lu;
00021 C                KLNOMA (Sortie) ==> Nombre de caracteres utiles dans
00022 C                                    CDNOMA;
00023 C    ( Tableau ) KVALCO (Entree) ==> Donnees issues de la lecture;
00024 C                KLONGD (Entree) ==> Nombre de valeurs (mots de 64 bits
00025 C                                    en principe) lues;
00026 C    ( Tableau ) PCHAMP (Sortie) ==> Valeurs REELLES du champ lu.
00027 C
00028 C    Remarques:
00029 C
00030 C    - KVALCO est type entier, et doit avoir une longueur
00031 C      suffisante pour stocker les donnees codees. Le dimensionnement
00032 C      "tous terrains" est (2+ILCHAM), qui permet le cas echeant de
00033 C      stocker un champ a pleine resolution sans codage effectif.
00034 C      (ILCHAM est le nombre de valeurs du champ a decoder)
00035 C
00036 C    - CDNOMA doit avoir au moins FA%JPXNOM caracteres.
00037 #include "precision.h"
00038 C
00039 C
00040       TYPE(FA_COM) :: FA
00041       INTEGER KREP, KNUMER, KNIVAU, KLNOMA, KLONGD
00042 C
00043 C
00044       INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANG, INIMES
00045       INTEGER ILPREF, ILSUFF, ILCDNO, IRANGC, IVALC1
00046       INTEGER IB1PAR (FA%JPLB1P)
00047 C
00048       REAL (KIND=JPDBLR) PCHAMP (*)
00049       INTEGER (KIND=JPDBLE) KVALCO(*)
00050 C
00051       LOGICAL LLVERF, LLRLFI, LDCOSP, LLNOMU
00052 C
00053       CHARACTER CDPREF*(*), CDSUFF*(*), CDNOMA*(*)
00054       CHARACTER CLPREF*(FA%JPXNOM), CLSUFF*(FA%JPXSUF)
00055 C
00056 #include "facom2.h"
00057 #include "facom_mt.h"
00058 C**
00059 C     1.  -  CONTROLES ET INITIALISATIONS.
00060 C-----------------------------------------------------------------------
00061 C
00062       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00063       IF (LHOOK) CALL DR_HOOK('FADECO_MT',0,ZHOOK_HANDLE)
00064       LLVERF=.FALSE.
00065       LLRLFI=.FALSE.
00066       LLNOMU=.FALSE.
00067       ILPRFU=LEN (CDPREF)
00068       ILSUFU=LEN (CDSUFF)
00069       ILCDNO=LEN (CDNOMA)
00070       KLNOMA=0
00071       CALL FANUMU_MT (FA, KNUMER,IRANG)
00072 C
00073       IF (IRANG.EQ.0) THEN
00074         IREP=-51
00075         GOTO 1001
00076       ELSEIF (ILCDNO.LT.FA%JPXNOM) THEN
00077         IREP=-65
00078         GOTO 1001
00079       ELSE
00080         CDNOMA=' '
00081       ENDIF
00082 C
00083 C         Verrouillage eventuel du fichier.
00084 C
00085       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'ON')
00086       LLVERF=FA%LFAMUL
00087 C
00088       IF (FA%LCREAF(IRANG)) THEN
00089         IREP=-85
00090         GOTO 1001
00091       ENDIF
00092 C**
00093 C     2.  -  FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
00094 C            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
00095 C-----------------------------------------------------------------------
00096 C
00097       CALL FANFAR_MT (FA, IREP,IRANG,CDPREF,KNIVAU,CDSUFF,CDNOMA,
00098      S                IB1PAR(6),ILPRFU,ILSUFU,ILNOMU)
00099       IF (IREP.NE.0) GOTO 1001
00100       LLNOMU=.TRUE.
00101       KLNOMA=ILNOMU
00102 C**
00103 C     3.  -  CONTROLE ET DECODAGE DE L'ARTICLE DEJA LU SUR LE FICHIER.
00104 C-----------------------------------------------------------------------
00105 C
00106 C
00107 C  Controle de l'homogeneite du type de rangement des coeff. spectraux
00108 C  parmi les champs lus/ecrits: ces champs compactes avec
00109 C  FA%NIGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement"
00110 C  soit selon des colonnes JM=cst consecutives) et contrairement si compactes
00111 C  avec FA%NIGRIB= 0,1 ou 2.
00112 C 
00113       IRANGC=FA%NUCADR(IRANG)
00114       IVALC1=KVALCO(1)
00115       IF (LDCOSP) THEN
00116         IF (IVALC1.EQ.-1.OR.IVALC1.EQ.3) THEN
00117           FA%NRASVE(IRANG)=FA%NRASVE(IRANG)+1
00118           IF (FA%NRASVE(IRANG).EQ.1.AND.FA%NRASHO(IRANG).GT.0) THEN
00119             WRITE(FA%NULOUT,*)
00120      S      '------------------------------------------------'
00121             WRITE(FA%NULOUT,*)' FADECO :  WARNING !!!!!           '
00122             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00123             WRITE(FA%NULOUT,*)
00124      S      ' rangement type modele va etre lu alors que'
00125             WRITE(FA%NULOUT,*)
00126      S      ' d''autres champs spect. ont un rangt different.'
00127             WRITE(FA%NULOUT,*)
00128      S      ' ***  Prenez en compte cette heterogeneite!  ***'
00129             WRITE(FA%NULOUT,*)
00130      S      '------------------------------------------------'
00131           ENDIF
00132         ELSEIF (IVALC1.GE.0.AND.IVALC1.LE.2) THEN
00133           FA%NRASHO(IRANG)=FA%NRASHO(IRANG)+1
00134           IF (FA%NRASHO(IRANG).EQ.1.AND.FA%NRASVE(IRANG).GT.0) THEN
00135             WRITE(FA%NULOUT,*)
00136      S      '------------------------------------------------'
00137             WRITE(FA%NULOUT,*)' FADECO :  WARNING !!!!!           '
00138             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00139             WRITE(FA%NULOUT,*)
00140      S      ' rangement autre que celui du modele va etre lu'
00141             WRITE(FA%NULOUT,*)
00142      S      ' alors que d''autres champs ont le rangt modele'
00143             WRITE(FA%NULOUT,*)
00144      S      ' ***  Prenez en compte cette heterogeneite!  ***'
00145             WRITE(FA%NULOUT,*)
00146      S      '------------------------------------------------'
00147           ENDIF
00148         ENDIF
00149       ENDIF
00150 C
00151       IF (IVALC1.EQ.3) THEN
00152 C Cas d'un champ gribe avec GRIBEX
00153         CALL FADECX_MT (FA,  IREP,   IRANG,  CDNOMA(1:ILNOMU), KVALCO, 
00154      S               KLONGD, PCHAMP, LDCOSP )
00155       ELSE
00156         CALL FADECI_MT (FA,  IREP,   IRANG,  CDNOMA(1:ILNOMU), KVALCO, 
00157      S               KLONGD, PCHAMP, LDCOSP )
00158       ENDIF
00159 C**
00160 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00161 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00162 C-----------------------------------------------------------------------
00163 C
00164  1001 CONTINUE
00165       KREP=IREP
00166       LLFATA=LLMOER (IREP,IRANG)
00167 C
00168 C        Deverrouillage eventuel du fichier.
00169 C
00170       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00171 C
00172       IF (LLFATA) THEN
00173         INIMES=2
00174       ELSE
00175         INIMES=IXNVMS(IRANG)
00176       ENDIF
00177 C
00178       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00179         IF (LHOOK) CALL DR_HOOK('FADECO_MT',1,ZHOOK_HANDLE)
00180         RETURN
00181       ENDIF
00182 C
00183       CLNSPR='FADECO'
00184 C
00185       IF (ILPRFU.GE.1) THEN
00186         ILPREF=MIN (ILPRFU,LEN (CLPREF))
00187         CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
00188       ELSE
00189         ILPREF=8
00190         CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF)
00191       ENDIF
00192 C
00193       IF (ILSUFU.GE.1) THEN
00194         ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
00195         CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
00196       ELSE
00197         ILSUFF=8
00198         CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF)
00199       ENDIF
00200 C
00201       IF (.NOT.LLNOMU) THEN
00202         ILNOMU=MIN (ILPREF,FA%NCPCAD)
00203         CDNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
00204       ENDIF
00205 C
00206       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00207 ',I3,     S       '', CDPREF='''''',A,'''''', KNIVAU='
00208 ',I6,     S       '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)')
00209      S   KREP,KNUMER,CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF),LDCOSP
00210       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00211      S                CLNSPR,CDNOMA(1:ILNOMU),LLRLFI)
00212 C
00213       IF (LHOOK) CALL DR_HOOK('FADECO_MT',1,ZHOOK_HANDLE)
00214       END
00215