fadgra.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fadgra_fort                                          &
&                     (fa, krep, krang, cdnoma, kvalco, klonga, &
&                      pchamp, ldcosp, cdpref, knivau, cdsuff,  &
&                      ldundf, pundf)
USE fa_mod, ONLY : fa_com, jpniil, fafich, facadr
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:
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                KRANG  (Entree) ==> Rang de l'unite logique;
!                CDNOMA (Entree) ==> Nom d'article (prefabrique);
!    ( Tableau ) KVALCO (Entree) ==> Donnees issues de la lecture;
!                KLONGA (Entree) ==> Nombre de mots lus;
!    ( Tableau ) PCHAMP (Sortie) ==> Valeurs REELLES du champ lu;
!                LDCOSP (Entree) ==> Vrai si le champ est represente
!                                    par des coefficients spectraux;
!                CDPREF (Entree) ==> Prefixe au sens FA
!                KNIVAU (Entree) ==> Niveau au sens FA
!                CDSUFF (Entree) ==> Suffixe au sens FA
!                LDUNDF (Entree) ==> Si ce champ a des valeurs indefinies
!                                    alors inserer PUNDF sur les points
!                                    manquants
!                PUNDF  (Entree) ==> Dans le cas ou LDUNDF est vrai,
!                                    valeur non definie a inserer dans le champ
!                LDUNDF (Sortie) ==> Vrai si ce champ a des valeurs 
!                                    indefinies
!                PUNDF  (Sortie) ==> Dans le cas ou LDUNDF est vrai (en sortie),
!                                    valeur non definie a inserer dans le champ
!
!
TYPE(fa_com)   :: FA
INTEGER (KIND=JPLIKB) KREP, KRANG, KLONGA, KNIVAU
!
INTEGER (KIND=JPLIKB), TARGET :: KVALCO(klonga)
REAL (KIND=JPDBLR) PCHAMP(*)
!
REAL (KIND=JPDBLR) PUNDF
!
LOGICAL LDCOSP, LDUNDF, LLUNDF, LLLTLN 
!
CHARACTER CDNOMA*(*), CDPREF*(*), CDSUFF*(*)
!
REAL (KIND=JPDBLR) ZUNDF
!
INTEGER (KIND=JPLIKB) ILCHAM
INTEGER (KIND=JPLIKB) ITRONC
INTEGER (KIND=JPLIKB) INIMES
INTEGER (KIND=JPLIKB) INUMER
!
LOGICAL LLMLAM, LLCOSP, LLMGLO
!
type(fafich), POINTER :: ylfich
type(facadr), POINTER :: ylcadr
!
CHARACTER, ALLOCATABLE :: CLGRIB (:)
!
REAL (KIND=JPDBLR), ALLOCATABLE :: ZCHAMP (:)
!
INTEGER (KIND=JPLIKB) ILGRIB, IRANGC
INTEGER (KIND=JPLIKB) JLAT, JLON, JN, IDX, J
INTEGER (KIND=JPLIKM) IGRIBH, IRET, IBITMAP, INDATV, IBTMP
CHARACTER(LEN=FA%JPLSPX)   CLNSPR
CHARACTER(LEN=FA%JPLMES)   CLMESS 
CHARACTER(LEN=FA%JPXNOM)   CLNOMU
!
INTEGER (KIND=JPLIKB)    IMULTM, IMULTE
LOGICAL                  LLFATA
REAL (KIND=JPDBLR)       ZMULTI
INTEGER                  IEDITION, IPARAM
LOGICAL                  LLLOCSEC, LLGRIB1

!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FADGRA_MT',0,zhook_handle)

krep = 0


ylfich => fa%FICHIER(krang)
irangc = ylfich%NUCADR
ylcadr => fa%CADRE(irangc)
!
llmlam = ylcadr%LIMLAM
llltln = ylcadr%SINLAT(2) < 0 .AND. llmlam
llmglo = (.NOT. llltln) .AND. (.NOT. llmlam)
!
llcosp = ldcosp
!
inumer=ylfich%NULOGI
!
!**
!     2.  -  CONTROLE DES DONNEES DE L'ARTICLE
!-----------------------------------------------------------------------
!
IF ((.NOT. falgra(kvalco(1))).OR.                     &
&   kvalco(2).LT.0.OR.kvalco(2).GT.1) THEN
  krep=-91
  GOTO 1001
ELSE
  llcosp=kvalco(2).EQ.1
ENDIF
!
IF ((llcosp.AND..NOT.ldcosp).OR.(.NOT.llcosp.AND.ldcosp)) THEN
  krep=-92
  GOTO 1001
ENDIF
!
IF (llcosp) THEN
  IF (llmlam) THEN
    ilcham = ylcadr%NSFLAM
  ELSE    
    ilcham =(1+ylcadr%MTRONC)*(2+ylcadr%MTRONC)
  ENDIF   
ELSE
  ilcham=ylcadr%NVAPDG
ENDIF
!
!**
!     3.  -  DECODAGE GRIB_API DES DONNEES DE L'ARTICLE
!-----------------------------------------------------------------------
!

ilgrib = (klonga-3)*8

ALLOCATE (clgrib(ilgrib))
clgrib = transfer(kvalco(4:klonga), clgrib)
CALL grib_new_from_message_char (igribh, clgrib, status=iret)
DEALLOCATE (clgrib)

CALL igrib_get_value (igribh, 'editionNumber', iedition)
llgrib1 = iedition == 1

IF (llgrib1) THEN
  CALL igrib_set_value (igribh, 'setLocalDefinition', 1)
  lllocsec = .false.
ELSE
! Scaling factor may be encoded in the message
  CALL igrib_is_defined (igribh, 'grib2LocalSectionNumber', lllocsec)
  IF (.NOT. lllocsec) THEN
    CALL igrib_set_value (igribh, 'grib2LocalSectionPresent', 1)
    CALL igrib_set_value (igribh, 'grib2LocalSectionNumber', 1)
  ENDIF
ENDIF

IF (.NOT. lllocsec) THEN
! Restore encoding parameters if needed
  IF (knivau > 0) THEN
    CALL stru (cdsuff, clnomu)
  ELSE
    CALL stru (cdnoma, clnomu)
  ENDIF
  CALL igrib_set_value (igribh, 'faFieldName', trim(clnomu))
ENDIF

IF (llgrib1) THEN
  CALL igrib_get_value (igribh, 'indicatorOfParameter', iparam)
ELSE
  CALL igrib_get_value (igribh, 'parameterNumber', iparam)
ENDIF

IF (iparam == 255) THEN
  WRITE (fa%NULOUT, '(" FADGRA: Field `",A,"'' is not &
       &declared in `faFieldName.def'' and has no encoded &
       &FMULTM and FMULTE")') trim(cdnoma)
ENDIF

CALL igrib_get_value (igribh, 'FMULTM', imultm)
CALL igrib_get_value (igribh, 'FMULTE', imulte)

zmulti = REAL (IMULTM, JPDBLR) * 10._JPDBLR ** IMULTE

CALL igrib_get_value (igribh, 'bitmapPresent', ibtmp)
IF (ibtmp == 0) THEN
! When there is not bitmap, numberOfDataPoints may be broken; in this case we
! use numberOfValues
  CALL igrib_get_value (igribh, 'numberOfValues', indatv) 
ELSE
! numberOfValues = number of non-missing values when a bitmap is present
  CALL igrib_get_value (igribh, 'numberOfDataPoints', indatv) 
ENDIF

! Basic check

IF (indatv < ilcham) THEN
  krep=-93
  GOTO 1001
ELSEIF (indatv > ilcham) THEN
  krep=-94
  GOTO 1001
ENDIF

IF (llltln) THEN

  ALLOCATE (zchamp(ilcham))
  CALL igrib_get_value (igribh, 'values', zchamp(1:ilcham))

  DO jlat = 1, ylcadr%NLATIT
    DO jlon = 1, ylcadr%NXLOPA
      jn  = jlon+ylcadr%NXLOPA*(jlat-1)
      idx = jlon+ylcadr%NXLOPA*(ylcadr%NLATIT-jlat)
      pchamp(jn) = zchamp(idx)
    ENDDO
  ENDDO

  DEALLOCATE (zchamp)

ELSE
  CALL igrib_get_value (igribh, 'values', pchamp(1:ilcham))
ENDIF

CALL igrib_get_value (igribh, 'bitmapPresent', ibitmap)
llundf = ibitmap /= 0

IF (llundf) THEN
  CALL igrib_get_value (igribh, 'missingValue',  zundf)
ENDIF

CALL igrib_release (igribh)

!
! Facteur d'echelle eventuel
!
IF (zmulti /= real(1._4, jpdblr)) THEN
  pchamp(1:ilcham) = pchamp(1:ilcham) / zmulti
  zundf             = zundf             / zmulti
ENDIF
!
IF (ldundf .AND. llundf) THEN
  DO j = 1, ilcham
    IF (pchamp(j) == zundf) THEN
      pchamp(j) = pundf
    ENDIF
  ENDDO
  zundf = pundf
ENDIF
!
ldundf = llundf
pundf  = zundf

!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
llfata=llmoer(krep,krang)
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FADGRA'
  inumer=ylfich%NULOGI
!
  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I4,  &
&         '', CDNOMA='''''',A,'''''', KLONGA= '',I8,      &
&         '', LDCOSP='',L1)')                             &
&     krep, krang, cdnoma, klonga, ldcosp
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,cdnoma,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FADGRA_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"
#include "falgra.h"

SUBROUTINE stru (CDS, CDU)
CHARACTER (LEN=*) :: CDS, CDU
INTEGER (KIND=JPLIKB) :: J

DO j = 1, len(cdu)
  cdu(j:j) = ' '
ENDDO

DO j = 1, len_trim(cds)
  IF (cds(j:j) == ' ') THEN
    cdu(j:j) = '_'
  ELSE
    cdu(j:j) = cds(j:j)
  ENDIF
ENDDO

END SUBROUTINE stru

END SUBROUTINE

!INTF KREP            OUT                                                              
!INTF KRANG         IN                                                                 
!INTF CDNOMA        IN                                                                 
!INTF KVALCO        IN    DIMS=*                         KIND=JPLIKB                   
!INTF KLONGA        IN                                                                 
!INTF PCHAMP          OUT DIMS=*                                                       
!INTF LDCOSP        IN                                                                 
!INTF LDUNDF          OUT                                                              
!INTF PUNDF           OUT