SUBROUTINE PREPACKA(KDOM,PREAL,CDPREF,KLEV,CDSUFF,KFLDS,KDIMG,KMASK,LDCOSP, &
 & KGRIB,KBITS,CDLEC,KNOMA,KLONGA,CDNOMA,KSTART,KLEN,KLENPACK)  

!**** *PREPACKA*  - preliminar packing of gridpoint or spectral data 
!                   before writing out to file

!     Purpose.
!     --------
!        To pack a chunk of global fields (either spectral or gridpoint) 
!        prior to writing out to a file Arpege/Aladin
!        WARNING : spectral data is expected to be ordered like in FA file

!**   Interface.
!     ----------
!        *CALL* *PREPACKA*

!        Explicit arguments :
!        --------------------

!            KDOM    : number of subdomains
!            PREAL   : global fields to pack
!            CDPREF  : prefix of field names
!            KLEV    : level  of field names
!            CDSUFF  : suffix of field names
!            KFLDS   : number of fields to pack
!            KDIMG   : Size of fields in PREAL
!            KMASK   : binary mask ; =0 to skip the field (no write out) ;
!                      else =1
!            LDCOSP  : .TRUE. for spectral data ; else gridpoint data
!            KGRIB   : level of GRIB encoding
!            KBITS   : number of bits to code with        
!            CDLEC   : file framework for encoding        
!            KNOMA   : length of field name to write afterward
!            KLONGA  : length of field to write afterward
!            CDNOMA  : field name to write afterward
!            KSTART  : start adress of fields in PREAL
!            KLEN    : actual size of fields in PREAL
!            KLENPACK: OVERDIMENSIONED size of fields for packing in PREAL 

!        Implicit arguments :
!        --------------------

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------
!           FA routines

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!         RYAD EL KHATIB *METEO-FRANCE*

!     Modifications.
!     --------------
!        ORIGINAL : 98-12-18 from wrpxfa
!    R. El Khatib 99-12-23 Fix : no possible shift in start pointers
!    R. El Khatib : 03-04-17 Fullpos improvemnts
!    M.Hamrud      01-Oct-2003 CY28 Cleaning
!    D. Paradis & R. El Khatib : 04-07-22 GRIBEX
!    R. El Ouaraini : 03-Oct-06 GRIBEX: INGRIG is computed from KGRIB(NFPGRIB) instead of INGRIB(NVGRIB)
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMLUN   , ONLY : NSCRTCH
USE YOMDIM   , ONLY : NSEFRE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KDOM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLDS 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDIMG 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PREAL(KDIMG,KFLDS) 
CHARACTER(LEN=*)  ,INTENT(IN)    :: CDPREF(KFLDS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV(KFLDS) 
CHARACTER(LEN=*)  ,INTENT(IN)    :: CDSUFF(KFLDS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMASK(KFLDS,KDOM) 
LOGICAL           ,INTENT(IN)    :: LDCOSP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGRIB 
INTEGER(KIND=JPIM),INTENT(IN)    :: KBITS(KFLDS) 
CHARACTER(LEN=*)  ,INTENT(IN)    :: CDLEC(KDOM) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KNOMA(KFLDS,KDOM) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KLONGA(KFLDS,KDOM) 
CHARACTER(LEN=*)  ,INTENT(OUT)   :: CDNOMA(KFLDS,KDOM) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KSTART(KDOM) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN(KDOM) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLENPACK(KDOM) 
INTEGER(KIND=JPIM) :: JPMAXBIT
INTEGER(KIND=JPIM) :: JPFAOVRSZ

PARAMETER(JPMAXBIT=31)
PARAMETER(JPFAOVRSZ=2)

CHARACTER (LEN = 6) ::  CLSTTU, CLNAME
REAL(KIND=JPRB) :: ZWORK(KDIMG)
REAL(KIND=JPRB), ALLOCATABLE :: ZFIELD(:,:), ZVALCO(:), ZORDER(:,:)
LOGICAL :: LLNOM, LLERFA, LLIMST, LLFILE_TO_MODEL

INTEGER(KIND=JPIM) :: IBIT, ICOD, IDMOPL, INBARI, INBARP, INBCSP, INBPDG
INTEGER(KIND=JPIM) :: INGRIB, INIMES, IPUILA, IREP, ISTRON, IUNTIN, JFLD, JD
INTEGER(KIND=JPIM) :: JI, INGRIG 
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "spreord.intfb.h"

!      -----------------------------------------------------------

!*    1.    SETUP PACKING ENVIRONMENT WITHOUT OPENING FILE
!           ----------------------------------------------

IF (LHOOK) CALL DR_HOOK('PREPACKA',0,ZHOOK_HANDLE)
INIMES=1
INBARI=0
INBARP=KFLDS
IUNTIN=NSCRTCH
LLNOM=.FALSE.
LLERFA=.TRUE.
LLIMST=.TRUE.
CLSTTU='NEW'
LLFILE_TO_MODEL=.FALSE.
ALLOCATE(ZFIELD(1,MAXVAL(KLEN)))
ALLOCATE(ZVALCO(MAXVAL(KLENPACK)))
IF (LDCOSP) ALLOCATE(ZORDER(1,NSEFRE))

! Space data before packing
IF (KDOM > 1) THEN
  DO JFLD=1,KFLDS
    DO JD=2,KDOM
      DO JI=KSTART(JD),KSTART(JD)-1+KLEN(JD) 
        ZWORK(JI)=PREAL(JI,JFLD)
      ENDDO 
    ENDDO
    DO JD=2,KDOM
      DO JI=KSTART(JD),KSTART(JD)-1+KLEN(JD)
        PREAL(JI+JPFAOVRSZ,JFLD)=ZWORK(JI)
      ENDDO
    ENDDO
  ENDDO
  DO JD=2,KDOM
    KSTART(JD)=KSTART(JD)+JPFAOVRSZ
  ENDDO
ENDIF

DO JD=1,KDOM
  CALL FANOUV(IREP,IUNTIN,LLNOM,CLNAME,CLSTTU,LLERFA,LLIMST,INIMES,&
   & INBARP,INBARI,CDLEC(JD))  
  CALL FAVEUR(IREP,IUNTIN,INGRIB,INBPDG,INBCSP,ISTRON,IPUILA,IDMOPL)
! data should be reordered only if packing type is not -1 and not 3
  IF (KGRIB==-1 .OR. KGRIB==3) THEN
    INGRIG=-1
  ELSE
    INGRIG=0
  ENDIF  

!*    2.    PACK FIELDS
!           -----------

  DO JFLD=1,KFLDS

    IF (KMASK(JFLD,JD) == 1) THEN

!*        2.1 Extract a global field from global array

      DO JI=1,KLEN(JD)
        ZFIELD(1,JI)=PREAL(KSTART(JD)-1+JI,JFLD)
      ENDDO 
      
!*        2.2 Prepare for packing

      IF (KBITS(JFLD) > JPMAXBIT) THEN
        ICOD=INGRIG
      ELSE
        ICOD=KGRIB
      ENDIF
!     Prevent abort in FAGOTE :
      IBIT=MIN(JPMAXBIT,KBITS(JFLD))
      CALL FAGOTE(IREP,IUNTIN,ICOD,IBIT,IBIT,ISTRON,IPUILA,IDMOPL)

!*        2.3 Pack

      IF (LDCOSP .AND. INGRIG==0) THEN
        CALL SPREORD(1,ZORDER,ZFIELD,LLFILE_TO_MODEL)
        CALL FACOND(IREP,IUNTIN,CDPREF(JFLD),KLEV(JFLD),CDSUFF(JFLD),ZORDER, &
         & LDCOSP,CDNOMA(JFLD,JD),KNOMA(JFLD,JD),ZVALCO,KLONGA(JFLD,JD))
      ELSE
        CALL FACOND(IREP,IUNTIN,CDPREF(JFLD),KLEV(JFLD),CDSUFF(JFLD),ZFIELD, &
         & LDCOSP,CDNOMA(JFLD,JD),KNOMA(JFLD,JD),ZVALCO,KLONGA(JFLD,JD))  
      ENDIF

!*        2.4 Re-inject the global field in global array. ZVALCO may carry 
!*            non representable floats, therefore make a memcopy

      CALL ECMWF_TRANSFER(PREAL(KSTART(JD):KSTART(JD)+KLONGA(JFLD,JD)-1,JFLD), &
       & JPRB*KLONGA(JFLD,JD),ZVALCO(1:KLONGA(JFLD,JD)),JPRB*KLONGA(JFLD,JD))

    ENDIF

  ENDDO

!*    3.    FLUSH OUT PACKING ENVIRONMENT
!           -----------------------------

  CLSTTU='DELETE'
  CALL FAIRNO(IREP,IUNTIN,CLSTTU)

ENDDO
IF (LDCOSP) DEALLOCATE(ZORDER)
DEALLOCATE(ZFIELD)
DEALLOCATE(ZVALCO)

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('PREPACKA',1,ZHOOK_HANDLE)
END SUBROUTINE PREPACKA
