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

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FAREGI_MT (FA,  CDCLEF, KVAL, KOPT )
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 C****
00007 C      Ce sous-programme controle (lecture/ecriture) les options
00008 C      de compression de GRIBEX implicites.
00009 C      (REGlage des options Implicites de codage de gribex)
00010 C**
00011 C    Arguments : CDCLEF (Entree) ==> Mot clef precisant l'action a faire;
00012 C                KVAL   (Sortie  ==> Valeur lue ou ecrite;
00013 C                      ou Entree)
00014 C                KOPT   (Entree) ==> Flag: 0->lecture 1->ecriture;
00015 C*
00016 C     Signification des divers elements du tableau FA%NCODGRI
00017 C
00018 C     FA%NCODGRI(1) = type de codage (0->option HOPER='C'; 1->option HOPER='K')
00019 C     FA%NCODGRI(2) = KSEC4(6), indicateur de la presence de flags
00020 C                               additionnels (0->non; 16->oui)
00021 C     FA%NCODGRI(3) = KSEC4(7)
00022 C     FA%NCODGRI(4) = KSEC4(9), indicateur de la presence de bitmaps
00023 C                             secondaires (0->non; 32->oui)
00024 C     FA%NCODGRI(5) = KSEC4(10), indicateur pour le nb de bits des
00025 C                        groupes de pts de grille (0->const.; 16->different)
00026 C     FA%NCODGRI(6) = KSEC4(11), nb de bits pour les groupes de pts de
00027 C                      grille, quand il est constant.
00028 C                        Si negatif, le logiciel calcule un nb optimal a partir
00029 C                        de -KSEC4(11).
00030 C     FA%NCODGRI(7) = KSEC4(12), indicateur pour les extensions generales de la
00031 C                        compression (0->non; 8->oui)
00032 C     FA%NCODGRI(8) = KSEC4(13), indicateur pour le rearrangement boustrophedo
00033 C                        nique (0->non; 4->oui)
00034 C     FA%NCODGRI(9) = KSEC4(14) (valeurs possibles: -1, 0 et 2)
00035 C     FA%NCODGRI(10) = KSEC4(15) (valeurs possibles: -1, 0 et 1), sert avec
00036 C                         KSEC4(14) a definir la technique de la difference
00037 C                         spatiale.Si l'un des 2 est negatif, l'ordre de
00038 C                         differentiation est estime dynamiquement, sinon
00039 C                         l'ordre vaut KSEC4(14)+KSEC4(15)
00040 C
00041 #include "precision.h"
00042 C
00043 C
00044       TYPE(FA_COM) :: FA
00045       INTEGER KNUMER, KVAL, KOPT
00046 C
00047       CHARACTER*5 CDCLEF
00048 C
00049       INTEGER INUMER, INIMES, IREP, INBITSMAX
00050 C
00051       LOGICAL LLVERG
00052 #include "facom2.h"
00053 #include "facom_mt.h"
00054 C
00055 C
00056 C
00057 C**
00058 C     0.  -  INITIALISATIONS ET ALLOCATIONS PREALABLES
00059 C-----------------------------------------------------------------------
00060 C
00061       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00062       IF (LHOOK) CALL DR_HOOK('FAREGI_MT',0,ZHOOK_HANDLE)
00063       IREP=0
00064       IF (FA%FAREGI_LLPREA) THEN
00065 C
00066 C          A la premiere utilisation, appel au sous-programme "FARINE".
00067 C
00068         CALL FARINE_MT(FA, 2)
00069         FA%FAREGI_LLPREA=.FALSE.
00070       ENDIF
00071       INBITSMAX=MAX(FA%NBIPDG,FA%NBICSP)
00072 C
00073 C**
00074 C     1.  -  SPECIFICATION D'UN NOUVEAU CODAGE
00075 C-----------------------------------------------------------------------
00076 C
00077       IF (KOPT==1) THEN
00078 C
00079 C   Pas de compression (sous-tronc et puissance laplacien
00080 C   ajoutees systematiquement + tard pour les coeff spectraux)
00081 C
00082         IF (CDCLEF=='BASIC'.OR.CDCLEF=='basic') THEN
00083           FA%NCODGRI(1)=0
00084           FA%NCODGRI(2)=0
00085           FA%NCODGRI(3)=0
00086           FA%NCODGRI(4)=0
00087           FA%NCODGRI(5)=0
00088           FA%NCODGRI(6)=0
00089 C
00090 C   Comme le "BASIC" avec une compression
00091 C   ligne a ligne pour les points de grille
00092 C
00093         ELSEIF (CDCLEF=='PACK1'.OR.CDCLEF=='pack1') THEN
00094           FA%NCODGRI(1)=0
00095           FA%NCODGRI(2)=16
00096           FA%NCODGRI(3)=0
00097           FA%NCODGRI(4)=0
00098           FA%NCODGRI(5)=16
00099           FA%NCODGRI(6)=0
00100 C
00101 C   Comme le "BASIC" avec une compression
00102 C   pour les points de grille ou le nb de bits est le meme
00103 C   dans chaque groupe de points de grille
00104 C
00105         ELSEIF (CDCLEF=='PACK2'.OR.CDCLEF=='pack2') THEN
00106           FA%NCODGRI(1)=0
00107           FA%NCODGRI(2)=16
00108           FA%NCODGRI(3)=0
00109           FA%NCODGRI(4)=32
00110           FA%NCODGRI(5)=0
00111 C Un nb de bits optimal sera recherche par le logiciel
00112           FA%NCODGRI(6)=-99
00113 C
00114 C   Comme le "BASIC" avec une compression
00115 C   "OMM general" pour les points de grille
00116 C
00117         ELSEIF (CDCLEF=='PACK3'.OR.CDCLEF=='pack3') THEN
00118           FA%NCODGRI(1)=0
00119           FA%NCODGRI(2)=16
00120           FA%NCODGRI(3)=0
00121           FA%NCODGRI(4)=32
00122           FA%NCODGRI(5)=16
00123           FA%NCODGRI(6)=0
00124 C
00125 C   Compression "aggressive": le logiciel va
00126 C   tenter la compression ligne a ligne et comparer la
00127 C   longueur de message obtenue avec celle en l'absence de
00128 C   compression et au final retenir la meilleure solution.
00129 C
00130         ELSEIF (CDCLEF=='APAC1'.OR.CDCLEF=='apac1') THEN
00131           FA%NCODGRI(1)=1
00132           FA%NCODGRI(2)=16
00133           FA%NCODGRI(3)=0
00134           FA%NCODGRI(4)=0
00135           FA%NCODGRI(5)=16
00136           FA%NCODGRI(6)=0
00137 C
00138 C   Compression "aggressive": le logiciel va
00139 C   suivre la demarche "APAC1" en testant en plus le nb de bits
00140 C   constant par groupe de pts de grille et retenir la meilleure
00141 C   compression
00142 C
00143         ELSEIF (CDCLEF=='APAC2'.OR.CDCLEF=='apac2') THEN
00144           FA%NCODGRI(1)=1
00145           FA%NCODGRI(2)=16
00146           FA%NCODGRI(3)=0
00147           FA%NCODGRI(4)=0
00148           FA%NCODGRI(5)=0
00149 C Un nb de bits optimal sera recherche par le logiciel
00150           FA%NCODGRI(6)=-99
00151 C
00152 C   Compression "aggressive": le logiciel va
00153 C   suivre la demarche "APAC1" en testant en plus la compression
00154 C   "general OMM" et retenir la meilleure compression.
00155 C
00156         ELSEIF (CDCLEF=='APAC3'.OR.CDCLEF=='apac3') THEN
00157           FA%NCODGRI(1)=1
00158           FA%NCODGRI(2)=16
00159           FA%NCODGRI(3)=0
00160           FA%NCODGRI(4)=32
00161           FA%NCODGRI(5)=16
00162           FA%NCODGRI(6)=0
00163 C
00164 C   Compression "aggressive": le logiciel va
00165 C   suivre la demarche "APAC3" en testant en plus le nb de bits
00166 C   constant par groupe de pts de grille et retenir la meilleure
00167 C   compression.
00168 C
00169         ELSEIF (CDCLEF=='APAC4'.OR.CDCLEF=='apac4') THEN
00170           FA%NCODGRI(1)=1
00171           FA%NCODGRI(2)=16
00172           FA%NCODGRI(3)=0
00173           FA%NCODGRI(4)=32
00174           FA%NCODGRI(5)=0
00175 C Un nb de bits optimal sera recherche par le logiciel
00176           FA%NCODGRI(6)=-99
00177 C
00178 C   Specification du nb de bits a utiliser dans le cadre
00179 C   de la compression avec nb de bits constant
00180 C   par groupe de pts de grille
00181 C   
00182         ELSEIF (CDCLEF=='WIDPA'.OR.CDCLEF=='widpa') THEN
00183           IF (KVAL.LT.1-INBITSMAX.OR.KVAL.GT.INBITSMAX-1) THEN
00184             IREP=-97
00185             GOTO 1001
00186           ENDIF
00187           FA%NCODGRI(6)=KVAL
00188 C
00189 C   Demande supplementaire de l'extension generale de la compression
00190 C   (si KVAL=1, sinon c'est le retrait de cette option)
00191 C
00192         ELSEIF (CDCLEF=='GEXTE'.OR.CDCLEF=='gexte') THEN
00193           IF (KVAL.EQ.1) THEN
00194             CALL GRSX2O(1)
00195             FA%NCODGRI(7)=8
00196           ELSE
00197             FA%NCODGRI(7)=0
00198           ENDIF
00199 C
00200 C   Demande supplementaire du rearrangement boustrophedonique dans la
00201 C   compression (si KVAL=1, sinon c'est le retrait de cette option)
00202 C
00203         ELSEIF (CDCLEF=='BOUST'.OR.CDCLEF=='boust') THEN
00204           IF (KVAL.EQ.1) THEN
00205             CALL GRSX2O(1)
00206             FA%NCODGRI(8)=4
00207           ELSE
00208             FA%NCODGRI(8)=0
00209           ENDIF
00210 C
00211 C   Demande supplementaire de la difference spatiale dans la compression.
00212 C   KVAL donne l'ordre de differentiation:
00213 C   -1-> calcul dynamique par GRIBEX; 1 a 3->ordre; 0->desactiv; autre->err
00214 C
00215         ELSEIF (CDCLEF=='DIFFE'.OR.CDCLEF=='diffe') THEN
00216           IF (KVAL.EQ.-1) THEN
00217             CALL GRSX2O(1)
00218             CALL GRSN2O(1)
00219             FA%NCODGRI( 9)=0
00220             FA%NCODGRI(10)=-1
00221           ELSEIF (KVAL.EQ.1) THEN
00222             CALL GRSX2O(1)
00223             CALL GRSN2O(1)
00224             FA%NCODGRI( 9)=0
00225             FA%NCODGRI(10)=1
00226           ELSEIF (KVAL.EQ.2) THEN
00227             CALL GRSX2O(1)
00228             CALL GRSN2O(1)
00229             FA%NCODGRI( 9)=2
00230             FA%NCODGRI(10)=0
00231           ELSEIF (KVAL.EQ.3) THEN
00232             CALL GRSX2O(1)
00233             CALL GRSN2O(1)
00234             FA%NCODGRI( 9)=2
00235             FA%NCODGRI(10)=1
00236           ELSEIF (KVAL.EQ.0) THEN
00237             CALL GRSN2O(0)
00238             FA%NCODGRI( 9)=0
00239             FA%NCODGRI(10)=0
00240           ELSE
00241             IREP=-125
00242             GOTO 1001
00243           ENDIF
00244         ENDIF
00245 C**
00246 C     2.  -  DEMANDE D'INFORMATION
00247 C-----------------------------------------------------------------------
00248 C
00249       ELSEIF (KOPT==0) THEN
00250 C
00251 C   Obtention des mots-clef disponibles
00252 C
00253         IF (CDCLEF=='CLEFS'.OR.CDCLEF=='clefs') THEN
00254           KVAL=0
00255           WRITE (UNIT=FA%NULOUT,FMT=*)
00256           WRITE (UNIT=FA%NULOUT,FMT=*)
00257      S    'Mots clef disponibles pour FAREGI:'
00258           WRITE (UNIT=FA%NULOUT,FMT=*)
00259           WRITE (UNIT=FA%NULOUT,FMT=*)'BASIC: pas de compression'
00260           WRITE (UNIT=FA%NULOUT,FMT=*)
00261      S    'PACK1: BASIC avec une compression'
00262           WRITE (UNIT=FA%NULOUT,FMT=*)
00263      S    '       ligne a ligne pour les pts de grille'
00264           WRITE (UNIT=FA%NULOUT,FMT=*)
00265      S    'PACK2: BASIC avec une compression'
00266           WRITE (UNIT=FA%NULOUT,FMT=*)
00267      S    '       ou le nb de bits est cst pour les groupes'
00268           WRITE (UNIT=FA%NULOUT,FMT=*)
00269      S    'PACK3: BASIC avec une compression'
00270           WRITE (UNIT=FA%NULOUT,FMT=*)
00271      S    '       OMM general pour les points de grille'
00272           WRITE (UNIT=FA%NULOUT,FMT=*)
00273      S    'APAC1: compression agressive'
00274           WRITE (UNIT=FA%NULOUT,FMT=*)
00275      S    '       BASIC et PACK1 sont testes'
00276           WRITE (UNIT=FA%NULOUT,FMT=*)
00277      S    'APAC2: compression agressive'
00278           WRITE (UNIT=FA%NULOUT,FMT=*)
00279      S    '       BASIC, PACK1 et PACK2 sont testes'
00280           WRITE (UNIT=FA%NULOUT,FMT=*)
00281      S    'APAC3: compression agressive'
00282           WRITE (UNIT=FA%NULOUT,FMT=*)
00283      S    '       BASIC, PACK1 et PACK3 sont testes'
00284           WRITE (UNIT=FA%NULOUT,FMT=*)
00285      S    'APAC4: compression agressive'
00286           WRITE (UNIT=FA%NULOUT,FMT=*)
00287      S    '       BASIC, PACK1, PACK2 et PACK3 testes'
00288           WRITE (UNIT=FA%NULOUT,FMT=*)
00289      S    'WIDPA: lecture/ecriture du nb de bits'
00290           WRITE (UNIT=FA%NULOUT,FMT=*)
00291      S    '       a utiliser pour les groupes de points'
00292           WRITE (UNIT=FA%NULOUT,FMT=*)
00293      S    '       de grille dans le cas PACK2'
00294           WRITE (UNIT=FA%NULOUT,FMT=*)
00295      S    'GEXTE: les extensions generales de la compression'
00296           WRITE (UNIT=FA%NULOUT,FMT=*)
00297      S    '       sont activees (KVAL=1) ou desactiv. (KVAL=0)'
00298           WRITE (UNIT=FA%NULOUT,FMT=*)
00299      S    'BOUST: le rearrangement boustrophedonique est'
00300           WRITE (UNIT=FA%NULOUT,FMT=*)
00301      S    '       active (KVAL=1) ou desactive (KVAL=0)'
00302           WRITE (UNIT=FA%NULOUT,FMT=*)
00303      S    'DIFFE: la differenciation spatiale est'
00304           WRITE (UNIT=FA%NULOUT,FMT=*)
00305      S    '       activee (KVAL=ordre de differ. (1 a 3)'
00306           WRITE (UNIT=FA%NULOUT,FMT=*)
00307      S    '       ou -1 (calcul dyn)) ou desactivee (0)'
00308           WRITE (UNIT=FA%NULOUT,FMT=*)
00309 C
00310 C   Lecture du nb de bits a utiliser dans le cadre
00311 C   de la compression avec nb de bits constant
00312 C   par groupe de pts de grille
00313 C   
00314         ELSEIF (CDCLEF=='WIDPA'.OR.CDCLEF=='widpa') THEN
00315           KVAL=FA%NCODGRI(6)
00316 C
00317 C   Lecture de la presence ou non de la compression
00318 C   "general extended"
00319 C
00320         ELSEIF (CDCLEF=='GEXTE'.OR.CDCLEF=='gexte') THEN
00321           KVAL = FA%NCODGRI(7) / 8
00322 C
00323 C   Lecture de la presence ou non du rearrangement
00324 C   boustrophedonique.
00325 C
00326         ELSEIF (CDCLEF=='BOUST'.OR.CDCLEF=='boust') THEN
00327           KVAL = FA%NCODGRI(8) / 4
00328 C
00329 C   Lecture de la presence ou non de la differentiation spatiale
00330 C
00331         ELSEIF (CDCLEF=='DIFFE'.OR.CDCLEF=='diffe') THEN
00332           KVAL=FA%NCODGRI( 9)+FA%NCODGRI(10)
00333         ELSE
00334           IREP=-125
00335           GOTO 1001
00336         ENDIF
00337 C**
00338 C     3.  -  OPTION INCONNUE
00339 C-----------------------------------------------------------------------
00340 C
00341       ELSE
00342         IREP=-125
00343         GOTO 1001
00344       ENDIF
00345 C**
00346 C    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
00347 C            VIA LE SOUS-PROGRAMME "FAIPAR" .
00348 C-----------------------------------------------------------------------
00349 C
00350  1001 CONTINUE
00351       LLFATA=LLMOER (IREP,0)
00352 C
00353       IF (LLFATA) THEN
00354         INIMES=2
00355       ELSE
00356         INIMES=FA%NIMSGA
00357       ENDIF
00358 C
00359       IF (INIMES.EQ.0)  THEN 
00360         IF (LHOOK) CALL DR_HOOK('FAREGI_MT',1,ZHOOK_HANDLE)
00361         RETURN
00362       ENDIF
00363 C
00364       CLNSPR='FAREGI'
00365       INUMER=FA%JPNIIL
00366 C
00367       WRITE (UNIT=CLMESS,FMT='(''IREP='
00368 ',I2,     S        '', CDCLEF='''''',A,'''''', KVAL='
00369 ',I12,     S        '', KOPT='',I4)')
00370      S        IREP,CDCLEF,KVAL,KOPT
00371       INUMER=FA%JPNIIL
00372       CALL FAIPAR_MT (FA, INUMER,INIMES,IREP,LLFATA,CLMESS,
00373      S                CLNSPR,CLNSPR,.FALSE.)
00374 C
00375       IF (LHOOK) CALL DR_HOOK('FAREGI_MT',1,ZHOOK_HANDLE)
00376       END
00377