faveur.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE faveur_fort                                             &
&                     (fa,  krep, knumer, kngrib, knarg1, knarg2,  &
&                      knarg3, knarg4, knarg5)
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!        Ce sous-programme permet d'obtenir, pour un fichier ARPEGE
!     ouvert, les options courantes liees au codage GRIB des champs.
!     CES OPTIONS NE SONT UTILISEES QUE POUR (RE)ECRIRE DES CHAMPS
!     codes en GRIB.
!       ( Visualisation (?) options Effectives pour l'UtilisateuR )
!**
!     Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                 KNUMER (Entree) ==> Numero d'Unite Logique concernee;
!                 KNGRIB (Sortie) ==> Niveau de codage GRIB (-1,0,1,2,3,4);
!
!               * Pour KNGRIB compris entre -1 et 3, les arguments 
!                 de sortie ont la signification suivante:
!                 KNARG1 (Sortie) ==> Nombre de bits par valeur point-de-grille;
!                 KNARG2 (Sortie) ==> Nombre de bits par partie reelle/imaginaire
!                                     de coefficient spectral;
!                 KNARG3 (Sortie) ==> Sous-troncature non compactee;
!                 KNARG4 (Sortie) ==> Puissance de laplacien;
!                 KNARG5 (Sortie) ==> Degre de modulation de KNARG4.
!
!               * Pour KNGRIB==4, les arguments de sortie ont la 
!                 signification suivante:
!                 
!                 KNARG1 (Sortie) ==> Taille de la couronne a conserver
!                 KNARG2 (Sortie) ==> Nombre de bits utilises pour le codage
!                 KNARG3 (Sortie) ==> Inutilise
!                 KNARG4 (Sortie) ==> Inutilise
!                 KNARG5 (Sortie) ==> Inutilise
!
!
!
TYPE(fa_com) :: FA
INTEGER (KIND=JPLIKB) KREP, KNUMER, KNGRIB
INTEGER (KIND=JPLIKB) KNARG1, KNARG2, KNARG3, KNARG4
INTEGER (KIND=JPLIKB) KNARG5
!
INTEGER (KIND=JPLIKB) IREP, IRANG, INIMES
!
LOGICAL LLVERF
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA

!**
!     1.  -  INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FAVEUR_MT',0,zhook_handle)
clacti=''
llverf=.false.
CALL fanumu_fort                 &
&               (fa, knumer,irang)
!
IF (irang.EQ.0) THEN
  irep=-51
  GOTO 1001
ENDIF
!
!         Verrouillage eventuel du fichier.
!
IF (fa%LFAMUL) CALL lfiver_fort                               &
&                              (fa%LFI, fa%FICHIER(irang)%VRFICH,'ON')
llverf=fa%LFAMUL
!**
!     2.  -  RECOPIE DES VALEURS EN COMMON DANS LES ARGUMENTS.
!-----------------------------------------------------------------------
!
kngrib=fa%FICHIER(irang)%NFGRIB

IF (kngrib /= 4) THEN
  knarg1=fa%FICHIER(irang)%NBFPDG
  knarg2=fa%FICHIER(irang)%NBFCSP
  knarg3=fa%FICHIER(irang)%NSTROF
  knarg4=fa%FICHIER(irang)%NPUFLA
  knarg5=fa%FICHIER(irang)%NMFDPL
ELSE
  knarg1=fa%FICHIER(irang)%NCPLSIZE
  knarg2=fa%FICHIER(irang)%NCPLBITS
  knarg3=0
  knarg4=0
  knarg5=0
ENDIF
irep=0
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
krep=irep
llfata=llmoer(irep,irang)
!
!        Deverrouillage eventuel du fichier.
!
IF (llverf) CALL lfiver_fort                                &
&                           (fa%LFI, fa%FICHIER(irang)%VRFICH,'OFF')
!
IF (llfata) THEN
  inimes=2
ELSE
  inimes=ixnvms(irang)
ENDIF
!
IF (.NOT.llfata.AND.inimes.NE.2)  THEN 
  IF (lhook) CALL dr_hook('FAVEUR_MT',1,zhook_handle)
  RETURN
ENDIF
!
clnspr='FAVEUR'
!
WRITE (unit=clmess,fmt='(''KREP='',I4,'', KNUMER='',I3,      &
&       '', KNGRIB='',I2,'', KNARG1='',I3,'', KNARG2='',I3,   &
&       '', KNARG3='',I2,'', KNARG4='',I3,'', KNARG5='',I3)') &
&   krep,knumer,kngrib,knarg1,knarg2,knarg3,knarg4,knarg5
CALL faipar_fort                                     &
&               (fa, knumer,inimes,irep,llfata,clmess, &
&                clnspr,clacti,.false.)
!
IF (lhook) CALL dr_hook('FAVEUR_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"
#include "facom2.ixnvms.h"

END SUBROUTINE faveur_fort



! Oct-2012 P. Marguinaud 64b LFI
SUBROUTINE faveur64                                      &
&           (krep, knumer, kngrib, knarg1, knarg2, knarg3, &
&           knarg4, knarg5)
USE fa_mod, ONLY : fa => fa_com_default, &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKB)  KREP                                   !   OUT
INTEGER (KIND=JPLIKB)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  KNGRIB                                 !   OUT
INTEGER (KIND=JPLIKB)  KNARG1                                 !   OUT
INTEGER (KIND=JPLIKB)  KNARG2                                 !   OUT
INTEGER (KIND=JPLIKB)  KNARG3                                 !   OUT
INTEGER (KIND=JPLIKB)  KNARG4                                 !   OUT
INTEGER (KIND=JPLIKB)  KNARG5                                 !   OUT

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faveur_fort                                               &
&           (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
&           knarg4, knarg5)

END SUBROUTINE faveur64

SUBROUTINE faveur                                          &
&           (krep, knumer, kngrib, knarg1, knarg2, knarg3, &
&           knarg4, knarg5)
USE fa_mod, ONLY : fa => fa_com_default,  &
&                   fa_com_default_init,  &
&                   new_fa_default
USE lfi_precision
IMPLICIT NONE
! Arguments
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNGRIB                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG1                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG2                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG3                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG4                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG5                                 !   OUT

IF (.NOT. fa_com_default_init) CALL new_fa_default ()

CALL faveur_mt                                                 &
&           (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
&           knarg4, knarg5)

END SUBROUTINE faveur

SUBROUTINE faveur_mt                                           &
&           (fa, krep, knumer, kngrib, knarg1, knarg2, knarg3, &
&           knarg4, knarg5)
USE fa_mod, ONLY : fa_com
USE lfi_precision
IMPLICIT NONE
! Arguments
type(fa_com)          fa                                     ! INOUT
INTEGER (KIND=JPLIKM)  KREP                                   !   OUT
INTEGER (KIND=JPLIKM)  KNUMER                                 ! IN   
INTEGER (KIND=JPLIKM)  KNGRIB                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG1                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG2                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG3                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG4                                 !   OUT
INTEGER (KIND=JPLIKM)  KNARG5                                 !   OUT
! Local integers
INTEGER (KIND=JPLIKB)  IREP                                   !   OUT
INTEGER (KIND=JPLIKB)  INUMER                                 ! IN   
INTEGER (KIND=JPLIKB)  INGRIB                                 !   OUT
INTEGER (KIND=JPLIKB)  INARG1                                 !   OUT
INTEGER (KIND=JPLIKB)  INARG2                                 !   OUT
INTEGER (KIND=JPLIKB)  INARG3                                 !   OUT
INTEGER (KIND=JPLIKB)  INARG4                                 !   OUT
INTEGER (KIND=JPLIKB)  INARG5                                 !   OUT
! Convert arguments

inumer     = int(    knumer, jplikb)

CALL faveur_fort                                               &
&           (fa, irep, inumer, ingrib, inarg1, inarg2, inarg3, &
&           inarg4, inarg5)

krep       = int(      irep, jplikm)
kngrib     = int(    ingrib, jplikm)
knarg1     = int(    inarg1, jplikm)
knarg2     = int(    inarg2, jplikm)
knarg3     = int(    inarg3, jplikm)
knarg4     = int(    inarg4, jplikm)
knarg5     = int(    inarg5, jplikm)

END SUBROUTINE faveur_mt

!INTF KREP            OUT 
!INTF KNUMER        IN    
!INTF KNGRIB          OUT 
!INTF KNARG1          OUT 
!INTF KNARG2          OUT 
!INTF KNARG3          OUT 
!INTF KNARG4          OUT 
!INTF KNARG5          OUT