faregi.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE faregi_fort                         &
&                     (fa,  cdclef, kval, kopt)
USE fa_mod, ONLY : fa_com, jpniil
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Ce sous-programme controle (lecture/ecriture) les options
!      de compression de GRIBEX implicites.
!      (REGlage des options Implicites de codage de gribex)
!**
!    Arguments : CDCLEF (Entree) ==> Mot clef precisant l'action a faire;
!                KVAL   (Sortie  ==> Valeur lue ou ecrite;
!                      ou Entree)
!                KOPT   (Entree) ==> Flag: 0->lecture 1->ecriture;
!*
!     Signification des divers elements du tableau FA%NCODGRI
!
!     NCODGRI(1) = type de codage (0->option HOPER='C'; 1->option HOPER='K')
!     NCODGRI(2) = KSEC4(6), indicateur de la presence de flags
!                            additionnels (0->non; 16->oui)
!     NCODGRI(3) = KSEC4(7)
!     NCODGRI(4) = KSEC4(9), indicateur de la presence de bitmaps
!                          secondaires (0->non; 32->oui)
!     NCODGRI(5) = KSEC4(10), indicateur pour le nb de bits des
!                     groupes de pts de grille (0->const.; 16->different)
!     NCODGRI(6) = KSEC4(11), nb de bits pour les groupes de pts de
!                   grille, quand il est constant.
!                     Si negatif, le logiciel calcule un nb optimal a partir
!                     de -KSEC4(11).
!     NCODGRI(7) = KSEC4(12), indicateur pour les extensions generales de la
!                     compression (0->non; 8->oui)
!     NCODGRI(8) = KSEC4(13), indicateur pour le rearrangement boustrophedo
!                     nique (0->non; 4->oui)
!     NCODGRI(9) = KSEC4(14) (valeurs possibles: -1, 0 et 2)
!     NCODGRI(10) = KSEC4(15) (valeurs possibles: -1, 0 et 1), sert avec
!                      KSEC4(14) a definir la technique de la difference
!                      spatiale.Si l'un des 2 est negatif, l'ordre de
!                      differentiation est estime dynamiquement, sinon
!                      l'ordre vaut KSEC4(14)+KSEC4(15)
!     NCODGRI(11) = 1->Calcul automatique de KSEC1 (23), 0->On laisse faire
!     NCODGRI(12) = Ecriture des champs GRIB1 dans un fichier externe
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KVAL, KOPT
!
CHARACTER(LEN=*) CDCLEF
!
INTEGER (KIND=JPLIKB) INUMER, INIMES, IREP, INBITSMAX
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!
!
!
!**
!     0.  -  INITIALISATIONS ET ALLOCATIONS PREALABLES
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FAREGI_MT',0,zhook_handle)
irep=0
IF (fa%FAREGI_LLPREA) THEN
!
!          A la premiere utilisation, appel au sous-programme "FARINE".
!
  CALL farine_fort             &
&                (fa, 2_jplikb )
  fa%FAREGI_LLPREA=.false.
ENDIF
inbitsmax=max(fa%NBIPDG,fa%NBICSP)
!
!**
!     1.  -  SPECIFICATION D'UN NOUVEAU CODAGE
!-----------------------------------------------------------------------
!
IF (kopt==1) THEN
!
!   Pas de compression (sous-tronc et puissance laplacien
!   ajoutees systematiquement + tard pour les coeff spectraux)
!
  IF (cdclef=='BASIC'.OR.cdclef=='basic') THEN
    fa%NCODGRI(1)=0
    fa%NCODGRI(2)=0
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=0
    fa%NCODGRI(5)=0
    fa%NCODGRI(6)=0
  ELSEIF (cdclef=='IDCEN'.OR.cdclef=='idcen') THEN
    fa%NIDCEN = kval
!
!   Comme le "BASIC" avec une compression
!   ligne a ligne pour les points de grille
!
  ELSEIF (cdclef=='PACK1'.OR.cdclef=='pack1') THEN
    fa%NCODGRI(1)=0
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=0
    fa%NCODGRI(5)=16
    fa%NCODGRI(6)=0
!
!   Comme le "BASIC" avec une compression
!   pour les points de grille ou le nb de bits est le meme
!   dans chaque groupe de points de grille
!
  ELSEIF (cdclef=='PACK2'.OR.cdclef=='pack2') THEN
    fa%NCODGRI(1)=0
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=32
    fa%NCODGRI(5)=0
! Un nb de bits optimal sera recherche par le logiciel
    fa%NCODGRI(6)=-99
!
!   Comme le "BASIC" avec une compression
!   "OMM general" pour les points de grille
!
  ELSEIF (cdclef=='PACK3'.OR.cdclef=='pack3') THEN
    fa%NCODGRI(1)=0
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=32
    fa%NCODGRI(5)=16
    fa%NCODGRI(6)=0
!
!   Compression "aggressive": le logiciel va
!   tenter la compression ligne a ligne et comparer la
!   longueur de message obtenue avec celle en l'absence de
!   compression et au final retenir la meilleure solution.
!
  ELSEIF (cdclef=='APAC1'.OR.cdclef=='apac1') THEN
    fa%NCODGRI(1)=1
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=0
    fa%NCODGRI(5)=16
    fa%NCODGRI(6)=0
!
!   Compression "aggressive": le logiciel va
!   suivre la demarche "APAC1" en testant en plus le nb de bits
!   constant par groupe de pts de grille et retenir la meilleure
!   compression
!
  ELSEIF (cdclef=='APAC2'.OR.cdclef=='apac2') THEN
    fa%NCODGRI(1)=1
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=0
    fa%NCODGRI(5)=0
! Un nb de bits optimal sera recherche par le logiciel
    fa%NCODGRI(6)=-99
!
!   Compression "aggressive": le logiciel va
!   suivre la demarche "APAC1" en testant en plus la compression
!   "general OMM" et retenir la meilleure compression.
!
  ELSEIF (cdclef=='APAC3'.OR.cdclef=='apac3') THEN
    fa%NCODGRI(1)=1
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=32
    fa%NCODGRI(5)=16
    fa%NCODGRI(6)=0
!
!   Compression "aggressive": le logiciel va
!   suivre la demarche "APAC3" en testant en plus le nb de bits
!   constant par groupe de pts de grille et retenir la meilleure
!   compression.
!
  ELSEIF (cdclef=='APAC4'.OR.cdclef=='apac4') THEN
    fa%NCODGRI(1)=1
    fa%NCODGRI(2)=16
    fa%NCODGRI(3)=0
    fa%NCODGRI(4)=32
    fa%NCODGRI(5)=0
! Un nb de bits optimal sera recherche par le logiciel
    fa%NCODGRI(6)=-99
!
!   Specification du nb de bits a utiliser dans le cadre
!   de la compression avec nb de bits constant
!   par groupe de pts de grille
!   
  ELSEIF (cdclef=='WIDPA'.OR.cdclef=='widpa') THEN
    IF (kval.LT.1-inbitsmax.OR.kval.GT.inbitsmax-1) THEN
      irep=-97
      GOTO 1001
    ENDIF
    fa%NCODGRI(6)=kval
!
!   Demande supplementaire de l'extension generale de la compression
!   (si KVAL=1, sinon c'est le retrait de cette option)
!
  ELSEIF (cdclef=='GEXTE'.OR.cdclef=='gexte') THEN
    IF (kval.EQ.1) THEN
      fa%IOPTGRSX2O=1
      fa%NCODGRI(7)=8
    ELSE
      fa%NCODGRI(7)=0
    ENDIF
!
!   Demande supplementaire du rearrangement boustrophedonique dans la
!   compression (si KVAL=1, sinon c'est le retrait de cette option)
!
  ELSEIF (cdclef=='BOUST'.OR.cdclef=='boust') THEN
    IF (kval.EQ.1) THEN
      fa%IOPTGRSX2O=1
      fa%NCODGRI(8)=4
    ELSE
      fa%NCODGRI(8)=0
    ENDIF
!
!   Demande supplementaire de la difference spatiale dans la compression.
!   KVAL donne l'ordre de differentiation:
!   -1-> calcul dynamique par GRIBEX; 1 a 3->ordre; 0->desactiv; autre->err
!
  ELSEIF (cdclef=='DIFFE'.OR.cdclef=='diffe') THEN
    IF (kval.EQ.-1) THEN
      fa%IOPTGRSX2O=1
      fa%IOPTGRSN2O=1
      fa%NCODGRI( 9)=0
      fa%NCODGRI(10)=-1
    ELSEIF (kval.EQ.1) THEN
      fa%IOPTGRSX2O=1
      fa%IOPTGRSN2O=1
      fa%NCODGRI( 9)=0
      fa%NCODGRI(10)=1
    ELSEIF (kval.EQ.2) THEN
      fa%IOPTGRSX2O=1
      fa%IOPTGRSN2O=1
      fa%NCODGRI( 9)=2
      fa%NCODGRI(10)=0
    ELSEIF (kval.EQ.3) THEN
      fa%IOPTGRSX2O=1
      fa%IOPTGRSN2O=1
      fa%NCODGRI( 9)=2
      fa%NCODGRI(10)=1
    ELSEIF (kval.EQ.0) THEN
      fa%IOPTGRSX2O=0
      fa%NCODGRI( 9)=0
      fa%NCODGRI(10)=0
    ELSE
      irep=-125
      GOTO 1001
    ENDIF
!
!   Facteur decimal; calcul automatique
!
  ELSEIF (cdclef=='FACDEC'.OR.cdclef=='facdec') THEN
    fa%NCODGRI(11)=kval
!
!  Ecriture dans un fichier externe
!
  ELSEIF (cdclef=='EXTERN'.OR.cdclef=='extern') THEN
    fa%NCODGRI(12)=kval
  ENDIF
!**
!     2.  -  DEMANDE D'INFORMATION
!-----------------------------------------------------------------------
!
ELSEIF (kopt==0) THEN
!
!   Obtention des mots-clef disponibles
!
  IF (cdclef=='CLEFS'.OR.cdclef=='clefs') THEN
    kval=0
    WRITE (unit=fa%NULOUT,fmt=*)
    WRITE (unit=fa%NULOUT,fmt=*) 'Mots clef disponibles pour FAREGI:'
    WRITE (unit=fa%NULOUT,fmt=*)
    WRITE (unit=fa%NULOUT,fmt=*) 'BASIC: pas de compression'
    WRITE (unit=fa%NULOUT,fmt=*) 'PACK1: BASIC avec une compression'
    WRITE (unit=fa%NULOUT,fmt=*) '       ligne a ligne pour les pts de grille'
    WRITE (unit=fa%NULOUT,fmt=*) 'PACK2: BASIC avec une compression'
    WRITE (unit=fa%NULOUT,fmt=*) '       ou le nb de bits est cst pour les groupes'
    WRITE (unit=fa%NULOUT,fmt=*) 'PACK3: BASIC avec une compression'
    WRITE (unit=fa%NULOUT,fmt=*) '       OMM general pour les points de grille'
    WRITE (unit=fa%NULOUT,fmt=*) 'APAC1: compression agressive'
    WRITE (unit=fa%NULOUT,fmt=*) '       BASIC et PACK1 sont testes'
    WRITE (unit=fa%NULOUT,fmt=*) 'APAC2: compression agressive'
    WRITE (unit=fa%NULOUT,fmt=*) '       BASIC, PACK1 et PACK2 sont testes'
    WRITE (unit=fa%NULOUT,fmt=*) 'APAC3: compression agressive'
    WRITE (unit=fa%NULOUT,fmt=*) '       BASIC, PACK1 et PACK3 sont testes'
    WRITE (unit=fa%NULOUT,fmt=*) 'APAC4: compression agressive'
    WRITE (unit=fa%NULOUT,fmt=*) '       BASIC, PACK1, PACK2 et PACK3 testes'
    WRITE (unit=fa%NULOUT,fmt=*) 'WIDPA: lecture/ecriture du nb de bits'
    WRITE (unit=fa%NULOUT,fmt=*) '       a utiliser pour les groupes de points'
    WRITE (unit=fa%NULOUT,fmt=*) '       de grille dans le cas PACK2'
    WRITE (unit=fa%NULOUT,fmt=*) 'GEXTE: les extensions generales de la compression'
    WRITE (unit=fa%NULOUT,fmt=*) '       sont activees (KVAL=1) ou desactiv. (KVAL=0)'
    WRITE (unit=fa%NULOUT,fmt=*) 'BOUST: le rearrangement boustrophedonique est'
    WRITE (unit=fa%NULOUT,fmt=*) '       active (KVAL=1) ou desactive (KVAL=0)'
    WRITE (unit=fa%NULOUT,fmt=*) 'DIFFE: la differenciation spatiale est'
    WRITE (unit=fa%NULOUT,fmt=*) '       activee (KVAL=ordre de differ. (1 a 3)'
    WRITE (unit=fa%NULOUT,fmt=*) '       ou -1 (calcul dyn)) ou desactivee (0)'
    WRITE (unit=fa%NULOUT,fmt=*) 'FACDEC: calcul automatique du facteur decimal'
    WRITE (unit=fa%NULOUT,fmt=*) 'EXTERN: ecriture dans un fichier externe'
    WRITE (unit=fa%NULOUT,fmt=*)
  ELSEIF (cdclef=='IDCEN'.OR.cdclef=='idcen') THEN
    kval = fa%NIDCEN 
!
!   Lecture du nb de bits a utiliser dans le cadre
!   de la compression avec nb de bits constant
!   par groupe de pts de grille
!   
  ELSEIF (cdclef=='WIDPA'.OR.cdclef=='widpa') THEN
    kval=fa%NCODGRI(6)
!
!   Lecture de la presence ou non de la compression
!   "general extended"
!
  ELSEIF (cdclef=='GEXTE'.OR.cdclef=='gexte') THEN
    kval = fa%NCODGRI(7) / 8
!
!   Lecture de la presence ou non du rearrangement
!   boustrophedonique.
!
  ELSEIF (cdclef=='BOUST'.OR.cdclef=='boust') THEN
    kval = fa%NCODGRI(8) / 4
!
!   Lecture de la presence ou non de la differentiation spatiale
!
  ELSEIF (cdclef=='DIFFE'.OR.cdclef=='diffe') THEN
    kval=fa%NCODGRI( 9)+fa%NCODGRI(10)
!
!   Facteur decimal; calcul automatique
!
  ELSEIF (cdclef=='FACDEC'.OR.cdclef=='facdec') THEN
    kval=fa%NCODGRI(11)
!
!   Ecriture dans un fichier externe
!
  ELSEIF (cdclef=='EXTERN'.OR.cdclef=='extern') THEN
    kval=fa%NCODGRI(12)
  ELSE
    irep=-125
    GOTO 1001
  ENDIF
!**
!     3.  -  OPTION INCONNUE
!-----------------------------------------------------------------------
!
ELSE
  irep=-125
  GOTO 1001
ENDIF
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
llfata=llmoer(irep,0_jplikb )
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=fa%NIMSGA
ENDIF
!
IF (inimes.EQ.0)  THEN 
  IF (lhook) CALL dr_hook('FAREGI_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FAREGI'
inumer=jpniil
!
WRITE (unit=clmess,fmt='(''IREP='',I2,            &
&        '', CDCLEF='''''',A,'''''', KVAL='',I12, &
&        '', KOPT='',I4)')                        &
&        irep,cdclef,kval,kopt
inumer=jpniil
CALL faipar_fort                                       &
&               (fa, inumer,inimes,irep,llfata,clmess, &
&                clnspr,clnspr,.false.)
!
IF (lhook) CALL dr_hook('FAREGI_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE faregi_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE faregi64            &
&           (cdclef, kval, kopt)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
CHARACTER (LEN=*)      CDCLEF                                 ! IN   
INTEGER (KIND=JPLIKB)  KVAL                                   ! INOUT
INTEGER (KIND=JPLIKB)  KOPT                                   ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faregi_fort                   &
&           (fa, cdclef, kval, kopt)

END SUBROUTINE faregi64

SUBROUTINE faregi              &
&           (cdclef, kval, kopt)
USE fa_mod, ONLY : fa => fa_com_default, &
&                  fa_com_default_init,  &
&                  new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
CHARACTER (LEN=*)      CDCLEF                                 ! IN   
INTEGER (KIND=JPLIKM)  KVAL                                   ! INOUT
INTEGER (KIND=JPLIKM)  KOPT                                   ! IN   

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faregi_mt                     &
&           (fa, cdclef, kval, kopt)

END SUBROUTINE faregi

SUBROUTINE faregi_mt               &
&           (fa, cdclef, kval, kopt)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
CHARACTER (LEN=*)      CDCLEF                                 ! IN   
INTEGER (KIND=JPLIKM)  KVAL                                   ! INOUT
INTEGER (KIND=JPLIKM)  KOPT                                   ! IN   
! Local integers
INTEGER (KIND=JPLIKB)  IVAL                                   ! INOUT
INTEGER (KIND=JPLIKB)  IOPT                                   ! IN   
! Convert arguments

IF (kopt==1) THEN
  ival       = int(      kval, jplikb)
ENDIF
iopt       = int(      kopt, jplikb)

CALL faregi_fort                   &
&           (fa, cdclef, ival, iopt)

IF (kopt==0) THEN
  kval       = int(      ival, jplikm)
ENDIF

END SUBROUTINE faregi_mt

!INTF CDCLEF        IN                                                                 
!INTF KVAL          INOUT IN_IF=KOPT==1                  OUT_IF=KOPT==0                
!INTF KOPT          IN