facodx.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE facodx_fort                                              &
&                     (fa,  krep,   krang,  cdpref, knivau, cdsuff, &
&                      psec4, ldcosp, kvalco, klongd,               &
&                      ldundf, pundf, ydgr1tab)
USE fa_mod, ONLY : fa_com, jpniil, nundef, fagr1tab
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
!      PREPARATION (codage GRIBEX) d'un CHAMP HORIZONTAL
!      destine a etre ecrit sur un fichier ARPEGE/ALADIN.
!       ( CODage d'un champ a l'aide de gribeX )
!**
!    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 ) PSEC4  (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 (Sortie) ==> Nombre de mots a ecrire;
!*
!       En mode multi-taches, il doit y avoir verrouillage du fichier
!     concerne avant l'appel au sous-programme.
!
!      Modifications
!      -------------
!         R. El Ouaraini : 03-Oct-06, introduire la nouvelle geometrie pour tester ERPK
!
!         JM AUDOIN  :  15 mai 2007 partie 5 changement unite 
!         R. El Khatib 22-May-2015 : Bypass errror message in case of underflows
!
!
!
TYPE(fa_com)   :: FA
TYPE(fagr1tab) :: YDGR1TAB
INTEGER (KIND=JPLIKB) KREP, KRANG, KNIVAU, KLONGD
!
INTEGER (KIND=JPLIKB) KVALCO(*)
REAL (KIND=JPDBLR) PSEC4(*), PUNDF, ZUNDF
!
LOGICAL LDCOSP, LDUNDF, LLUNDF
!
CHARACTER CDPREF*(*), CDSUFF*(*)
!
#include "fagribex.h"
!
REAL (KIND=JPDBLR), ALLOCATABLE :: ZSEC4(:)
INTEGER (KIND=JPLIKB), ALLOCATABLE :: IVALCO(:)
REAL (KIND=JPDBLR) :: ZMIN, ZA
REAL (KIND=JPDBLR) :: ZSEC2(10+2*(fa%jpxniv+1)), ZSEC3(2), ZPULAP
!
INTEGER (KIND=JPLIKB) ISEC0(2), ISEC1(fa%jpsec1)
INTEGER (KIND=JPLIKB) ISEC2(fa%jpsec2), ISEC3(2)
INTEGER (KIND=JPLIKB) ISEC4(fa%jpsec4), ILONSEC2
INTEGER (KIND=JPLIKB) ILENG, IWORD, IRET, JM, IPULAP
INTEGER (KIND=JPLIKB) ILCHAM, JN, IDECAL, ICPACK
INTEGER (KIND=JPLIKB) ITRONC, ILOW, IHIGH, IDIMNC, INBITS
INTEGER (KIND=JPLIKB) IL, IADD, IRANGC, IILCHAM, INIMES
INTEGER (KIND=JPLIKB) INUMER,  IDX, JLAT, JLON, IDECOPT
INTEGER (KIND=JPLIKB) IFAORI, IFAMOD, INBIMO
!
LOGICAL LLMLAM
!
CHARACTER(LEN=1) CLOPER
!
INTRINSIC len_trim
!
CHARACTER(LEN=FA%JPXNOM) CLACTI 
CHARACTER(LEN=FA%JPLMES) CLMESS 
CHARACTER(LEN=FA%JPLSPX) CLNSPR
LOGICAL                  LLFATA
LOGICAL                  LLFACDE

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

isec0 = 0
isec1 = 0
isec2 = 0
isec3 = 0
isec4 = 0
zsec2 = 0
zsec3 = 0

llundf = ldundf

clacti=''
IF (krang.LE.0.OR.krang.GT.fa%JPNXFA) THEN
  krep=-66
  GOTO 1001
ENDIF
icpack=fa%FICHIER(krang)%NSTROF
irangc=fa%FICHIER(krang)%NUCADR
llmlam=fa%CADRE(irangc)%LIMLAM
itronc=fa%CADRE(irangc)%MTRONC
!
IF (llmlam) THEN
  IF (ldcosp) THEN
    ilonsec2=21+fa%CADRE(irangc)%NOMPAR(2)
  ELSE
    ilonsec2=22
  ENDIF
ELSE
  IF (ldcosp) THEN
    ilonsec2=22
  ELSE
    ilonsec2=22+fa%CADRE(irangc)%NLATIT
  ENDIF
ENDIF
!
kvalco(1)=fa%FICHIER(krang)%NFGRIB
idecal=3
IF (ldcosp) THEN
  IF (llmlam) THEN
    ilcham=fa%CADRE(irangc)%NSFLAM
  ELSE
    ilcham=(1+itronc)*(2+itronc)
  ENDIF
  kvalco(2)=1
  inbits=fa%FICHIER(krang)%NBFCSP 
  idecal=idecal+2
ELSE
  ilcham=fa%CADRE(irangc)%NVAPDG
  kvalco(2)=0
  inbits=fa%FICHIER(krang)%NBFPDG
ENDIF
kvalco(3)=inbits
iilcham = ilcham
idecopt = 0
llfacde = fa%FICHIER(krang)%NCOGRIF(11) /= 0
!**
!     2.  -  PREPARATION DU TABLEAU DE DONNEES A ECRIRE SUR LE FICHIER.
!-----------------------------------------------------------------------
!
ALLOCATE (zsec4(ilcham))
!
IF (ldcosp .AND. llmlam) THEN
!
!       Champ ALADIN en coefficients spectraux... traitement particulier,
!     car non prevu dans GRIBEX (il y sera considere comme un champ lat-lon)
!     mais on a la possibilite de compacter une (pseudo-)puissance de
!     laplacien du champ a la place du champ, de maniere a augmenter
!     la precision du champ en "aplanissant" le spectre.
!
!     Determination de la puissance de Laplacien (en 1/1000 ieme)
!
  CALL fapula_fort                                 &
&                 (fa,  krep, krang, psec4, ipulap )
  zpulap=REAL(ipulap,jpdblr)/1000._JPDBLR
!       ZPULAP=0.
!       IPULAP=0
  IF (fa%LFAMOP) THEN
    print *,'FACODX: puissance de laplacien selectionee ',zpulap, &
&          ' pour une sous-tronc de ',icpack
  ENDIF
  IF (krep.NE.0) GOTO 1001
!
! Transfert des coeff spectraux devant etre compactes de PSEC4 a ZSEC4
! avec prise en compte du coefficient (n**2+m**2)**zpulap. Les coefficients
! concernes sont ceux inclus dans le quart de l'ellipse, hors axes (coeff
! nuls), et hors du triangle non-compacte (sous-troncature).
  iilcham=0
!
  DO jm=1,fa%CADRE(irangc)%NOMPAR(2)
    ilow=2+2*jm+1
    iadd=4* max(icpack+1-jm,1_jplikb )
!
    DO idx=fa%CADRE(irangc)%NOMPAR(ilow)+iadd,fa%CADRE(irangc)%NOMPAR(ilow+1)
      iilcham=iilcham+1
      jn=(idx-fa%CADRE(irangc)%NOMPAR(ilow))/4
      zsec4(iilcham)=psec4(idx) *              &
&         ((REAL(jn**2+jm**2, jpdblr))**zpulap)
    ENDDO
  ENDDO

! Number of elements in sub-triangle+axes:IDIMNC
  idimnc=ilcham-iilcham
! Recherche de l'amplitude et du min du champ
  zmin = minval(zsec4(1:iilcham))
  za   = maxval(zsec4(1:iilcham)) - zmin
! Recherche du facteur decimal optimal pour utiliser
! au mieux les INBITS dans le codage de ce champ
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)'FACODX: traitement du champ: ', &
&          cdpref,knivau,cdsuff
  ENDIF
  krep = 0
  IF (llfacde) CALL facdec_fort (fa, krep, za, zmin, inbits, idecopt)
  IF (krep.NE.0) THEN
    krep = 0
  ENDIF
ELSEIF(ldcosp .AND. .NOT.llmlam) THEN
!
!          Transfert du tableau d'entree dans un tableau local
!     de maniere a eviter l'ecrasement du tableau d'entree par "GRIBEX".
!
  zsec4(1:iilcham) = psec4(1:iilcham)
  idimnc=(1+icpack)*(2+icpack)
ELSE
!
!    CHAMPS NON SPECTRAUX: transfert du tableau d'entree dans un
!    tableau local de maniere a eviter son ecrasement par "GRIBEX".
!
!
  idimnc=0
! Tester si Nouvelle ou ancienne geometrie Aladin
IF (fa%CADRE(irangc)%SINLAT(1) .GE. 0) THEN
  IF (llmlam .AND. fa%CADRE(irangc)%SINLAT(10).LT.0) THEN
!  Parametre de projection negatif, donc pas de projection:
!  Il s'agit d'une grille lat-lon reguliere du type Full-Pos
!  (pour champ ARPEGE ou Aladin). Il faut donc renverser
!  le champ afin de ranger Nord-Sud les valeurs plutot que Sud-Nord
!  (on conserve le rangt W-E consecutif).
!  Le but est de satisfaire la BDAP qui attend un rangt NW-->SE.
!
    IF (fa%LFAMOP) THEN
      WRITE (unit=fa%NULOUT,fmt=*)                              &
&              ' FACODX: Grille LAT-LON pour BDAP -> ',         &
&              ' renversement des valeurs pour etre rangees NS'
    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)
      zsec4(idx) = psec4(jn)
    ENDDO
    ENDDO
  ELSE
    zsec4(1:iilcham) = psec4(1:iilcham)
  ENDIF
ELSE
  IF (llmlam .AND. fa%CADRE(irangc)%SINLAT(2).LT.0) THEN
    IF (fa%LFAMOP) THEN
      WRITE (unit=fa%NULOUT,fmt=*)                              &
&              ' FACODX: Grille LAT-LON pour BDAP -> ',         &
&              ' renversement des valeurs pour etre rangees NS'
    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)
      zsec4(idx) = psec4(jn)
    ENDDO
    ENDDO
  ELSE
    zsec4(1:iilcham) = psec4(1:iilcham)
  ENDIF
ENDIF
! Recherche de l'amplitude et du min du champ
  zmin=zsec4(1)
  za=0._jpdblr
  zmin = minval(zsec4(1:iilcham))
  za   = maxval(zsec4(1:iilcham)) - zmin
! Recherche du facteur decimal optimal pour utiliser
! au mieux les INBITS dans le codage de ce champ
  IF (fa%LFAMOP) THEN 
  WRITE (unit=fa%NULOUT,fmt=*)'FACODX: traitement du champ: ', &
&          cdpref,knivau,cdsuff
  ENDIF
  krep = 0
  IF (llfacde) THEN
    IF (abs(za) <= epsilon(za)) THEN
!     On anticipe le retour d'erreur de facdec dans le cas ou le champs est quasi-constant
!     (cad : son amplitude est inferieur a la precision de la machine).
      idecopt = 0
      krep = 0
    ELSEIF (zmin /= 0_jpdblr .AND. abs(zmin) < epsilon(zmin)) THEN
!     On anticipe le retour d'erreur de facdec dans le cas ou le champ contient un "underflow"
      idecopt = 0
      krep = 0
    ELSE 
      CALL facdec_fort (fa, krep, za, zmin, inbits, idecopt)
      IF (krep.NE.0) THEN
        WRITE (unit=fa%NULOUT,fmt=*)'FACODX: field incriminated by FACDEC was ', cdpref,knivau,cdsuff
        idecopt = 0
        krep = 0
      ENDIF
    ENDIF
  ENDIF
ENDIF
!*
!     3.  -  INITIALISATION DE L'ENROBAGE GRIB
!-----------------------------------------------------------------------
!
!     3.1 -  Sections 1, 2, 3 et 4 (sf la partie reelle pour 4)
!
CALL fainig_fort                                                   &
&               (fa,  krep, krang, cdpref, knivau, cdsuff, ldcosp, &
&                iilcham, isec1, isec2, zsec2, isec3, zsec3, isec4,&
&                ydgr1tab)

IF (krep.NE.0) THEN
  GOTO 1001
ENDIF
! Prise en compte du facteur decimal
IF (llfacde .AND. isec1(23) == 0) THEN
  isec1(23) = idecopt
ENDIF
!
!     3.2 -  Definition du type de codage
!
cloper='C'
IF (fa%FICHIER(krang)%NCOGRIF(1)==1) cloper='K'
!*
!     4.  -  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 %.
!---------------------------------------------------------------
!
zundf = pundf
IF (ydgr1tab%LMULTI) THEN
  zsec4 = zsec4 * ydgr1tab%FMULTI
  zundf = zundf * ydgr1tab%FMULTI
ENDIF
!
! Traitement des valeurs indefinies; on verifie d'abord que le champ
! contient de telles valeurs afin d'eviter de polluer le resultat
! final avec un bitmap inutile
!
IF (llundf) THEN
  llundf = any(zsec4 == zundf)
ENDIF
!
! Ajustement des parametres d'encodage
!
IF (llundf) THEN
  isec1(5)=192
  zsec3(2)=zundf
  isec3(1)=0
  isec3(2)=int(zundf)
ENDIF
!*
!     5.  -  CODAGE GRIB PROPREMENT DIT
!-----------------------------------------------------------------------
!
iret=-1
! ILENG=longueur disponible en nb d'"entiers declares INTEGER" dans KVALCO.
! On part de l'hypothese ou le dimensionnement de KVALCO se fait
! dans la routine appelante a ILCHAM+2 (cas de l'absence de compactage).
ileng=(kind(kvalco)/4)*(ilcham+2-idecal)
iword=0
!DP
!DP  TEST AVEC UNE PUISSANCE DE LAPLACIEN IMPOSEE
!DP
!DP   CALL GRSMKP(0)
!DP ISEC4(17) = 2000
!DP
IF (fa%LFAMOP) THEN
  WRITE (unit=fa%NULOUT,fmt=*)' FACODX: CLOPER = ',cloper
  WRITE (unit=fa%NULOUT,fmt=*)                                     &
&                    ' FACODX: IILCHAM, ILCHAM, IDECAL, ILENG = ', &
&                    iilcham, ilcham, idecal, ileng
  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
  WRITE (unit=fa%NULOUT,fmt=*)'       * ZSEC4(1:20) = ', &
&                              zsec4(1:20)
ENDIF

!     WARNING GRIBEX ENLEVE 
!CALL GRSDBG (0)
!CALL GRSVCK (0)

! Defauts

!CALL GRSX2O (1)
!CALL GRSN2O (1)

! Defaults FA

!IF (FA%IOPTGRSX2O /= NUNDEF) &
!& CALL GRSX2O(INT (FA%IOPTGRSX2O, JPLIKM))
!
!IF (FA%IOPTGRSN2O /= NUNDEF) &
!& CALL GRSN2O(INT (FA%IOPTGRSN2O, JPLIKB))

! Defauts pour cette unite

!IF (FA%FICHIER(KRANG)%IOPTGRSX2O /= NUNDEF) &
!& CALL GRSX2O(INT (FA%FICHIER(KRANG)%IOPTGRSX2O, JPLIKM))
!
!IF (FA%FICHIER(KRANG)%IOPTGRSN2O /= NUNDEF) &
!& CALL GRSN2O(INT (FA%FICHIER(KRANG)%IOPTGRSN2O, JPLIKB))

!  1/ On force GRIBEX a calculer la puissance de laplacien
!CALL GRSMKP(1)
!  2/ On retire l'arrondi du message GRIB a un multiple de 120 octets
!CALL GRSRND(0)

CALL fagribex(isec0,isec1,isec2,zsec2,isec3,zsec3,isec4,  &
&             zsec4,iilcham,kvalco(idecal+1),ileng,iword, &
&             cloper,iret)
!
IF (iret.GT.0) THEN
! Erreur rapportee par GRIBEX
  krep=-1000-iret
  GOTO 1001
ELSEIF (iret.LT.0) THEN
! Warning rapporte par GRIBEX
  WRITE (unit=fa%NULOUT,fmt=*)
  WRITE (unit=fa%NULOUT,fmt=*)                               &
&               '!------------------------------------------'
  WRITE (unit=fa%NULOUT,fmt=*)                               &
&               '!           FACODX:   WARNING !!!         !'
  WRITE (unit=fa%NULOUT,fmt=*)                               &
&               '!------------------------------------------'
  WRITE (unit=fa%NULOUT,fmt=*) ' Code retour de GRIBEX = ', &
&        iret,' pour le champ: ',cdpref,knivau,cdsuff
  WRITE (unit=fa%NULOUT,fmt=*)
ENDIF
!
! ISEC0(1) = nb d'octets dans le message GRIB
! IWORD    = nb de mots de JBDBLE octets (64 bits) du message GRIB
iword=1+(isec0(1)-1)/jplikb
klongd=idecal+iword+idimnc
IF (fa%LFAMOP) THEN
  WRITE (unit=fa%NULOUT,fmt=*)                                    &
&         ' FACODX: longueur du GRIB en nb octets et en mots = ', &
&         isec0(1), iword
  WRITE (unit=fa%NULOUT,fmt=*)                             &
&         ' FACODX: longueur de l''article FA en mots = ', &
&         klongd
  IF (isec4(4).EQ.64 .AND. isec4(3).EQ.128) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                          &
&           ' FACODX: complex packing with P=',isec4(17), &
&           ' and sub trunc = ',isec4(18)
  ENDIF
ENDIF
!
!  CAS D'UN DEPASSEMENT DE LA TAILLE MAX DE L'ARTICLE FINAL
!  On ramene ce cas a celui d'un tableau trop petit dans GRIBEX.
!
IF (klongd.GT.ilcham+2) THEN
  IF (fa%LFAMOP) THEN
    WRITE (unit=fa%NULOUT,fmt=*)                           &
&            ' FACODX: article FA + long avec compactage', &
&            ' que sans => on le supprime'
  ENDIF
  iret=710
  krep=-1000-iret
  GOTO 1001
ENDIF
!
!*
!     6.  -  TRANSFERT DES COEFFICIENTS SPECTRAUX NON COMPACTES.
!-----------------------------------------------------------------------
!        (et non traites par GRIBEX) en fin d'article.
!
IF (ldcosp) THEN
  kvalco(4)=icpack
  IF (llmlam) THEN
    kvalco(5)=ipulap
! Copy nonpacked part of PSEC4 (sub-triangle+axes) into KVALCO
    iilcham=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*(icpack+1-jm)-1
        IF (ihigh.LE.ilow) ihigh=ilow+3
      ENDIF     
!
      DO idx=ilow,ihigh
        iilcham=iilcham+1
        zsec4(iilcham)=psec4(idx)
      ENDDO
    ENDDO
    IF (iilcham.NE.idimnc) THEN
      WRITE (unit=fa%NULOUT,fmt='(A35,I10,A11,I10)')        &
&            'FACODX: incoherence entre IILCHAM= ',iilcham, &
&            'et IDIMNC= ',idimnc
      krep=-126
      GOTO 1001
    ENDIF
  ELSE
    kvalco(5)=isec4(17)
! Recuperation des coeff spectraux non compactes sachant que le
! rangement est fait par colonnes de JM=cst juxtaposees
    zsec4(1:2*(icpack+1))=psec4(1:2*(icpack+1))
    iilcham=2*(icpack+1)-1
    idx=2*(itronc+1)-1
    DO jm=1,icpack
    DO jn=jm,itronc
      idx=idx+2
      IF (jn.LE.icpack) THEN
        iilcham=iilcham+2
        zsec4(iilcham) = psec4(idx)
        zsec4(iilcham+1) = psec4(idx+1)
      ENDIF
    ENDDO
    ENDDO
    IF (iilcham+1.NE.idimnc) THEN
      WRITE (unit=fa%NULOUT,fmt='(A35,I10,A11,I10)')            &
&            'FACODX: incoherence entre IILCHAM+1= ',iilcham+1, &
&            'et IDIMNC= ',idimnc
      krep=-126
      GOTO 1001
    ENDIF
  ENDIF
! Les IDIMNC coeff spectraux non compactes doivent etre transferes
! sur le tableau d'entiers KVALCO apres le IDECAL+IWORD ieme elt.
!
!       KVALCO(IDECAL+IWORD+1:KLONGD)=TRANSFER(ZSEC4,KVALCO,IDIMNC)
  ALLOCATE (ivalco(idimnc))
  ivalco(1:idimnc)=transfer(zsec4,ivalco,idimnc)
  kvalco(idecal+iword+1:klongd)=ivalco(1:idimnc)
  DEALLOCATE (ivalco)
ENDIF
!**
!    10.  -  PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
!            VIA LE SOUS-PROGRAMME "FAIPAR" .
!-----------------------------------------------------------------------
!
1001 CONTINUE
IF (ALLOCATED(zsec4)) DEALLOCATE ( zsec4 )
!
! Cas particulier de l'erreur GRIBEX num 710: OUTPUT ARRAY TOO SMALL
! On s'en sert pour detecter un probleme de compactage lie a ce que
! le champ compacte+les descripteurs prennent plus de place que le
! champ non compacte...
! On sort donc du compactage (FACODX) pour demander un codage sans
! compactage (FACINE) avec rangement des valeurs selon le modele:
! FA%NFGRIB=-1.
!
IF (iret==710) THEN
  clnspr='FACODX'
  inimes=2
  inumer=jpniil
!
  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I4,  &
&         '', CDPREF='''''',A,'''''', KNIVAU='',I6,       &
&         '', CDSUFF='''''',A,'''''', LDCOSP= '',L1,      &
&         '', KLONGD='',I6)')                             &
&     krep, krang, cdpref(1:len_trim(cdpref)), knivau,    &
&     cdsuff(1:len_trim(cdsuff)), ldcosp, klongd
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
  clmess=                                                          &
& ' CAUTION: this field is not packed or it will occupy more space'
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
  IF (lhook) CALL dr_hook('FACODX_MT',1,zhook_handle)
  RETURN
ENDIF
!
!
!
llfata=llmoer(krep,krang)
!
IF (fa%LFAMOP.OR.llfata) THEN
  inimes=2
  clnspr='FACODX'
  inumer=jpniil
!
  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I4,  &
&         '', CDPREF='''''',A,'''''', KNIVAU='',I6,       &
&         '', CDSUFF='''''',A,'''''', LDCOSP= '',L1,      &
&         '', KLONGD='',I6)')                             &
&     krep, krang, cdpref(1:len_trim(cdpref)), knivau,    &
&     cdsuff(1:len_trim(cdsuff)), ldcosp, klongd
  CALL faipar_fort                                        &
&                 (fa, inumer,inimes,krep,.false.,clmess, &
&                  clnspr,clacti,.false.)
ENDIF
!
IF (lhook) CALL dr_hook('FACODX_MT',1,zhook_handle)

CONTAINS

#include "facom2.llmoer.h"

END SUBROUTINE facodx_fort

!INTF KREP            OUT                                                              
!INTF KRANG         IN                                                                 
!INTF CDPREF        IN                                                                 
!INTF KNIVAU        IN                                                                 
!INTF CDSUFF        IN                                                                 
!INTF PSEC4         IN    DIMS=*                                                       
!INTF LDCOSP        IN                                                                 
!INTF KVALCO          OUT DIMS=*                         KIND=JPLIKB                   
!INTF KLONGD          OUT                                                              
!INTF LDUNDF        IN                                                                 
!INTF PUNDF         IN                                                                 
!INTF YDGR1TAB      IN