SUBROUTINE FPTSA_DIR(PSCA,PVOR,PDIV,PUMEAN,PVMEAN)

!**** *FPTSA_DIR * - Full-Pos Transfer Spectral Array - Direct

!     Purpose
!     -------
!       To transfer spectral arrays out of transforms to the post-processing 
!       spectral array.

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

!     Explicit arguments : 
!     --------------------
!        PSCA   : scalar fields
!        PVOR   : vorticity fields
!        PDIV   : divergence fields
!        PUMEAN : U - mean wind (for LAM)
!        PVMEAN : V - mean wind (for LAM)

!     Externals.
!     ----------
!       None.

!     Reference.
!     ----------
!        Fullpos technical & users guide.

!     Author.
!     -------
!        Ryad El Khatib *METEO-FRANCE*

!     Modifications.
!     --------------
!        Original : 03-02-11 From TRANSDIR_FP
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        R. El Khatib  20-Apr-2007 Optimisation.
!     ------------------------------------------------------------------

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

USE YOMVPOS  , ONLY : QFPTYPE  ,NFPOSDYN ,NFPTRDYN ,MYSFSET
USE YOMFPSP  , ONLY : SPBFP    ,UMEAN    ,VMEAN
USE YOMDIM   , ONLY : NSPEC2
USE YOMFPDIM , ONLY : NFPSCA   ,NFPVEC   ,NFPSPB   ,NFPUVMN
USE YOMCT0   , ONLY : LALLOPR
USE YOMLUN   , ONLY : NULOUT

IMPLICIT NONE

REAL(KIND=JPRB)   ,INTENT(IN)    :: PSCA(:,:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PVOR(:,:) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDIV(:,:) 
REAL(KIND=JPRB)   ,OPTIONAL,INTENT(IN)    :: PUMEAN(:) 
REAL(KIND=JPRB)   ,OPTIONAL,INTENT(IN)    :: PVMEAN(:) 
INTEGER(KIND=JPIM) :: J, JF, INC, JLEV, IJ, JS
INTEGER(KIND=JPIM) :: IFLD(NFPSPB), IARR(NFPSPB)

INTEGER(KIND=JPIM) :: IVOR     ! last pointer of vorticity fields in PVOR
INTEGER(KIND=JPIM) :: IDIV     ! last pointer of divergence fields in PDIV
INTEGER(KIND=JPIM) :: ISCA     ! last pointer of scalar fields in PSCA
INTEGER(KIND=JPIM) :: ISPB     ! last pointer of divergence fields in SPBFP
INTEGER(KIND=JPIM) :: IMNU     ! last pointer of mean U
INTEGER(KIND=JPIM) :: IMNV     ! last pointer of mean V

LOGICAL :: LLAM       ! .TRUE. if limited area model

CHARACTER(LEN=35) :: CLFMT='(1X,''ARRAY '',A10,'' ALLOCATED '',8I8)'
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

!      1. Select model

IF (LHOOK) CALL DR_HOOK('FPTSA_DIR',0,ZHOOK_HANDLE)
LLAM=PRESENT(PUMEAN).AND.PRESENT(PVMEAN)

!      2. Allocate spectral post-processing arrays

! Allocate even with size 0, because it will be sent to subroutines fpspnorm & trwvtof
ALLOCATE(SPBFP(NFPSPB,NSPEC2))
IF (LALLOPR) THEN
  WRITE(NULOUT,CLFMT) 'SPBFP    ',SIZE(SPBFP),SHAPE(SPBFP)
ENDIF
IF (LLAM) THEN
  IF (ALLOCATED(UMEAN)) DEALLOCATE(UMEAN)
  IF (ALLOCATED(VMEAN)) DEALLOCATE(VMEAN)
  ALLOCATE(UMEAN(NFPUVMN),VMEAN(NFPUVMN))
  IF (LALLOPR) THEN
    WRITE(NULOUT,CLFMT) 'UMEAN    ',SIZE(UMEAN),SHAPE(UMEAN)
    WRITE(NULOUT,CLFMT) 'VMEAN    ',SIZE(VMEAN),SHAPE(VMEAN)
  ENDIF
ENDIF

!      3. Set fields correspondences

IVOR=1
IDIV=1
ISCA=1
ISPB=1
IMNU=1
IMNV=1
DO J=1,NFPOSDYN
  IJ=NFPTRDYN(J)
  IF (QFPTYPE%ISF(IJ) >= 1) THEN
    SELECT CASE (QFPTYPE%ILED(IJ))
    CASE (0)
!       Scalar
      DO JLEV=1,QFPTYPE%ILEV(IJ)
        IF (QFPTYPE%ISET(JLEV,IJ)==MYSFSET) THEN
          INC=QFPTYPE%ISPD(JLEV,IJ)
          DO JF=1,INC
            IFLD(ISPB)=ISCA
            IARR(ISPB)=0
            ISPB=ISPB+1
          ENDDO
          ISCA=ISCA+1
        ENDIF
      ENDDO
    CASE (1,2)
!       U or Vor
      DO JLEV=1,QFPTYPE%ILEV(IJ)
        IF (QFPTYPE%ISET(JLEV,IJ)==MYSFSET) THEN
          INC=QFPTYPE%ISPD(JLEV,IJ)
          DO JF=1,INC
            IFLD(ISPB)=IVOR
            IARR(ISPB)=1
            ISPB=ISPB+1
          ENDDO
!           Mean U wind if U and lam
          IF (LLAM .AND. QFPTYPE%ILED(IJ) /= 2) THEN
            UMEAN(IMNU:IMNU+INC-1)=PUMEAN(IVOR)
            IMNU=IMNU+INC
          ENDIF
          IVOR=IVOR+1
!           Skip divergence if Vor :
          IF (QFPTYPE%ILED(IJ) == 2) IDIV=IDIV+1
        ENDIF
      ENDDO
    CASE (:-1,3)
!       V or Div
      DO JLEV=1,QFPTYPE%ILEV(IJ)
        IF (QFPTYPE%ISET(JLEV,IJ)==MYSFSET) THEN
          INC=QFPTYPE%ISPD(JLEV,IJ)
          DO JF=1,INC
            IFLD(ISPB)=IDIV
            IARR(ISPB)=-1
            ISPB=ISPB+1
          ENDDO 
!           Mean V wind if V and lam
          IF (LLAM .AND. QFPTYPE%ILED(IJ) /= 3) THEN
            VMEAN(IMNV:IMNV+INC-1)=PVMEAN(IDIV)
            IMNV=IMNV+INC 
          ENDIF
          IDIV=IDIV+1
!           Skip vorticity if Div :
          IF (QFPTYPE%ILED(IJ) == 3) IVOR=IVOR+1
        ENDIF
      ENDDO
    END SELECT
  ENDIF
ENDDO
IF (ISCA-1 /= NFPSCA) CALL ABOR1('FPTSA_DIR : INTERNAL ERROR ISCA')
IF (IDIV+IVOR-2 /= 2*NFPVEC) CALL ABOR1('FPTSA_DIR : INTERNAL ERROR IDIV+IVOR')
IF (LLAM) THEN
  IF (IMNU+IMNV-2 /= 2*NFPUVMN) CALL ABOR1 &
   & ('FPTSA_DIR : INTERNAL ERROR IMNU/IMNV')  
ENDIF

!      4. Fill spectral post-processing arrays

DO JF=1,NFPSCA
  DO J=1,NFPSPB
    IF (IARR(J)==0) THEN
      IF (JF==IFLD(J)) THEN
        DO JS=1,NSPEC2
          SPBFP(J,JS)=PSCA(JF,JS)
        ENDDO
      ENDIF
    ENDIF 
  ENDDO
ENDDO

DO JF=1,NFPVEC
  DO J=1,NFPSPB
    IF (IARR(J)==1) THEN
      IF (JF==IFLD(J)) THEN
        DO JS=1,NSPEC2
          SPBFP(J,JS)=PVOR(JF,JS)
        ENDDO
      ENDIF
    ENDIF
  ENDDO
ENDDO

DO JF=1,NFPVEC
  DO J=1,NFPSPB
    IF (IARR(J)==-1) THEN
      IF (JF==IFLD(J)) THEN
        DO JS=1,NSPEC2
          SPBFP(J,JS)=PDIV(JF,JS)
        ENDDO
      ENDIF
    ENDIF
  ENDDO
ENDDO

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

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