facgra.F90

Go to the documentation of this file.

SUBROUTINE facgra_fort                                              &
&                     (fa,  krep,   krang,  cdpref, knivau, cdsuff, &
&                      pchamp, ldcosp, kvalco, klongd,              &
&                      ldundf, pundf)
USE fa_mod, ONLY : fa_com, jpniil, facadr, fafich,                  &
                 & ngrib2_glo_sh, ngrib2_glo_gp, ngrib2_lam_gp,     &
                 & ngrib2_lam_bf, ngrib2_latlon, ngrib1_latlon,     &
                 & nundef
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
USE grib_api_interface
USE grib_api
IMPLICIT NONE
!****
!      Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!      PREPARATION (codage GRIB_API) d'un CHAMP HORIZONTAL
!      destine a etre ecrit sur un fichier ARPEGE/ALADIN.
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KRANG  (Entree) ==> Rang de l'unite logique;
!                CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
!                KNIVAU (Entree) ==> Niveau vertical eventuel;
!                CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
!    ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
!                LDCOSP (Entree) ==> Vrai si le champ est represente
!                                    par des coefficients spectraux;
!    ( Tableau ) KVALCO (Sortie) ==> Donnees destinees a l'ecriture;
!                KLONGD (Entree/Sortie) 
!                                ==> Nombre de mots a ecrire;
!*
!
TYPE(fa_com)   :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG, KNIVAU, KLONGD, ILONGD
!
INTEGER (KIND=JPLIKB) KVALCO(*)
REAL (KIND=JPDBLR), TARGET :: PCHAMP(*)
REAL (KIND=JPDBLR) PUNDF, ZUNDF
!
LOGICAL LDCOSP, LDUNDF, LLFATA
!
CHARACTER CDPREF*(*), CDSUFF*(*)
!
CHARACTER(LEN=FA%JPXNOM)   CLACTI 
CHARACTER(LEN=FA%JPLSPX)   CLNSPR
CHARACTER(LEN=FA%JPLMES)   CLMESS 
INTEGER (KIND=JPLIKB) :: INIMES, INUMER
CHARACTER, ALLOCATABLE :: CLGRIB (:)
INTEGER (KIND=JPKSIZE_T) :: ILGRIB
INTEGER (KIND=JPLIKM) :: IRET, IGRIBH
INTEGER (KIND=JPLIKB) :: INGRIB, INBITS

!
REAL (KIND=JPRB) :: ZHOOK_HANDLE

IF (lhook) CALL dr_hook('FACGRA_MT',0,zhook_handle)

krep = 0

CALL facgrm_fort (fa, krep, krang, cdpref, knivau, cdsuff, pchamp, &
                & ldcosp, igribh, ldundf, pundf, 1_jplikb)

IF (krep /= 0) GOTO 1001

CALL igrib_get_value (igribh, 'INGRIB', ingrib)
CALL igrib_get_value (igribh, 'INBITS', inbits)

CALL igrib_get_message_size (igribh, ilgrib)

ALLOCATE (clgrib(ilgrib))
CALL grib_copy_message (igribh, clgrib, status=iret)

IF (iret == grib_success) THEN
  ilongd = 3+(ilgrib+jplikb-1)/jplikb
  kvalco(1) = ingrib
  IF (ldcosp) THEN
    kvalco(2) = 1
  ELSE
    kvalco(2) = 0
  ENDIF
  kvalco(3) = inbits
  IF ((klongd < ilongd) .AND. (klongd > 0)) THEN
    krep=-130
    GOTO 1001
  ELSE
    klongd = ilongd
  ENDIF
  kvalco(4:ilongd) = transfer(clgrib, kvalco(4:ilongd))
ELSE
  krep = iret-1000
  RETURN
ENDIF

DEALLOCATE (clgrib)

CALL igrib_release (igribh)

1001 CONTINUE
!
llfata=llmoer(krep,krang)
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACGRA'
  inumer=jpniil
!
  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I4,  &
&         '', CDPREF='''''',A,'''''', KNIVAU='',I6,       &
&         '', CDSUFF='''''',A,'''''', LDCOSP= '',L1,      &
&         '', KLONGD='',I10,'' < '',I10)')                &
&     krep, krang, cdpref(1:len_trim(cdpref)), knivau,    &
&     cdsuff(1:len_trim(cdsuff)), ldcosp, klongd, ilongd

  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
ENDIF

IF (lhook) CALL dr_hook('FACGRA_MT',1,zhook_handle)
!
CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE