SUBROUTINE WRITE_SPEC(cdfile, YD_SPEC, ldfirst, LDGRIB,PFACTOR,PEXPO)

!     Purpose.
!     --------
!       Write spectral fields in files, one file per level.

!     Author.
!     -------
!       Yannick Tremolet *ECMWF*

!     Modifications.
!     --------------
!       Original  : 02-03-21
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!        Y.Tremolet    30-Mar-2005 PREGRBENC -> PRESET_GRIB_HEAD
!        M.Hamrud      01-May-2006 Generalized IO scheme
! ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE PARDIM, ONLY: JPMXLE
USE YOMCT0, ONLY: NPRTRW, LELAM, NPROC,NPRTRV
USE YOMMP , ONLY:  MYSETV, MYPROC,NBSETLEV,MYSETW
USE SPECTRAL_FIELDS_MOD, ONLY : SPECTRAL_FIELD
USE IOSTREAM_MIX , ONLY : SETUP_IOSTREAM, SETUP_IOREQUEST, IO_PUT, &
 & CLOSE_IOSTREAM, TYPE_IOSTREAM , TYPE_IOREQUEST, &
 & CLOSE_IOREQUEST

IMPLICIT NONE

CHARACTER(LEN=*)  ,INTENT(IN)    :: CDFILE 
TYPE(SPECTRAL_FIELD),INTENT(INOUT) :: YD_SPEC
LOGICAL           ,INTENT(IN)    :: LDFIRST 
LOGICAL ,OPTIONAL ,INTENT(IN)    :: LDGRIB
REAL(KIND=JPRB) ,OPTIONAL ,INTENT(IN) :: PFACTOR, PEXPO
REAL(KIND=JPRB), ALLOCATABLE ::  ZFILTER(:)
INTEGER(KIND=JPIM) :: JLEV, JF, IL, ILL,JS,JN
INTEGER(KIND=JPIM) :: JA,JB,IC,IM,JMLOC
INTEGER(KIND=JPIM) :: IONPROCS,ICHUNKS,JCH,ISTLEV,IENLEV,ILEVS,IGLEV
INTEGER(KIND=JPIM) :: IOPROCS(JPMXLE),ILEVLIST(JPMXLE),IUMLL(NPRTRV)
INTEGER(KIND=JPIM) :: IMYLEVS,IPE
INTEGER(KIND=JPIM) :: IGRIB3D(99),ILEVS3D(JPMXLE),IPROC3D(JPMXLE),IBSET3D(JPMXLE)
INTEGER(KIND=JPIM) :: INVALUE(YD_SPEC%NSPEC2)
CHARACTER(LEN=128) :: CLFILELEV
CHARACTER(LEN=3) :: CLEV
CHARACTER(LEN=1) :: CLMODE

TYPE(TYPE_IOSTREAM) :: YL_IOSTREAM
TYPE(TYPE_IOREQUEST) :: YL_IOREQUEST
REAL(KIND=JPRB),ALLOCATABLE :: ZSPEC(:,:,:)
LOGICAL :: LLGRIB
REAL(KIND=JPRB) :: ZFACTOR, ZEXPOH
REAL(KIND=JPRB) :: ZHOOK_HANDLE


#include "abor1.intfb.h"
#include "set2pe.intfb.h"

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

IF (LHOOK) CALL DR_HOOK('WRITE_SPEC',0,ZHOOK_HANDLE)
IF (LELAM) CALL ABOR1(' WRITE_SPEC: lelam case not implemented ')

IF (PRESENT(PFACTOR)) THEN
  ZFACTOR=PFACTOR
ELSE
  ZFACTOR=1.0_JPRB
ENDIF

IF (PRESENT(PEXPO)) THEN
  ZEXPOH=PEXPO/2.0_JPRB
ELSE
  ZEXPOH=1.0_JPRB
ENDIF

ALLOCATE(ZFILTER(0:YD_SPEC%nsmax))
IF (ZFACTOR /=1.0_JPRB) THEN
  DO JN=0,YD_SPEC%NSMAX
    ZFILTER(JN)=1.0_JPRB/(1.0_JPRB+(ZFACTOR-1.0_JPRB)*((JN*(JN+1))**ZEXPOH/ &
     &            (YD_SPEC%NSMAX*(YD_SPEC%NSMAX+1))**ZEXPOH))
  ENDDO
ELSE
  ZFILTER(:)=1.0_JPRB
ENDIF
IC=1
DO JMLOC=1,YD_SPEC%NUMP
  IM=YD_SPEC%MS_PROC(JMLOC,MYSETW)
  DO JN=IM,YD_SPEC%NSMAX
    INVALUE(IC  )=JN
    INVALUE(IC+1)=JN
    IC=IC+2
  ENDDO
ENDDO


LLGRIB=.TRUE.
IF (PRESENT(LDGRIB)) LLGRIB=LDGRIB

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

IF (YD_SPEC%NS3D > 0) THEN
  IONPROCS = MIN(NPROC,YD_SPEC%NFLEVG)
  ICHUNKS  = (YD_SPEC%NFLEVG-1)/IONPROCS+1
  ILEVS    = 0
  IUMLL(:) = 0
  OUTER:DO
    DO JA=1,NPRTRW
      DO JB=1,NPRTRV
        ILEVS = ILEVS+1
        IF(ILEVS > YD_SPEC%NFLEVG) EXIT OUTER
        IUMLL(JB) = IUMLL(JB)+1
        IF( IUMLL(JB) <= YD_SPEC%NUMLL(JB)) THEN
          IGLEV = YD_SPEC%NPTRLL(JB)+IUMLL(JB)-1
          ILEVLIST(ILEVS) = IGLEV
          CALL SET2PE(IPE,0,0,JA,JB)
          IOPROCS(ILEVS) = IPE
        ENDIF
      ENDDO
    ENDDO
  ENDDO OUTER

  DO JCH=1,ICHUNKS
    ISTLEV = (JCH-1)*IONPROCS+1
    IENLEV = MIN(YD_SPEC%NFLEVG,JCH*IONPROCS)
    ILEVS  = IENLEV-ISTLEV+1
    IMYLEVS = 0
    DO JLEV=ISTLEV,IENLEV
      IGLEV = ILEVLIST(JLEV)
      IF(NBSETLEV(IGLEV) == MYSETV) THEN
        IMYLEVS = IMYLEVS+1
      ENDIF
      IF (IOPROCS(JLEV) == MYPROC) THEN
        WRITE(CLEV,'(I3.3)')IGLEV
        CLFILELEV=CDFILE//'L'//CLEV
      ENDIF
    ENDDO
    CALL SETUP_IOSTREAM(YL_IOSTREAM,'CIO',TRIM(CLFILELEV),CDMODE=CLMODE,&
     & KIOPROCS=IOPROCS(ISTLEV:IENLEV))
    ALLOCATE(ZSPEC(IMYLEVS,YD_SPEC%nspec2,YD_SPEC%NS3D))
    CALL GSTATS(1476,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JS,JF,ILL,JLEV,IGLEV,IL)
    DO JS=1,YD_SPEC%NSPEC2
      DO JF=1,YD_SPEC%NS3D
        ILL = 0
        DO JLEV=ISTLEV,IENLEV
          IGLEV = ILEVLIST(JLEV)
          IF(NBSETLEV(IGLEV) == MYSETV) THEN
            IL = IGLEV-YD_SPEC%NPTRLL(MYSETV)+1
            ILL = ILL+1
            ZSPEC(ILL,JS,JF) = YD_SPEC%SP3D(IL,JS,JF)*ZFILTER(INVALUE(JS))
          ENDIF
        ENDDO
      ENDDO
    ENDDO
!$OMP END PARALLEL DO
    CALL GSTATS(1476,1)
    DO JF=1,YD_SPEC%NS3D
      IGRIB3D(JF) = YD_SPEC%NGRIB3(JF)
    ENDDO
    ILEVS3D(1:ILEVS) = ILEVLIST(ISTLEV:IENLEV)
    IPROC3D(1:ILEVS) = IOPROCS(ISTLEV:IENLEV)
    DO JLEV=1,ILEVS
      IBSET3D(JLEV) = NBSETLEV(ILEVS3D(JLEV))
    ENDDO
    CALL SETUP_IOREQUEST(YL_IOREQUEST,'SPECTRAL_FIELDS',LDGRIB=.TRUE.,&
     & KGRIB3D=IGRIB3D(1:YD_SPEC%NS3D),KLEVS3D=ILEVS3D(1:ILEVS),KBSET3D=IBSET3D,&
     & KSMAX=YD_SPEC%NSMAX)
    CALL IO_PUT(YL_IOSTREAM,YL_IOREQUEST,PR3=ZSPEC,KLEVPROC3D=IPROC3D(1:ILEVS))
    CALL CLOSE_IOREQUEST(YL_IOREQUEST)
    DEALLOCATE(ZSPEC)
    CALL CLOSE_IOSTREAM(YL_IOSTREAM)
  ENDDO
ENDIF


! ------------------------------------------------------------------
! 2D arrays
! ------------------------------------------------------------------

IF (YD_SPEC%NS2G>0) THEN
  IL = 0
  WRITE(CLEV,'(I3.3)')IL
  CLFILELEV = CDFILE//'L'//CLEV

!   Write fields
  CALL SETUP_IOSTREAM(YL_IOSTREAM,'CIO',TRIM(CLFILELEV),CDMODE=CLMODE,&
   & KIOMASTER=1)

! It should be on model levels but for bit-reprod ....
!!$  CALL SETUP_IOREQUEST(YL_IOREQUEST,'SPECTRAL_FIELDS',LDGRIB=.TRUE.,&
!!$   & KGRIB2D=YD_SPEC%NGRIB2(1:YD_SPEC%NS2G),KSMAX=YD_SPEC%NSMAX)
  CALL SETUP_IOREQUEST(YL_IOREQUEST,'SPECTRAL_FIELDS',LDGRIB=.TRUE.,&
   & KGRIB2D=YD_SPEC%NGRIB2(1:YD_SPEC%NS2G),KSMAX=YD_SPEC%NSMAX,CDLEVTYPE='SFC')
  DO JF=1,YD_SPEC%NS2D
    DO JS=1,YD_SPEC%NSPEC2
      YD_SPEC%SP2D(JS,JF) = YD_SPEC%SP2D(JS,JF)*ZFILTER(INVALUE(JS))
    ENDDO
  ENDDO
  CALL IO_PUT(YL_IOSTREAM,YL_IOREQUEST,PR2=YD_SPEC%SP2D)
  CALL CLOSE_IOREQUEST(YL_IOREQUEST)
  CALL CLOSE_IOSTREAM(YL_IOSTREAM)
ENDIF

DEALLOCATE(ZFILTER)


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