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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACOND_MT (FA,  KREP,   KNUMER, CDPREF, KNIVAU, CDSUFF,
00003      S                    PCHAMP, LDCOSP, CDNOMA, KLNOMA, PVALCO,
00004      S                    KLONGD )
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 CODAGE d'un CHAMP HORIZONTAL destine a etre
00010 C      ecrit sur un fichier ARPEGE/ALADIN.
00011 C       ( COdage de (Nouvelles ?) 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    ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
00019 C                LDCOSP (Entree) ==> Vrai si le champ est represente
00020 C                                    par des coefficients spectraux;
00021 C                CDNOMA (Sortie) ==> Nom de l'article-champ a ecrire;
00022 C                KLNOMA (Sortie) ==> Nombre de caracteres utiles dans
00023 C                                    CDNOMA;
00024 C    ( Tableau ) PVALCO (Sortie) ==> Donnees destinees a l'ecriture;
00025 C                KLONGD (Sortie) ==> Nombre de valeurs (mots de 64 bits
00026 C                                    en principe) a ecrire.
00027 C
00028 C    Remarques:
00029 C
00030 C    - PVALCO est type reel par commodite, 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 ecrire)
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       REAL (KIND=JPDBLR) PCHAMP (*), PVALCO (*)
00044 C
00045       CHARACTER CDPREF*(*), CDSUFF*(*), CDNOMA*(*)
00046 C
00047       INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANG, INIMES
00048       INTEGER ILPREF, ILSUFF, ILCDNO, IRANGC
00049       INTEGER IB1PAR (FA%JPLB1P)
00050 C
00051       LOGICAL LLVERF, LLRLFI, LDCOSP, LLNOMU, LLNOPA
00052 C
00053       CHARACTER CLPREF*(FA%JPXNOM), CLSUFF*(FA%JPXSUF)
00054 C
00055 #include "facom2.h"
00056 #include "facom_mt.h"
00057 C**
00058 C     1.  -  CONTROLES ET INITIALISATIONS.
00059 C-----------------------------------------------------------------------
00060 C
00061       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00062       IF (LHOOK) CALL DR_HOOK('FACOND_MT',0,ZHOOK_HANDLE)
00063       LLVERF=.FALSE.
00064       LLRLFI=.FALSE.
00065       LLNOMU=.FALSE.
00066       LLNOPA=.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.  -  FABRICATION DE L'ARTICLE A ECRIRE 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       IF (LDCOSP) THEN
00115         IF (FA%NFGRIB(IRANG).EQ.-1.OR.FA%NFGRIB(IRANG).EQ.3) THEN
00116           FA%NRASVE(IRANG)=FA%NRASVE(IRANG)+1
00117           IF (FA%NRASVE(IRANG).EQ.1.AND.FA%NRASHO(IRANG).GT.0) THEN
00118             WRITE(FA%NULOUT,*)
00119      S      '------------------------------------------------'
00120             WRITE(FA%NULOUT,*)' FACOND :  WARNING !!!!!           '
00121             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00122             WRITE(FA%NULOUT,*)
00123      S      ' rangement type modele va etre ecrit alors que'
00124             WRITE(FA%NULOUT,*)
00125      S      ' d''autres champs spec. ont un rangt different.'
00126             WRITE(FA%NULOUT,*)
00127      S      '------------------------------------------------'
00128           ENDIF
00129         ELSEIF (FA%NFGRIB(IRANG).GE.0.AND.FA%NFGRIB(IRANG).LE.2) THEN
00130           FA%NRASHO(IRANG)=FA%NRASHO(IRANG)+1
00131           IF (FA%NRASHO(IRANG).EQ.1.AND.FA%NRASVE(IRANG).GT.0) THEN
00132             WRITE(FA%NULOUT,*)
00133      S      '------------------------------------------------'
00134             WRITE(FA%NULOUT,*)
00135      S      ' FACOND :  WARNING !!!!!           '
00136             WRITE(FA%NULOUT,*)
00137      S      ' Un champ de coeff. spectraux avec'
00138             WRITE(FA%NULOUT,*)
00139      S      ' rangt autre que celui du modele va etre ecrit'
00140             WRITE(FA%NULOUT,*)
00141      S      ' alors que d''autres champs ont le rangt modele'
00142             WRITE(FA%NULOUT,*)
00143      S      '------------------------------------------------'
00144           ENDIF
00145         ENDIF
00146       ENDIF
00147 C
00148 500   CONTINUE
00149 C
00150       IF (FA%NFGRIB(IRANG).EQ.3) THEN
00151 C Cas d'un champ qu'il faut "griber" avec GRIBEX
00152         CALL FACODX_MT (FA,  IREP, IRANG, CDPREF, KNIVAU, CDSUFF, 
00153      S                  PCHAMP, LDCOSP, PVALCO, KLONGD)
00154 C
00155 C Cas particulier de l'erreur GRIBEX num 710: OUTPUT ARRAY TOO SMALL
00156 C On s'en sert pour detecter un probleme de compactage lie a ce que
00157 C le champ compacte + les descripteurs prennent plus de place que le
00158 C champ non compacte...
00159 C On sort donc du compactage (FACODX) pour demander un codage sans
00160 C compactage (FACINE) avec rangement des valeurs selon le modele:
00161 C FA%NFGRIB=-1.
00162 C
00163         IF (IREP==-1710) THEN
00164           IREP = 0
00165           FA%NFGRIB(IRANG) = -1
00166           LLNOPA = .TRUE.
00167           GOTO 500
00168         ENDIF
00169       ELSE
00170         CALL FACINE_MT (FA,  IREP, IRANG, CDNOMA(1:ILNOMU), PCHAMP,
00171      S                LDCOSP, PVALCO, KLONGD, IB1PAR )
00172         IF (LLNOPA) FA%NFGRIB(IRANG) = 3
00173 C  Le codage num 3 avait ete demande mais se revelait etre
00174 C  plus gourmand en place que le num -1: on avait donc force
00175 C  l'absence de compactage (-1). On revient maintenant au codage
00176 C  num 3 pour ce cadre IRANG et les eventuels codages suivants.
00177 C
00178       ENDIF
00179 C**
00180 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00181 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00182 C-----------------------------------------------------------------------
00183 C
00184  1001 CONTINUE
00185       KREP=IREP
00186       LLFATA=LLMOER (IREP,IRANG)
00187 C
00188 C        Deverrouillage eventuel du fichier.
00189 C
00190       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00191 C
00192       IF (LLFATA) THEN
00193         INIMES=2
00194       ELSE
00195         INIMES=IXNVMS(IRANG)
00196       ENDIF
00197 C
00198       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00199         IF (LHOOK) CALL DR_HOOK('FACOND_MT',1,ZHOOK_HANDLE)
00200         RETURN
00201       ENDIF
00202 C
00203       CLNSPR='FACOND'
00204 C
00205       IF (ILPRFU.GE.1) THEN
00206         ILPREF=MIN (ILPRFU,LEN (CLPREF))
00207         CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
00208       ELSE
00209         ILPREF=8
00210         CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF)
00211       ENDIF
00212 C
00213       IF (ILSUFU.GE.1) THEN
00214         ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
00215         CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
00216       ELSE
00217         ILSUFF=8
00218         CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF)
00219       ENDIF
00220 C
00221       IF (.NOT.LLNOMU) THEN
00222         ILNOMU=MIN (ILPREF,FA%NCPCAD)
00223         CDNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
00224       ENDIF
00225 C
00226       WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='
00227 ',I3,     S       '', CDPREF='''''',A,'''''', KNIVAU='
00228 ',I6,     S       '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)')
00229      S   KREP,KNUMER,CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF),LDCOSP
00230       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00231      S                CLNSPR,CDNOMA(1:ILNOMU),LLRLFI)
00232 C
00233       IF (LHOOK) CALL DR_HOOK('FACOND_MT',1,ZHOOK_HANDLE)
00234       END
00235