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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FAIENC_MT (FA,  KREP,   KNUMER, CDPREF, KNIVAU, CDSUFF,
00003      S                      PCHAMP, LDCOSP )
00004       USE FA_MOD, ONLY : FA_COM
00005       USE PARKIND1, ONLY : JPRB
00006       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00007 C****
00008 C      Sous-programme d'ECRITURE d'un CHAMP HORIZONTAL sur un fichier
00009 C     ARPEGE.
00010 C       ( Integration par Ecriture d'un (Nouveau ?) Champ )
00011 C**
00012 C    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00013 C                KNUMER (Entree) ==> Numero de l'unite logique;
00014 C                CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
00015 C                KNIVAU (Entree) ==> Niveau vertical eventuel;
00016 C                CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
00017 C    ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
00018 C                LDCOSP (Entree) ==> Vrai si le champ est represente
00019 C                                    par des coefficients spectraux.
00020 C
00021 C     Modifications
00022 C     -------------
00023 C
00024 C    Avril 1998: Partie "codage" (paragraphe 3 du sous-programme)
00025 C                demenagee dans un sous-programme a usage interne au
00026 C                logiciel (FACINE). Le but est de pouvoir, sur machine
00027 C                a memoire distribuee, separer codage (via FACOND) et
00028 C                ecriture (via FAISAN) afin de paralleliser le codage.
00029 C
00030 C  Avril 2004, D. Paradis, DSI/DEV:
00031 C
00032 C    -Declaration IVALCO en ALLOCATABLE (gain memoire)
00033 C
00034 #include "precision.h"
00035 C
00036 C
00037       TYPE(FA_COM) :: FA
00038       INTEGER KREP, KNUMER, KNIVAU
00039 C
00040       REAL (KIND=JPDBLR) PCHAMP (*)
00041 C
00042       CHARACTER CDPREF*(*), CDSUFF*(*)
00043 C
00044       INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANG, INIMES
00045       INTEGER ILPREF, ILSUFF
00046 C
00047       INTEGER (KIND=JPDBLE), ALLOCATABLE :: IVALCO(:)
00048       INTEGER IB1PAR (FA%JPLB1P)
00049 C
00050       INTEGER IVALC1, IRANGC, ILCHAM
00051 C
00052       LOGICAL LLVERF, LLRLFI, LDCOSP, LLNOMU, LLMLAM, LLNOPA
00053 C
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('FAIENC_MT',0,ZHOOK_HANDLE)
00064       LLVERF=.FALSE.
00065       LLRLFI=.FALSE.
00066       LLNOMU=.FALSE.
00067       LLNOPA=.FALSE.
00068       ILPRFU=LEN (CDPREF)
00069       ILSUFU=LEN (CDSUFF)
00070       CALL FANUMU_MT (FA, KNUMER,IRANG)
00071 C
00072       IF (IRANG.EQ.0) THEN
00073         IREP=-51
00074         GOTO 1001
00075       ENDIF
00076 C
00077 C         Verrouillage eventuel du fichier.
00078 C
00079       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'ON')
00080       LLVERF=FA%LFAMUL
00081 C
00082       IF (FA%LCREAF(IRANG)) THEN
00083         IREP=-85
00084         GOTO 1001
00085       ENDIF
00086 C**
00087 C     2.  -  FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
00088 C            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
00089 C-----------------------------------------------------------------------
00090 C
00091       CALL FANFAR_MT (FA, IREP,IRANG,CDPREF,KNIVAU,CDSUFF,CLNOMA,
00092      S             IB1PAR(6), ILPRFU,ILSUFU,ILNOMU)
00093       IF (IREP.NE.0) GOTO 1001
00094       LLNOMU=.TRUE.
00095 C**
00096 C     3.  -  CALCUL D'UN MAJORANT POUR LA LONGUEUR DE L'ARTICLE (mots)
00097 C            ( on va prendre le nombre de valeurs du champ +2 :
00098 C              l'absence de compactage est un majorant et les 2 mots
00099 C              correspondent a l'enrobage FA dans ce cas )
00100 C-----------------------------------------------------------------------
00101 C
00102       IVALC1=FA%NFGRIB(IRANG)
00103       IRANGC=FA%NUCADR(IRANG)
00104       LLMLAM=FA%LIMLAM(IRANGC)
00105       IF (LDCOSP) THEN
00106         IF (LLMLAM) THEN
00107           ILCHAM=FA%NSFLAM(IRANGC)
00108         ELSE
00109           IF (IVALC1.EQ.-1 .OR. IVALC1.EQ.3) THEN
00110             ILCHAM=(1+FA%MTRONC(IRANGC))*(2+FA%MTRONC(IRANGC))
00111           ELSE
00112             ILCHAM=(1+FA%MTRONC(IRANGC))**2
00113           ENDIF
00114         ENDIF
00115       ELSE
00116         ILCHAM=FA%NVAPDG(IRANGC)
00117       ENDIF
00118 C
00119       ALLOCATE (IVALCO (ILCHAM+2))
00120 
00121 C**
00122 C     4.  -  FABRICATION DE L'ARTICLE A ECRIRE SUR LE FICHIER.
00123 C-----------------------------------------------------------------------
00124 C
00125 C  Controle de l'homogeneite du type de rangement de coeff. spectraux
00126 C  parmi les champs lus/ecrits: ces champs compactes avec
00127 C  FA%NIGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement"
00128 C  soit selon des colonnes JM=cst consecutives) et contrairement si compactes
00129 C  avec FA%NIGRIB= 0,1 ou 2.
00130 C
00131       IRANGC=FA%NUCADR(IRANG)
00132       IF (LDCOSP) THEN
00133         IF (FA%NFGRIB(IRANG).EQ.-1 .OR. FA%NFGRIB(IRANG).EQ.3) THEN
00134           FA%NRASVE(IRANG)=FA%NRASVE(IRANG)+1
00135           IF (FA%NRASVE(IRANG).EQ.1 .AND. FA%NRASHO(IRANG).GT.0) THEN
00136             WRITE(FA%NULOUT,*)
00137      S      '------------------------------------------------'
00138             WRITE(FA%NULOUT,*)' FAIENC :  WARNING !!!!!           '
00139             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00140             WRITE(FA%NULOUT,*)
00141      S      ' rangement type modele va etre ecrit alors que'
00142             WRITE(FA%NULOUT,*)
00143      S      ' les autres champs ont un rangement different.'
00144             WRITE(FA%NULOUT,*)
00145      S      '------------------------------------------------'
00146           ENDIF
00147         ELSEIF (FA%NFGRIB(IRANG).GE.0 .AND. FA%NFGRIB(IRANG).LE.2) THEN
00148           FA%NRASHO(IRANG)=FA%NRASHO(IRANG)+1
00149           IF (FA%NRASHO(IRANG).EQ.1 .AND. FA%NRASVE(IRANG).GT.0) THEN
00150             WRITE(FA%NULOUT,*)
00151      S      '------------------------------------------------'
00152             WRITE(FA%NULOUT,*)' FAIENC :  WARNING !!!!!           '
00153             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00154             WRITE(FA%NULOUT,*)
00155      S      ' rangt autre que celui du modele va etre ecrit'
00156             WRITE(FA%NULOUT,*)
00157      S      ' alors que d''autres champs ont le rangt modele'
00158             WRITE(FA%NULOUT,*)
00159      S      '------------------------------------------------'
00160           ENDIF
00161         ENDIF
00162       ENDIF
00163 C
00164 500   CONTINUE
00165 C
00166       IF (FA%NFGRIB(IRANG).EQ.3) THEN
00167 C Cas d'un champ qu'il faut "griber" avec GRIBEX
00168         CALL FACODX_MT (FA,  IREP, IRANG, CDPREF, KNIVAU, CDSUFF, 
00169      S               PCHAMP(1), LDCOSP, IVALCO, ILONGA)
00170 C
00171 C Cas particulier de l'erreur GRIBEX num 710: OUTPUT ARRAY TOO SMALL
00172 C On s'en sert pour detecter un probleme de compactage lie a ce que
00173 C le champ compacte + les descripteurs prennent plus de place que le
00174 C champ non compacte...
00175 C On sort donc du compactage (FACODX) pour demander un codage sans
00176 C compactage (FACINE) avec rangement des valeurs selon le modele:
00177 C FA%NFGRIB=-1.
00178 C
00179         IF (IREP==-1710) THEN
00180           IREP = 0
00181           FA%NFGRIB(IRANG) = -1
00182           LLNOPA = .TRUE.
00183           GOTO 500
00184         ENDIF
00185       ELSE
00186         CALL FACINE_MT (FA,  IREP, IRANG, CLNOMA(1:ILNOMU), PCHAMP,
00187      S                LDCOSP, IVALCO, ILONGA, IB1PAR )
00188         IF (LLNOPA) FA%NFGRIB(IRANG) = 3
00189 C  Le codage num 3 avait ete demande mais se revelait etre
00190 C  plus gourmand en place que le num -1: on avait donc force
00191 C  l'absence de compactage (-1). On revient maintenant au codage
00192 C  num 3 pour ce cadre IRANG et les eventuels codages suivants.
00193 C
00194       ENDIF
00195       IF (IREP.NE.0) GOTO 1001
00196 C**
00197 C     5.  -  ECRITURE DE L'ARTICLE "CHAMP" SUR LE FICHIER.
00198 C-----------------------------------------------------------------------
00199 C
00200       CALL LFIECR_MT (FA%LFI, IREP,KNUMER,CLNOMA(1:ILNOMU),
00201      S             IVALCO,ILONGA)
00202       LLRLFI=IREP.NE.0
00203 C**
00204 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00205 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00206 C-----------------------------------------------------------------------
00207 C
00208  1001 CONTINUE
00209       IF (ALLOCATED( IVALCO )) DEALLOCATE ( IVALCO )
00210       KREP=IREP
00211       LLFATA=LLMOER (IREP,IRANG)
00212 C
00213 C        Deverrouillage eventuel du fichier.
00214 C
00215       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00216 C
00217       IF (LLFATA) THEN
00218         INIMES=2
00219       ELSE
00220         INIMES=IXNVMS(IRANG)
00221       ENDIF
00222 C
00223       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00224         IF (LHOOK) CALL DR_HOOK('FAIENC_MT',1,ZHOOK_HANDLE)
00225         RETURN
00226       ENDIF
00227 C
00228       CLNSPR='FAIENC'
00229 C
00230       IF (ILPRFU.GE.1) THEN
00231         ILPREF=MIN (ILPRFU,LEN (CLPREF))
00232         CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
00233       ELSE
00234         ILPREF=8
00235         CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF)
00236       ENDIF
00237 C
00238       IF (ILSUFU.GE.1) THEN
00239         ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
00240         CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
00241       ELSE
00242         ILSUFF=8
00243         CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF)
00244       ENDIF
00245 C
00246       IF (.NOT.LLNOMU) THEN
00247         ILNOMU=MIN (ILPREF,FA%NCPCAD)
00248         CLNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
00249       ENDIF
00250 C
00251       WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KNUMER='
00252 ',I3,     S       '', CDPREF='''''',A,'''''', KNIVAU='
00253 ',I6,     S       '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)')
00254      S   KREP,KNUMER,CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF),LDCOSP
00255       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00256      S                CLNSPR, CLNOMA(1:ILNOMU),LLRLFI)
00257 C
00258       IF (LHOOK) CALL DR_HOOK('FAIENC_MT',1,ZHOOK_HANDLE)
00259       END
00260