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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACILE_MT (FA,  KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, 
00003      S                      KCHAMP, 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 de LECTURE d'un CHAMP HORIZONTAL sur un fichier
00009 C     ARPEGE.
00010 C       ( Champ d'Interet en LEcture )
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 ) KCHAMP (Sortie) ==> Valeurs REELLES du champ lu;
00018 C                LDCOSP (Entree) ==> Vrai si le champ est represente
00019 C                                    par des coefficients spectraux.
00020 C     MODIF:
00021 C     JM AUDOIN GMAP/EXT 10/05/95 intro de IVALC3 pour eviter ecrasement
00022 C     D  PARADIS TTI/DEV 12/10/98 partie controle et decodage de l'article
00023 C                                 demenagee dans un ss-prg a usage interne
00024 C                                 du logiciel (FADECI).
00025 C     D  PARADIS DSI/DEV 15/04/04 nettoyage code + declaration IVALCO en
00026 C                                 ALLOCATABLE
00027 #include "precision.h"
00028 C
00029 C
00030       TYPE(FA_COM) :: FA
00031       INTEGER KREP, KNUMER, KNIVAU
00032 C
00033       INTEGER IREP, ILPRFU, ILSUFU, ILNOMU, ILONGA, IRANG, INIMES
00034       INTEGER ILPREF, ILSUFF, IPOSEX, IRANGC
00035 C
00036       INTEGER (KIND=JPDBLE) KCHAMP (*)
00037       INTEGER (KIND=JPDBLE), ALLOCATABLE :: IVALCO(:)
00038       INTEGER IB1PAR (FA%JPLB1P)
00039 C
00040       LOGICAL LLVERF, LLRLFI, LDCOSP, LLNOMU
00041 C
00042       CHARACTER CDPREF*(*), CDSUFF*(*)
00043       CHARACTER CLPREF*(FA%JPXNOM), CLSUFF*(FA%JPXSUF)
00044 C
00045 #include "facom2.h"
00046 #include "facom_mt.h"
00047 C**
00048 C     1.  -  CONTROLES ET INITIALISATIONS.
00049 C-----------------------------------------------------------------------
00050 C
00051       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00052       IF (LHOOK) CALL DR_HOOK('FACILE_MT',0,ZHOOK_HANDLE)
00053       LLVERF=.FALSE.
00054       LLRLFI=.FALSE.
00055       LLNOMU=.FALSE.
00056       ILPRFU=LEN (CDPREF)
00057       ILSUFU=LEN (CDSUFF)
00058       CALL FANUMU_MT (FA, KNUMER,IRANG)
00059 C
00060       IF (IRANG.EQ.0) THEN
00061         IREP=-51
00062         GOTO 1001
00063       ENDIF
00064 C
00065 C         Verrouillage eventuel du fichier.
00066 C
00067       IF (FA%LFAMUL) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'ON')
00068       LLVERF=FA%LFAMUL
00069 C
00070       IF (FA%LCREAF(IRANG)) THEN
00071         IREP=-85
00072         GOTO 1001
00073       ENDIF
00074 C**
00075 C     2.  -  FABRICATION DU NOM D'ARTICLE VIA LE SOUS-PROGRAMME "FANFAR"
00076 C            ( controles de CDPREF, KNIVAU, CDSUFF inclus )
00077 C-----------------------------------------------------------------------
00078 C
00079       CALL FANFAR_MT (FA, IREP,IRANG,CDPREF,KNIVAU,CDSUFF,CLNOMA,
00080      S             IB1PAR(6),ILPRFU,ILSUFU,ILNOMU)
00081       IF (IREP.NE.0) GOTO 1001
00082       LLNOMU=.TRUE.
00083 C**
00084 C     3.  -  LECTURE DE L'ARTICLE SUR LE FICHIER
00085 C-----------------------------------------------------------------------
00086 C
00087       CALL LFINFO_MT (FA%LFI, IREP,KNUMER,CLNOMA(1:ILNOMU),
00088      S             ILONGA,IPOSEX)
00089 C
00090       IF (IREP.NE.0) THEN
00091         LLRLFI=.TRUE.
00092         GOTO 1001
00093       ELSEIF (ILONGA.EQ.0) THEN
00094         IREP=-89
00095         GOTO 1001
00096       ELSEIF (ILONGA.GT.FA%JPXCHA+2) THEN
00097         IREP=-90
00098         GOTO 1001
00099       ENDIF
00100 C
00101 C     ALLOCATE (IVALCO (2*ILONGA))
00102       ALLOCATE (IVALCO (ILONGA))
00103       CALL LFILEC_MT (FA%LFI, IREP,KNUMER,CLNOMA(1:ILNOMU),
00104      S             IVALCO,ILONGA)
00105       LLRLFI=IREP.NE.0
00106       IF (LLRLFI) GOTO 1001
00107 C
00108 C**
00109 C     4.  -  CONTROLES ET DECODAGE DE L'ARTICLE
00110 C----------------------------------------------
00111 C
00112 C  Controle de l'homogeneite du type de rangement de coeff. spectraux
00113 C  parmi les champs lus/ecrits: ces champs compactes avec
00114 C  FA%NIGRIB=-1 ou 3 doivent etre ranges comme dans le modele ("verticalement"
00115 C  soit selon des colonnes JM=cst consecutives) et contrairement si compactes
00116 C  avec FA%NIGRIB= 0,1 ou 2.
00117 C 
00118       IRANGC=FA%NUCADR(IRANG)
00119       IF (LDCOSP) THEN
00120         IF (IVALCO(1).EQ.-1.OR.IVALCO(1).EQ.3) THEN
00121           FA%NRASVE(IRANG)=FA%NRASVE(IRANG)+1
00122           IF (FA%NRASVE(IRANG).EQ.1.AND.FA%NRASHO(IRANG).GT.0) THEN
00123             WRITE(FA%NULOUT,*)
00124      S      '------------------------------------------------'
00125             WRITE(FA%NULOUT,*)' FACILE :  WARNING !!!!!           '
00126             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00127             WRITE(FA%NULOUT,*)
00128      S      ' rangement type modele va etre lu alors que'
00129             WRITE(FA%NULOUT,*)
00130      S      ' d''autres champs spec. ont un rangt different.'
00131             WRITE(FA%NULOUT,*)
00132      S      ' ***  Prenez en compte cette heterogeneite!  ***'
00133             WRITE(FA%NULOUT,*)
00134      S      '------------------------------------------------'
00135           ENDIF
00136         ELSEIF (IVALCO(1).GE.0.AND.IVALCO(1).LE.2) THEN
00137           FA%NRASHO(IRANG)=FA%NRASHO(IRANG)+1
00138           IF (FA%NRASHO(IRANG).EQ.1.AND.FA%NRASVE(IRANG).GT.0) THEN
00139             WRITE(FA%NULOUT,*)
00140      S      '------------------------------------------------'
00141             WRITE(FA%NULOUT,*)' FACILE :  WARNING !!!!!           '
00142             WRITE(FA%NULOUT,*)' Un champ de coeff. spectraux avec'
00143             WRITE(FA%NULOUT,*)
00144      S      ' rangement autre que celui du modele va etre lu'
00145             WRITE(FA%NULOUT,*)
00146      S      ' alors que d''autres champs ont le rangt modele'
00147             WRITE(FA%NULOUT,*)
00148      S      ' ***  Prenez en compte cette heterogeneite!  ***'
00149             WRITE(FA%NULOUT,*)
00150      S      '------------------------------------------------'
00151           ENDIF
00152         ENDIF
00153       ENDIF
00154 C
00155       IF (IVALCO(1).EQ.3) THEN
00156 C Cas d'un champ gribe avec GRIBEX
00157         CALL FADECX_MT (FA, IREP,IRANG,CLNOMA,
00158      S               IVALCO,ILONGA,KCHAMP,LDCOSP)
00159       ELSE
00160         CALL FADECI_MT (FA, IREP,IRANG,CLNOMA,
00161      S               IVALCO,ILONGA,KCHAMP,LDCOSP)
00162       ENDIF
00163 C
00164 C**
00165 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00166 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00167 C-----------------------------------------------------------------------
00168 C
00169  1001 CONTINUE
00170       IF (ALLOCATED( IVALCO )) DEALLOCATE ( IVALCO )
00171       KREP=IREP
00172       LLFATA=LLMOER (IREP,IRANG)
00173 C
00174 C        Deverrouillage eventuel du fichier.
00175 C
00176       IF (LLVERF) CALL LFIVER_MT (FA%LFI, FA%VRFICH(IRANG),'OFF')
00177 
00178       IF (LLFATA) THEN
00179         INIMES=2
00180       ELSE
00181         INIMES=IXNVMS(IRANG)
00182       ENDIF
00183 C
00184       IF (.NOT.LLFATA.AND.INIMES.NE.2)  THEN 
00185         IF (LHOOK) CALL DR_HOOK('FACILE_MT',1,ZHOOK_HANDLE)
00186         RETURN
00187       ENDIF
00188 C
00189       CLNSPR='FACILE'
00190 C
00191       IF (ILPRFU.GE.1) THEN
00192         ILPREF=MIN (ILPRFU,LEN (CLPREF))
00193         CLPREF(1:ILPREF)=CDPREF(1:ILPREF)
00194       ELSE
00195         ILPREF=8
00196         CLPREF(1:ILPREF)=FA%CHAINC(:ILPREF)
00197       ENDIF
00198 C
00199       IF (ILSUFU.GE.1) THEN
00200         ILSUFF=MIN (ILSUFU,LEN (CLSUFF))
00201         CLSUFF(1:ILSUFF)=CDSUFF(1:ILSUFF)
00202       ELSE
00203         ILSUFF=8
00204         CLSUFF(1:ILSUFF)=FA%CHAINC(:ILSUFF)
00205       ENDIF
00206 C
00207       IF (.NOT.LLNOMU) THEN
00208         ILNOMU=MIN (ILPREF,FA%NCPCAD)
00209         CLNOMA(1:ILNOMU)=CLPREF(1:ILPREF)
00210       ENDIF
00211 C
00212       WRITE (UNIT=CLMESS,FMT='(''KREP='',I5,'', KNUMER='
00213 ',I3,     S       '', CDPREF='''''',A,'''''', KNIVAU='
00214 ',I6,     S       '', CDSUFF='''''',A,'''''', LDCOSP= '',L1)')
00215      S   KREP,KNUMER,CLPREF(1:ILPREF),KNIVAU,CLSUFF(1:ILSUFF),LDCOSP
00216       CALL FAIPAR_MT (FA, KNUMER,INIMES,IREP,LLFATA,CLMESS,
00217      S                CLNSPR, CLNOMA(1:ILNOMU),LLRLFI)
00218 C
00219       IF (LHOOK) CALL DR_HOOK('FACILE_MT',1,ZHOOK_HANDLE)
00220       END
00221 
00222 
00223 
00224 
00225 
00226