! (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 EDIST_SPEC(PSPECG,KFDISTG,KFROM,KVSET,KRESOL,PSPEC,&
 & LDIM1_IS_FLD,KSORT)

!**** *EDIST_SPEC* - Distribute global spectral array among processors

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

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

!     Explicit arguments :
!     --------------------
!     PSPECG(:,:) - Global spectral array
!     KFDISTG     - Global number of fields to be distributed
!     KFROM(:)    - Processor resposible for distributing each field
!     KVSET(:)    - "B-Set" for each field
!     KRESOL      - resolution tag  which is required ,default is the
!                   first defined resolution (input)
!     PSPEC(:,:)  - Local spectral array

!     Method.
!     -------

!     Externals.  ESET_RESOL   - set resolution
!     ----------  DIST_SPEC_CONTROL - control routine

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

!     Modifications.
!     --------------
!        Original : 00-03-03
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        P.Marguinaud  10-Oct-2014 Add KSORT argument (change the order of fields)

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

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

!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    ,ONLY : DALD

USE ESET_RESOL_MOD  ,ONLY : ESET_RESOL
USE DIST_SPEC_CONTROL_MOD ,ONLY : DIST_SPEC_CONTROL
USE ABORT_TRANS_MOD ,ONLY : ABORT_TRANS

!endif INTERFACE

IMPLICIT NONE

! Declaration of arguments

REAL(KIND=JPRB)   ,OPTIONAL,INTENT(IN)    :: PSPECG(:,:)
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDISTG
INTEGER(KIND=JPIM),INTENT(IN)    :: KFROM(:)
INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN)    :: KVSET(:)
INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN)    :: KRESOL
LOGICAL           ,OPTIONAL,INTENT(IN)    :: LDIM1_IS_FLD
REAL(KIND=JPRB)   ,OPTIONAL,INTENT(OUT)   :: PSPEC(:,:)
INTEGER(KIND=JPIM),OPTIONAL,INTENT(IN)    :: KSORT (:)
!ifndef INTERFACE

INTEGER(KIND=JPIM) :: IVSET(KFDISTG)
INTEGER(KIND=JPIM) :: IFSEND,IFRECV,J, IFLD, ICOEFF
INTEGER(KIND=JPIM) :: ISMAX, 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
!     ------------------------------------------------------------------

! Set current resolution
IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',0,ZHOOK_HANDLE)
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

ISMAX = RALD%NMSMAX
ALLOCATE(IDIM0G(0:ISMAX))
ALLOCATE(IALLMS(ISMAX+1))
ALLOCATE(IKN(0:ISMAX))
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,ISMAX
  IKN(J)=2*DALD%NCPL2M(J)
ENDDO

IF(UBOUND(KFROM,1) < KFDISTG) THEN
  CALL ABORT_TRANS('EDIST_SPEC: KFROM TOO SHORT!')
ENDIF
 
IFSEND = 0
IFRECV = 0

DO J=1,KFDISTG
  IF(KFROM(J) < 1 .OR. KFROM(J) > NPROC) THEN
    WRITE(NERR,*) 'EDIST_SPEC:ILLEGAL KFROM VALUE',KFROM(J),J
    CALL ABORT_TRANS('EDIST_SPEC:ILLEGAL KFROM VALUE')
  ENDIF
  IF(KFROM(J) == MYPROC) IFSEND = IFSEND+1
ENDDO

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

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

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

IF (PRESENT (KSORT)) THEN
  IF (.NOT. PRESENT (PSPEC)) THEN
    CALL ABORT_TRANS('EDIST_SPEC: KSORT REQUIRES PSPEC')
  ENDIF
  IF (UBOUND (KSORT, 1) /= UBOUND (PSPEC, IFLD)) THEN
    CALL ABORT_TRANS('EDIST_SPEC: DIMENSION MISMATCH KSORT, PSPEC')
  ENDIF
ENDIF

CALL DIST_SPEC_CONTROL(PSPECG,KFDISTG,KFROM,IVSET,PSPEC,LLDIM1_IS_FLD,&
 & ISMAX,ISPEC2,ISPEC2MX,ISPEC2_G,IPOSSP,IDIM0G,IUMPP,IALLMS,IPTRMS,IKN,KSORT)
DEALLOCATE(IDIM0G)
IF (LHOOK) CALL DR_HOOK('EDIST_SPEC',1,ZHOOK_HANDLE)

!endif INTERFACE

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

END SUBROUTINE EDIST_SPEC

