fadecx.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE fadecx_fort                                          &
&                     (fa, krep, krang, cdnoma, kvalco, klonga, &
&                      pchamp, ldcosp, cdpref, knivau, cdsuff,  &
&                      ldundf, pundf, ydgr1tab)
USE fa_mod, ONLY : fa_com, jpniil, fagr1tab
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!      Controle de coherence et decodage (GRIBEX) d'un CHAMP
!      HORIZONTAL venant d'etre lu sur un fichier ARPEGE/ALADIN.
!       ( DECodage d'un champ gribeX )
!**
!    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
!*
!  MODIFICATION :
!         JM AUDOIN  15/05/2007  Partie 3.1  Blindage controle changement unite
!
!
!
TYPE(fa_com)   :: FA
TYPE(fagr1tab) :: YDGR1TAB
INTEGER (KIND=JPLIKB) KREP, KRANG, KLONGA, KNIVAU
!
INTEGER (KIND=JPLIKB), TARGET :: KVALCO(klonga)
REAL (KIND=JPDBLR) PCHAMP(*)
INTEGER (KIND=JPLIKB), POINTER :: IVALCO (:)
!
REAL (KIND=JPDBLR) PUNDF
!
LOGICAL LDCOSP, LDUNDF, LLUNDF, LLSWAP
!
CHARACTER CDNOMA*(*), CDPREF*(*), CDSUFF*(*)
!
#include "fagribex.h"
!
REAL (KIND=JPDBLR) ZSEC2(10+2*(fa%jpxniv+1)), ZSEC3(2)
REAL (KIND=JPDBLR), ALLOCATABLE ::  ZSEC4(:), ZCHAMP(:)
REAL (KIND=JPDBLR) ZUNDF
REAL (KIND=JPDBLR) ZPULAP
!
INTEGER (KIND=JPLIKB) ISEC0(2), ISEC1(fa%jpsec1)
INTEGER (KIND=JPLIKB) ISEC2(fa%jpsec2), ISEC3(2)
INTEGER (KIND=JPLIKB) ISEC4(fa%jpsec4)
INTEGER (KIND=JPLIKB) ILCHAM, ISTRIA, IDECAL
INTEGER (KIND=JPLIKB) IPOFIN, ILONSEC2
INTEGER (KIND=JPLIKB) ITRONC, IIND, ILOW, IHIGH
INTEGER (KIND=JPLIKB) IL, IADD, IRANGC, IILCHAM
INTEGER (KIND=JPLIKB) INIMES
INTEGER (KIND=JPLIKB) IVALC3, IVALC4, IVALC5, IWORD
INTEGER (KIND=JPLIKB) INUMER, ILENG, IRET, IDX
INTEGER (KIND=JPLIKB) JN, JM, JLAT, JLON, J
INTEGER (KIND=JPLIKB) IFAORI, IFAMOD 
INTEGER (KIND=JPLIKB) INIPAR (8)
!
LOGICAL LLMLAM, LLCOSP
!
CHARACTER(LEN=1) CLOPER
CHARACTER(LEN=8) CLGRIB
!
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA
type(fagr1tab)          ylgr1tab

!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FADECX_MT',0,zhook_handle)
krep=0
IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
  krep=-66
  GOTO 1001
ENDIF
!
inumer=fa%FICHIER(krang)%NULOGI
!
cloper='D'
istria=0
!**
!     2.  -  CONTROLE DES DONNEES DE L'ARTICLE
!-----------------------------------------------------------------------
!
IF (kvalco(1).NE.3.OR.                         &
&    kvalco(2).LT.0.OR.kvalco(2).GT.1.OR.      &
&    (kvalco(2).EQ.1.AND.kvalco(4).LT.0)) 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
!
irangc=fa%FICHIER(krang)%NUCADR
llmlam=fa%CADRE(irangc)%LIMLAM
itronc=fa%CADRE(irangc)%MTRONC
!
IF (ldcosp) THEN
  IF (llmlam) THEN
    ilcham=fa%CADRE(irangc)%NSFLAM
    ilonsec2=21+itronc
  ELSE    
    ilcham=(1+itronc)*(2+itronc)
    ilonsec2=22
  ENDIF   
ELSE
  ilcham=fa%CADRE(irangc)%NVAPDG
  IF (llmlam) THEN
    ilonsec2=22
  ELSE
    ilonsec2=22+fa%CADRE(irangc)%NLATIT
  ENDIF
ENDIF
!
ALLOCATE (zchamp(ilcham), zsec4(ilcham))
!
!**
!     3.  -  DECODAGE GRIBEX DES DONNEES DE L'ARTICLE
!-----------------------------------------------------------------------
!
idecal=3
ivalc3=kvalco(3)
IF (ldcosp) THEN
  idecal=idecal+2
! IVALC4=ss-tronc non compactee
! IVALC5=puissance de laplacien
  ivalc4=kvalco(4)
  ivalc5=kvalco(5)
ENDIF

iilcham=ilcham
!
! Pour Aladin, le calcul du nb de coeff spectraux qui ont
! ete compactes est plus complexe (certains ont ete retires
! pour ne pas etre compactes: ss-tronc triangulaire).
!
IF (ldcosp.AND.llmlam) THEN
  istria=4*(1+fa%CADRE(irangc)%NOZPAR(1)+fa%CADRE(irangc)%NOZPAR(2)+ &
&            ivalc4*(ivalc4-1)/2)
  iilcham=ilcham-istria
ENDIF

! C'est un champ GRIB, mais les octets ont peut-etre ete 
! inverses s'il a ete produit sur une architecture differente
! On cherche donc a deviner s'il faut les inverser a nouveau,
! et on inverse le cas echeant

clgrib=transfer(kvalco(idecal+1), clgrib)
llswap = (clgrib(1:4) /= 'GRIB') .AND. (clgrib(5:8) == 'BIRG')
IF (llswap) THEN
  ALLOCATE (ivalco(klonga))
  CALL jswap (ivalco(idecal+1), kvalco(idecal+1), 8_jplikm, int(klonga-idecal, jplikm))
ELSE
  ivalco => kvalco
ENDIF

! ILENG=longueur disponible en entiers declares INTEGER dans KVALCO.
ileng=2*(klonga-idecal)
!
!     3.1 -  APPEL A GRIBEX
!
iword=0
iret=-1

CALL fagribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4,          &
&             pchamp,iilcham,ivalco(idecal+1:klonga),ileng,iword, &
&             cloper,iret)

IF (llswap) THEN
  DEALLOCATE (ivalco)
  NULLIFY (ivalco)
ENDIF

IF (fa%LFAMOP) THEN
  WRITE (unit=fa%NULOUT,fmt=*)                          &
&         ' FADECX: KLONGA, IDECAL, ILENG, IILCHAM = ', &
&         klonga, idecal, ileng, iilcham
  WRITE (unit=fa%NULOUT,fmt=*) '       * ISEC0 = ',isec0
  WRITE (unit=fa%NULOUT,fmt=*) '       * ISEC1 = ',isec1
  WRITE (unit=fa%NULOUT,fmt=*)                                    &
&                     '       * ILONSEC2 ! ISEC2(1:ILONSEC2) = ', &
&                     ilonsec2, ' ! ', isec2(1:ilonsec2)
  WRITE (unit=fa%NULOUT,fmt=*) '       * ZSEC2(1:2) = ',zsec2(1:2)
  IF (isec2(12).GT.0) WRITE (unit=fa%NULOUT,fmt=*)            &
&          '       * ISEC2(12) ! ZSEC2(11:10+ISEC2(12)) = ',  &
&                    isec2(12), ' ! ', zsec2(11:10+isec2(12))
  WRITE (unit=fa%NULOUT,fmt=*) '       * FA%JPSEC4 ! ISEC4 = ', &
&                               fa%JPSEC4,' ! ',isec4
ENDIF
!
!
IF (krep.NE.0) THEN
  GOTO 1001
ENDIF
!
!*
!     3.3 -  CONTROLES DE COHERENCE
!-----------------------------------------------------------------------
!

IF (iret.GT.0) THEN
! Erreur rapportee par GRIBEX
  krep=-1000-iret
  WRITE (unit=fa%NULOUT,fmt=*) ' FADECX: IRET, KREP = ',iret, krep 
  GOTO 1001
ELSEIF (iret.LT.0 .AND. ((iret /= -4) .OR. .NOT. ldundf)) THEN ! -4 = "A bitmap was encountered"
! Warning rapporte par GRIBEX
  WRITE (unit=fa%NULOUT,fmt=*)
  WRITE (unit=fa%NULOUT,fmt=*)                         &
&         '!------------------------------------------'
  WRITE (unit=fa%NULOUT,fmt=*)                         &
&         '!           FADECX:   WARNING !!!         !'
  WRITE (unit=fa%NULOUT,fmt=*)                         &
&         '!------------------------------------------'
  WRITE (unit=fa%NULOUT,fmt=*) ' Code retour de GRIBEX = ', &
&        iret,' pour le champ: ',cdnoma
  WRITE (unit=fa%NULOUT,fmt=*)
ENDIF
IF (isec4(1).LT.iilcham) THEN
  krep=-93
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                                 &
&         'FADECX: ERREUR !!! Nbre de valeurs decodees = ',      &
&            isec4(1),' et nbre de valeurs attendues = ',iilcham
  ENDIF
  GOTO 1001
ELSEIF (isec4(1).GT.iilcham) THEN
  krep=-94
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                              &
&         'FADECX: ERREUR !!! Nbre de valeurs decodees = ',   &
&         isec4(1),' et nbre de valeurs attendues = ',iilcham
  ENDIF
  IF (llmoer(krep,krang)) GOTO 1001
ENDIF
!
IF (ivalc3.NE.isec4(2).AND.fa%LFAMOP) THEN
  WRITE (unit=fa%NULOUT,fmt=*)                                    &
&     ' FADECX: WARNING, le nb de bits de codage qui avait',      &
&     ' ete demande ( ',ivalc3,' ) est different de celui qui a', &
&          ' ete finalement retenu ( ',isec4(2),' ) par GRIBEX.'
  WRITE (unit=fa%NULOUT,fmt=*)                       &
&         ' => Gain de place sans perte de precision'
ENDIF
!
!  Dans le cas d'un champ spectral ARPEGE
!
IF (ldcosp.AND..NOT.llmlam.AND.(isec4(18).NE.ivalc4 &
&    .OR.isec4(17).NE.ivalc5)) THEN                  
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                              &
&            'Ss-tronc non compactee dans GRIB = ',isec4(18), &
&            ' et on attend: ',ivalc4
    WRITE (unit=fa%NULOUT,fmt=*)                              &
&            'Puissance de laplacien dans GRIB = ',isec4(17), &
&            ' et on attend: ',ivalc5
  ENDIF
  krep=-95
  GOTO 1001
ENDIF
!
! Controle de l'adequation entre le nb de mots lus par LFI et le detail:
! ( enrobage FA + message GRIBEX + eventuelles valeurs non-compactees ).
!
iword=1+(isec0(1)-1)/jplikb
IF (fa%LFAMOP) THEN
  WRITE (unit=fa%NULOUT,fmt=*) ' FADECX: IWORD = ',iword
ENDIF
ipofin=idecal+iword
IF (ldcosp) THEN
  IF (llmlam) THEN
    ipofin=ipofin+istria
  ELSE
    ipofin=ipofin+(1+ivalc4)*(2+ivalc4)
  ENDIF
ENDIF
!
IF (klonga.LT.ipofin) THEN
  krep=-93
  GOTO 1001
ELSEIF (klonga.GT.ipofin) THEN
  krep=-94
  IF (llmoer(krep,krang)) GOTO 1001
ENDIF
!*
!     3.2 -  DEMODULATION DES COEFF. SPEC. ALADIN QUI ONT ETE COMPACTES
!-----------------------------------------------------------------------
!
IF (ldcosp.AND.llmlam) THEN
!  Transfert des donnees decodees et modulees entieres en nombres reels
!  pour les demoduler. Comme PCHAMP est a profil implicite, on ne peut
!  s'en servir pour la fonction TRANSFER => il faut passer par ICHAMP!
  zsec4(1:iilcham) = pchamp(1:iilcham)
  zchamp=0._jpdblr
  zpulap=REAL(IVALC5,JPDBLR) * (-0.001_jpdblr)
  iind=0
  DO jm=1,fa%CADRE(irangc)%NOMPAR(2)
    ilow=2+2*jm+1
    iadd=4*max(ivalc4+1-jm,1_jplikb )
!
    DO idx=fa%CADRE(irangc)%NOMPAR(ilow)+iadd,fa%CADRE(irangc)%NOMPAR(ilow+1)
      iind=iind+1        
      jn=(idx-fa%CADRE(irangc)%NOMPAR(ilow))/4
      zchamp(idx)=zsec4(iind) *                 &
&           ((REAL(jn**2+jm**2,jpdblr))**zpulap)
    ENDDO
  ENDDO
!  Transfert des donnees decodees et demodulees reelles en nombres entiers
!  disposes aux bons endroits du tableau definitif.
  pchamp(1:ilcham) = zchamp(1:ilcham)
ENDIF
!*
!     3.3 -  TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES.
!-----------------------------------------------------------------------
!        (et non fournis par GRIBEX) stockes en fin d'article.
!
IF (ldcosp) THEN
  IF (llmlam) THEN
    iind=0
    DO jm=0,fa%CADRE(irangc)%NOMPAR(2)
      il=2+2*jm+1
      ilow=fa%CADRE(irangc)%NOMPAR(il)
!
      IF (jm.EQ.0) THEN
        ihigh=fa%CADRE(irangc)%NOMPAR(il+1)
      ELSE
        ihigh=ilow+4*(ivalc4+1-jm)-1
        IF (ihigh.LE.ilow) ihigh=ilow+3
      ENDIF
!
      DO idx=ilow,ihigh
        iind=iind+1
        pchamp(idx)=transfer(kvalco(idecal+iword+iind), pchamp(idx))
      ENDDO
    ENDDO
  ELSE
!
! Cas ARPEGE
!
    pchamp(1:2*(ivalc4+1))=                              &
&        transfer(kvalco(idecal+iword+1:idecal+iword+2*(ivalc4+1)), pchamp(1:2*(ivalc4+1)))
    iind=2*(ivalc4+1)-1
    idx=2*(itronc+1)-1
    DO jm=1,ivalc4
    DO jn=jm,itronc
      idx=idx+2
      IF (jn.LE.ivalc4) THEN
        iind=iind+2
        pchamp(idx) = transfer(kvalco(idecal+iword+iind), pchamp(idx))
        pchamp(idx+1) = transfer(kvalco(idecal+iword+iind+1), pchamp(idx+1))
      ENDIF
    ENDDO
    ENDDO
!
  ENDIF
ENDIF
!*
!     3.4 - Renversement des valeurs en pts de grille des champs
!            lat-lon afin de les ranger Sud-Nord plutot que Nord-Sud
!            (on conserve le rangt W-E consecutif) a l'image du rangt
!            initial effectue par FullPos.
!-----------------------------------------------------------------------
!
IF ((isec2(1)==0.OR.isec2(1)==10.OR.isec2(1)==20.OR. &
&    isec2(1)==30) .AND. .NOT.ldcosp) THEN
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                              &
&            ' FADECX: Grille LAT-LON issue BDAP -> ',        &
&            ' renversement des valeurs pour etre rangees SN'
  ENDIF
  DO jlat=1,fa%CADRE(irangc)%NLATIT
  DO jlon=1,fa%CADRE(irangc)%NXLOPA
    jn=jlon+fa%CADRE(irangc)%NXLOPA*(jlat-1)
    idx=jlon+fa%CADRE(irangc)%NXLOPA*(fa%CADRE(irangc)%NLATIT-jlat)
    zchamp(idx) = pchamp(jn)
  ENDDO
  ENDDO
  pchamp(1:ilcham) = zchamp(1:ilcham)
ENDIF

!
!            CHANGEMENT D'UNITE DE CERTAINS CHAMPS.
!            Il s'agit de champs dont les valeurs sont comprises
!            entre 0 et 1 dans le modele mais dont l'unite
!            conventionnelle dans le GRIB est le %.
!
CALL faipag_fort                                                    &
&               (fa,  krep, inumer, cdpref, knivau, cdsuff, inipar, &
&                ylgr1tab)
!
! Traitement des valeurs indefinies
!
llundf = isec1(5) == 192
IF (llundf) THEN
  zundf = zsec3(2)
ELSE
  zundf = 0._jpdblr
ENDIF
!
! Facteur d'echelle eventuel
!
IF (ylgr1tab%LMULTI) THEN
  pchamp(1:ilcham) = pchamp(1:ilcham) / ylgr1tab%FMULTI
  zundf             = zundf             / ylgr1tab%FMULTI
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='FADECX'
!
  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('FADECX_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE fadecx_fort

!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                                                              
!INTF YDGR1TAB        OUT