! (C) Copyright 2001- ECMWF.
! (C) Copyright 2001- Meteo-France.
! 
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.
! 


SUBROUTINE EGATH_SPEC(PSPECG,KFGATHG,KTO,KVSET,KRESOL,PSPEC,LDIM1_IS_FLD,KSMAX,KMSMAX,LDZA0IP)

!**** *EGATH_SPEC* - Gather global spectral array from processors

!     Purpose.
!     --------
!        Interface routine for gathering spectral array

!**   Interface.
!     ----------
!     CALL EGATH_SPEC(...)

!     Explicit arguments :
!     --------------------
!     PSPECG(:,:) - Global spectral array
!     KFGATHG     - Global number of fields to be gathered
!     KTO(:)      - Processor responsible for gathering each field
!     KVSET(:)    - "B-Set" for each field
!     KRESOL      - resolution tag  which is required ,default is the
!                   first defined resulution (input)
!     PSPEC(:,:)  - Local spectral array
!     LDZA0IP     - Set to zero imaginary part of first coefficients

!
!     Method.
!     -------

!     Externals.  SET_RESOL   - set resolution
!     ----------  GATH_SPEC_CONTROL - control routine

!     Author.
!     -------
!        Mats Hamrud *ECMWF*

!     Modifications.
!     --------------
!        Original : 00-03-03
!        Modified 03-09-30  Y. Seity, bug correction IFSEND=0       
!        R. El Khatib 23-Oct-2012 Monkey business
!        P.Marguinaud 10-Oct-2013 Add an option to set (or not) first
!        coefficients imaginary part to zero
!        R. El Khatib 01-Dec-2020 Merge egath_spec_control and gath_spec_control
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB

!ifndef INTERFACE

USE TPM_GEN         ,ONLY : NERR
USE TPM_DIM         ,ONLY : R
USE TPMALD_DIM      ,ONLY : RALD
USE TPM_DISTR       ,ONLY : D, NPRTRV, NPRTRW, MYSETV, MYPROC, NPROC
USE TPMALD_DISTR

USE ESET_RESOL_MOD  ,ONLY : ESET_RESOL
USE GATH_SPEC_CONTROL_MOD ,ONLY : GATH_SPEC_CONTROL

USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK, JPHOOK

!endif INTERFACE

IMPLICIT NONE

! Declaration of arguments

REAL(KIND=JPRB)    ,OPTIONAL, INTENT(OUT)  :: PSPECG(:,:)
INTEGER(KIND=JPIM)          , INTENT(IN)  :: KFGATHG
INTEGER(KIND=JPIM)          , INTENT(IN)  :: KTO(:)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN)  :: KVSET(:)
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN)  :: KRESOL
REAL(KIND=JPRB)    ,OPTIONAL, INTENT(IN)  :: PSPEC(:,:)
LOGICAL            ,OPTIONAL, INTENT(IN)  :: LDIM1_IS_FLD
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN)  :: KSMAX
INTEGER(KIND=JPIM) ,OPTIONAL, INTENT(IN)  :: KMSMAX
LOGICAL            ,OPTIONAL, INTENT(IN)  :: LDZA0IP

!ifndef INTERFACE

INTEGER(KIND=JPIM) :: IVSET(KFGATHG)
INTEGER(KIND=JPIM) :: IFRECV,IFSEND,J
INTEGER(KIND=JPIM) :: IFLD,ICOEFF
INTEGER(KIND=JPIM) :: ISMAX, IMSMAX, ISPEC2, ISPEC2_G,ISPEC2MX
INTEGER(KIND=JPIM) :: IPOSSP(NPRTRW+1)
INTEGER(KIND=JPIM) :: IUMPP(NPRTRW)
INTEGER(KIND=JPIM) :: IPTRMS(NPRTRW)
INTEGER(KIND=JPIM),ALLOCATABLE :: IDIM0G(:)
INTEGER(KIND=JPIM),ALLOCATABLE :: IALLMS(:)
INTEGER(KIND=JPIM),ALLOCATABLE :: IKN(:)
LOGICAL :: LLDIM1_IS_FLD
REAL(KIND=JPHOOK) :: ZHOOK_HANDLE

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

IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',0,ZHOOK_HANDLE)
! Set current resolution
CALL ESET_RESOL(KRESOL)

LLDIM1_IS_FLD = .TRUE.
IF(PRESENT(LDIM1_IS_FLD)) LLDIM1_IS_FLD = LDIM1_IS_FLD

IF(LLDIM1_IS_FLD) THEN
  IFLD = 1
  ICOEFF = 2
ELSE
  IFLD = 2
  ICOEFF = 1
ENDIF
IF(UBOUND(KTO,1) < KFGATHG) THEN
 CALL ABORT_TRANS('EGATH_SPEC: KTO TOO SHORT!')
ENDIF

ISMAX = R%NSMAX
IMSMAX = RALD%NMSMAX
IF(PRESENT(KSMAX)) ISMAX = KSMAX
IF(PRESENT(KMSMAX)) IMSMAX = KMSMAX
ALLOCATE(IDIM0G(0:IMSMAX))
ALLOCATE(IALLMS(IMSMAX+1))
ALLOCATE(IKN(0:IMSMAX))
IF(IMSMAX /= RALD%NMSMAX .OR. ISMAX /= R%NSMAX) THEN
  CALL ABORT_TRANS('EGATH_SPEC:TRUNCATION CHANGE NOT YET CODED')
ELSE
  ISPEC2    = D%NSPEC2
  ISPEC2_G  = R%NSPEC2_G
  IPOSSP(:) = D%NPOSSP(:)
  IDIM0G(:) = D%NDIM0G(:)
  ISPEC2MX  = D%NSPEC2MX
  IUMPP(:)  = D%NUMPP(:)
  IALLMS(:) = D%NALLMS(:)
  IPTRMS(:) = D%NPTRMS(:)
  DO J=0,IMSMAX
    IKN(J)=2*DALD%NCPL2M(J)
  ENDDO
ENDIF

IFSEND = 0 
IFRECV = 0
DO J=1,KFGATHG
  IF(KTO(J) < 1 .OR. KTO(J) > NPROC) THEN
    WRITE(NERR,*) 'EGATH_SPEC:ILLEGAL KTO VALUE',KTO(J),J
    CALL ABORT_TRANS('EGATH_SPEC:ILLEGAL KTO VALUE')
  ENDIF
  IF(KTO(J) == MYPROC) IFRECV = IFRECV+1
ENDDO

IF(IFRECV > 0) THEN
  IF(.NOT.PRESENT(PSPECG)) THEN
    CALL ABORT_TRANS('EGATH_SPEC:PSPECG MISSING')
  ENDIF
  IF(UBOUND(PSPECG,IFLD) < IFRECV) THEN
    WRITE(NERR,*) 'EGATH_SPEC: ',IFLD, UBOUND(PSPECG,IFLD), IFRECV
    CALL ABORT_TRANS('EGATH_SPEC:FIELD DIMENSION OF PSPECG TOO SMALL')
  ENDIF
 IF(UBOUND(PSPECG,ICOEFF) < ISPEC2_G) THEN
    WRITE(NERR,*) 'EGATH_SPEC: ',ICOEFF, UBOUND(PSPECG,ICOEFF), ISPEC2_G
    CALL ABORT_TRANS('EGATH_SPEC:COEFF DIMENSION OF PSPECG TOO SMALL')
  ENDIF
ENDIF

IF(PRESENT(KVSET)) THEN
  IF(UBOUND(KVSET,1) < KFGATHG) THEN
    CALL ABORT_TRANS('EGATH_SPEC: KVSET TOO SHORT!')
  ENDIF
  DO J=1,KFGATHG
    IF(KVSET(J) > NPRTRV .OR. KVSET(J) < 1) THEN
      WRITE(NERR,*) 'EGATH_SPEC:KVSET(J) > NPRTRV ',J,KVSET(J),NPRTRV
      CALL ABORT_TRANS('EGATH_SPEC:KVSET CONTAINS VALUES OUTSIDE RANGE')
    ENDIF
    IF(KVSET(J) == MYSETV) THEN
      IFSEND = IFSEND+1
    ENDIF
  ENDDO
  IVSET(:) = KVSET(1:KFGATHG)
ELSEIF(NPRTRV > 1) THEN
  WRITE(NERR,*) 'EGATH_SPEC:KVSET MISSING, NPRTRV ',NPRTRV
  CALL ABORT_TRANS('EGATH_SPEC:KVSET MISSING, NPRTRV > 1')
ELSE
  IFSEND   = KFGATHG
  IVSET(:) = 1
ENDIF

IF(IFSEND > 0 ) THEN
  IF(.NOT.PRESENT(PSPEC)) THEN
    CALL ABORT_TRANS('EGATH_SPEC: FIELDS TO RECIEVE AND PSPEC NOT PRESENT')
  ENDIF
  IF(UBOUND(PSPEC,IFLD) < IFSEND) THEN
    CALL ABORT_TRANS('EGATH_SPEC: FIELD DIMENSION OF PSPEC TOO SMALL')
  ENDIF
  IF(UBOUND(PSPEC,ICOEFF) < ISPEC2 ) THEN
    CALL ABORT_TRANS('EGATH_SPEC: COEFF DIMENSION OF PSPEC TOO SMALL')
  ENDIF
ENDIF

CALL GATH_SPEC_CONTROL(PSPECG,KFGATHG,KTO,IVSET,PSPEC,LLDIM1_IS_FLD,&
 & IMSMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,LDZA0IP)
DEALLOCATE(IDIM0G)

IF (LHOOK) CALL DR_HOOK('EGATH_SPEC',1,ZHOOK_HANDLE)
!endif INTERFACE

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

END SUBROUTINE EGATH_SPEC
