SUBROUTINE WRTHLFP(CDCONF)

!**** *WRTHLFP*  - WRITES OUT THE THETA LEVEL POST-PROCESSED FIELDS
!                  IN GRIB

!     PURPOSE.
!     --------
!        CODE IN GRIB FORMAT AND WRITE OUT, EITHER TO THE FDB OR TO A
!     FILE, THE POTENTIAL TEMPERATURE LEVEL POST-PROCESSED FIELDS.

!**   INTERFACE.
!     ----------
!        *CALL* *WRTHLFP(CDCONF)

!        EXPLICIT ARGUMENTS :     CDCONF - CONFIGURATION OF CALL
!        --------------------

!        IMPLICIT ARGUMENTS :      THE SPECTRAL ARRAY.
!        --------------------      the post-processed array(s)

!     METHOD.
!     -------
!        SEE DOCUMENTATION

!     EXTERNALS.
!     ----------

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

!     AUTHOR.
!     -------
!        NILS WEDI  *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 97-09-01 (From WRPLPPG)
!       R. El Khatib 98-10-05 calling sequence to extfpf
!       R. El Khatib 99-02-03 FPSPNORM
!       D.Dent       99-05-06 allow different field code lists
!    R. El Khatib : 99-12-28 remove poles rows
!       D.Dent       00-01-10 pass first dimension to FPSPNORM 
!    R. El Khatib : 00-08-18 derived type
!       D. Dent      00-04-12 output of Montgomery geopotential and pressure
!      D.Dent        00-09-01 : convert from MPE to MPL
!    R. El Khatib : 00-11-03 Optional communications in extgpf
!    R. El Khatib : 01-04-10 Enable post-processing of filtered spectra
!    R. El Khatib : 01-08-07 Pruning options
!    R. El Khatib : 02-21-20 Fullpos B-level distribution + remove IO scheme
!      D.Dent     : 02-05-15 Remove references to extra field 099
!    R. El Khatib : 03-04-17 Fullpos improvments
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMMP    , ONLY :   LSPLITOUT,MYPROC   ,MYSETV   
USE YOMLUN   , ONLY : NULOUT
USE YOMCT0   , ONLY :         &
 & LFDBOP  
USE YOMDIM   , ONLY : NPROMA   ,NSPEC2   
USE YOMGRB   , ONLY : &
 & NGRBZ    ,NGRBSP   ,NGRBMSL  ,&
 & NGRBLNSP   
USE YOMGEM   , ONLY : NGPTOT
USE YOMAUXB  , ONLY : GAUXBUF
USE YOMAFN   , ONLY : TFP_DYNDS
USE YOMFPC   , ONLY : CFPFMT   ,MFP3DFT  ,&
 & NFP3DFT  ,NFP2DF   ,LFITT  
USE YOMFPG   , ONLY : NFPRGPL  ,NFPRGPG  ,NFPRGPLX
USE YOMDFPB  , ONLY : HFPBUF
USE YOMFP4L  , ONLY : NFLDFPL  ,NDYNFPL  ,NFPSPBL  ,NFPSPBG  ,LFPSRFL ,&
 & LFPSSRFG ,NFPSFLDG ,NFPSSETG ,NFPSLOCG ,RFPSLEVG ,RLEVFPL  
USE YOMFPSP  , ONLY : SPBFP
USE YOMFPSC2 , ONLY : NFPROMA
IMPLICIT NONE

!     EXTERNAL INTEGER FUNCTIONS
CHARACTER(LEN=1)  ,INTENT(IN)    :: CDCONF 
INTEGER(KIND=JPIM), EXTERNAL :: ISRCHEQ

CHARACTER (LEN = 1) ::  CLMODE, CLP
REAL(KIND=JPRB) :: ZSD(NFPSPBG)

REAL(KIND=JPRB),ALLOCATABLE :: ZPTRFLD(:,:)
REAL(KIND=JPRB) ,ALLOCATABLE    :: ZREAL(:,:)
INTEGER(KIND=JPIM),ALLOCATABLE  :: IFLDPTU(:),IGRIBU(:),ILEVELU(:),ISENDU(:)
INTEGER(KIND=JPIM),ALLOCATABLE  :: ISKIPU(:)
INTEGER(KIND=JPIM),ALLOCATABLE  :: IGRIBIOSH(:,:),IGRIBIOGG(:,:)

INTEGER(KIND=JPIM) :: IBSET, IEND, IFIELDST, IFLD, IGRIBCD, II, IJUMP, ILEVEL, ILOCLV, &
 & IGGMAX, IMAXDYFLD, IMAXPTS, ISKIP, ISPEC2, IST, IFF, J, JF, JFLD, JNM  

LOGICAL :: LLDYN, LLSURF, LLUPPER

REAL(KIND=JPRB) :: ZMEAN
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "fpspnorm.intfb.h"
#include "prepfdb.intfb.h"
#include "wroutgpgb.intfb.h"
#include "wroutspgb.intfb.h"

#include "fcttim.h"

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

!*       1.    PREPARATIONS.
!              --------------

IF (LHOOK) CALL DR_HOOK('WRTHLFP',0,ZHOOK_HANDLE)
CALL GRSVCK(0)

CLMODE = 'w'

IF (CDCONF == 'E') THEN
  CLP='P'
ELSEIF (CDCONF == 'U') THEN
  CLP='H'
ELSEIF (CDCONF == 'Y') THEN
  CLP='V'
ELSEIF (CDCONF == 'M') THEN
  CLP='T'
ELSEIF (CDCONF == 'Z') THEN
  CLP='S'
ENDIF

ISPEC2  = NSPEC2

!     *  COMPUTE FIELD POINTERS

LLDYN=CDCONF == 'E'.OR.CDCONF == 'U'.OR.CDCONF == 'Y'.OR.&
 & CDCONF == 'M'.OR.CDCONF == 'Z'  

IMAXDYFLD = NDYNFPL

IF (LLDYN.AND.(NFP3DFT+NFP2DF) > 0) THEN
  ALLOCATE(IFLDPTU(IMAXDYFLD))
  ALLOCATE(IGRIBU(IMAXDYFLD))
  ALLOCATE(ILEVELU(IMAXDYFLD))
  ALLOCATE(ISENDU(IMAXDYFLD))
  ALLOCATE(ISKIPU(IMAXDYFLD))
  IF( LFITT ) THEN
    ALLOCATE(IGRIBIOSH(4,NFPSPBG+1))
  ENDIF
ENDIF

!*       1.1 PREPARE FDB      

IF(LFDBOP) THEN
  CALL PREPFDB
ENDIF

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

!*       2.    WRITE SPECTRAL DATA ON THETA LEVELS.
!              ------------------------------------

!*       2.1   EXTRACT AND COPY SPECTRAL FIELDS
!              --------------------------------

IF (NFPSPBG > 0.AND.LFITT.AND.CFPFMT == 'MODEL'.AND.LLDYN) THEN

! Initialise igribiosh data structure
!   1 - grib code
!   2 - level (used in file name)
!   3 - bset to send this field
!   4 - local level for sending bset

  DO J=1,NFPSPBG
    IGRIBIOSH(1,J)=TFP_DYNDS(NFPSFLDG(J))%IGRIB
    IGRIBIOSH(2,J)=NINT(RFPSLEVG(J))
    IGRIBIOSH(3,J)=NFPSSETG(J)
    IGRIBIOSH(4,J)=NFPSLOCG(J)
  ENDDO
  ALLOCATE(ZPTRFLD(ISPEC2,NFPSPBL))
  IFF=0
  DO JF=1,NFPSPBG
    IBSET  = IGRIBIOSH(3,JF)
    IF( IBSET == MYSETV )THEN
      IFF=IFF+1
      ILOCLV = IGRIBIOSH(4,JF)
      DO JNM=1,ISPEC2
        ZPTRFLD(JNM,IFF)=SPBFP(ILOCLV,JNM)
      ENDDO
    ENDIF
  ENDDO

! Compute and write out spectral norms
  WRITE(NULOUT,FMT='(''FULL-POS SPNORMS'')')
  CALL FPSPNORM(SPBFP,NFPSPBL,NFPSPBG,1,NFPSSETG,NFPSLOCG,ZSD)
  IF (MYPROC == 1) THEN
    DO JF=1,NFPSPBG
      IGRIBCD = IGRIBIOSH(1,JF)
      ILEVEL = IGRIBIOSH(2,JF)
      IBSET  = IGRIBIOSH(3,JF)
      ILOCLV = IGRIBIOSH(4,JF)
      ZMEAN=ZSD(JF)
      LLSURF=LLDYN.AND.LFPSSRFG(JF)
      LLUPPER=LLDYN.AND..NOT.LLSURF
      IF (LLUPPER) THEN
        WRITE(NULOUT,FMT='(1X, A1,I5.5,I3.3,'' : '',E21.15)') CLP,ILEVEL,&
         & IGRIBCD,ZMEAN  
      ELSEIF(LLSURF) THEN
        WRITE(NULOUT,FMT='(1X, I3.3,'' : '',E21.15)')IGRIBCD,ZMEAN
      ENDIF
    ENDDO
  ENDIF

!  Gather global fields and write out

  CALL WROUTSPGB(ZPTRFLD,NFPSPBG,IGRIBIOSH,'t')
  DEALLOCATE(ZPTRFLD)

ENDIF

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

!*       3.0   WRITE OUT UPPER AIR GRID POINT FIELDS
!              --------------------------------------

IF( LSPLITOUT )THEN
  CLMODE = 'w'
ELSE
  CLMODE = 'a'
ENDIF

IF (LLDYN.AND.(NFP3DFT+NFP2DF) > 0) THEN

!*       3.1   COPY FROM NPROMA FORMAT TO FIELD FORMAT

  IFF = 0
  DO JFLD=1,NDYNFPL

    IFLD=NFLDFPL(JFLD)
    LLSURF=LFPSRFL(JFLD)
    LLUPPER=.NOT.LLSURF
    ILEVELU(JFLD)=NINT(RLEVFPL(JFLD))
    IGRIBU (JFLD) = TFP_DYNDS(IFLD)%IGRIB
    IFLDPTU(JFLD) = JFLD

    IGRIBCD=IGRIBU(JFLD)
    IF( LLUPPER ) THEN
      IF( NFP3DFT /= 0 .AND. ISRCHEQ(NFP3DFT,MFP3DFT,1,IGRIBCD) > NFP3DFT ) THEN
        WRITE(NULOUT,'(A,I3.3)')&
         & ' FIELD IN BUFFER BUT PP NOT REQUESTED...',IGRIBCD  
        ISKIPU(JFLD) = 1
      ELSE
        IFF = IFF+1
        ISKIPU(JFLD) = 0
      ENDIF
    ELSE
      IF( (IGRIBCD == NGRBLNSP).OR.(IGRIBCD == NGRBSP).OR.&
         & (IGRIBCD == NGRBZ).OR.(IGRIBCD == NGRBMSL) ) THEN  
        WRITE(NULOUT,'(A,I3.3)')&
         & ' FIELD CONSIDERED SPECTRAL ONLY ... SKIPPED PAR=',IGRIBCD  
        ISKIPU(JFLD) = 1
      ELSE
        IFF = IFF+1
        ISKIPU(JFLD) = 0
      ENDIF
    ENDIF
  ENDDO

  IFIELDST = NDYNFPL

  IF( CFPFMT == 'GAUSS' ) THEN
    IJUMP    = MIN(NFPRGPL,NFPROMA)
    IMAXPTS  = NFPRGPL
  ELSE
    IJUMP    = MIN(NGPTOT,NPROMA)
    IMAXPTS  = NGPTOT
  ENDIF

! Loop over all fields
  ALLOCATE(ZREAL(NFPRGPL,IFF))
  ALLOCATE(IGRIBIOGG(2,IFF))

  IFF = 0
  DO JF=1,IFIELDST
    IGRIBCD = IGRIBU(JF)
    ILEVEL  = ILEVELU(JF)
    IF( ISKIPU(JF) /= 1 ) THEN
      IFF =IFF+1
      IGRIBIOGG(1,IFF) = IGRIBCD
      IGRIBIOGG(2,IFF) = ILEVEL
      
      II=0
      DO IST=1,IMAXPTS,IJUMP
        IEND  = MIN(IST+IJUMP-1,IMAXPTS)
        ISKIP = IEND-IST+1
        DO J=IST,IEND
          IF( CFPFMT == 'GAUSS' ) THEN
            ZREAL(J,IFF) = HFPBUF(II*IJUMP+(IFLDPTU(JF)-1)*ISKIP+J-IST+1)
          ELSE
!mf This needs changing. Gridpoint bufferws should be accessed using SC2RDG.
            ZREAL(J,IFF) = GAUXBUF%GPBUF(II*IJUMP+(IFLDPTU(JF)-1)*ISKIP+J-IST+1)
          ENDIF
        ENDDO
        II = II+IMAXDYFLD
      ENDDO
    ENDIF

  ENDDO

  IGGMAX = IFF

!  Gather global fields and write out
  IF(IGGMAX > 0) THEN
    CALL WROUTGPGB(ZREAL,NFPRGPL,NFPRGPG,NFPRGPLX,IGGMAX,IGRIBIOGG,'t',CLMODE)
  ENDIF
  DEALLOCATE(ZREAL)
  DEALLOCATE(IGRIBIOGG)

ENDIF

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

IF (LLDYN.AND.(NFP3DFT+NFP2DF) > 0) THEN
  DEALLOCATE(IFLDPTU)
  DEALLOCATE(IGRIBU)
  DEALLOCATE(ILEVELU)
  DEALLOCATE(ISENDU)
  DEALLOCATE(ISKIPU)
  IF( LFITT ) THEN
    DEALLOCATE(IGRIBIOSH)
  ENDIF
  IF (ALLOCATED(SPBFP)) DEALLOCATE(SPBFP)
ENDIF

CALL GRSVCK(1)

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

