SUBROUTINE PKSURFA (KN,P2,KL,P3)

!     *PKSURFA*  - PACK SURFACE DATA THROUGH ARPEGE FILE

!     PURPOSE.
!     --------
!        To pack model surface fields by writing to, then reading from a file
!        ARPEGE.
!        Fields are distributed between the processors ; each processor
!        performs its own loop on fields to write & read back on a local file.

!     INTERFACE.
!     ----------
!       *CALL* *PKSURFA*

!        EXPLICIT ARGUMENTS
!        --------------------
!        KN   - number of fields in data 
!        P2    - data array

!        IMPLICIT ARGUMENTS
!        ------------------

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

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

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

!     AUTHOR.
!     -------
!        RYAD EL KHATIB *METEO-FRANCE*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 16-Oct-2006
!     Apr 2008  K. Yessad: use DISGRID instead of DISGRID_C + cleanings
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMLUN   , ONLY : NSCRTCH  ,NULOUT
USE YOMOP    , ONLY : CNMCA
USE YOMCT0   , ONLY : NPROC    ,LOUTPUT
USE YOMMP    , ONLY : MYPROC
USE YOMDIM    ,ONLY : NPROMA
USE YOMGEM   , ONLY : NGPTOT   ,NGPTOTG

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

IMPLICIT NONE

INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KN 
INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KL
REAL(KIND=JPRB)   ,INTENT(INOUT), OPTIONAL :: P2(:,:,:)
REAL(KIND=JPRB)   ,INTENT(INOUT), OPTIONAL :: P3(:,:,:,:)

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

INTEGER(KIND=JPIM), PARAMETER :: JPFAOVRSZ=2

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

!     IASPIO(j): Processor number which packs fields #j
!     IFIELDS  : Number of fields packed by MYPROC
!     ZREALG   : global array of fields
!     ZREALL   : local  array of fields

REAL(KIND=JPRB),ALLOCATABLE :: ZREALG(:,:),ZREALL(:,:)
REAL(KIND=JPRB) :: ZVALCO(NGPTOTG+JPFAOVRSZ)
INTEGER(KIND=JPIM), ALLOCATABLE :: IASPIO(:)
INTEGER(KIND=JPIM) :: IEND, IFIELDS, IPCT, IREP, IST, JL, II, IFLDS
INTEGER(KIND=JPIM) :: JF, JKGLO, JROF,INBARI, INOMA, ILONGA
CHARACTER(LEN=16) :: CLSCRTCH, CLNOMA

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "disgrid.intfb.h"
#include "diwrgrid.intfb.h"
#include "abor1.intfb.h"

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('PKSURFA',0,ZHOOK_HANDLE)
!     ------------------------------------------------------------------

!        1.  CONTROL ARGUMENTS
!            -----------------

IF (.NOT.PRESENT(KN)) CALL ABOR1('PKSURFA: MISSING KN')
IF (.NOT.PRESENT(P2).AND..NOT.PRESENT(P3)) CALL ABOR1('PKSURFA: MISSING DATA P2 OR P3')
IF (PRESENT(P2).AND.PRESENT(P3)) CALL ABOR1('PKSURFA: DATA P2 OR P3 ARE EXCLUSIVE')
IF (PRESENT(P3).AND..NOT.PRESENT(KL)) CALL ABOR1('PKSURFA: MISSING KL')
IF (PRESENT(P2)) THEN
  IFLDS=KN
ELSE
  IFLDS=KN*KL
ENDIF

!        2.  DISTRIBUTE FIELDS
!            -----------------

ALLOCATE(IASPIO(IFLDS))
DO JF=1,IFLDS
  IASPIO(JF)=MOD(JF-1,NPROC)+1
ENDDO
IFIELDS=0
DO JF=1,IFLDS
  IF (IASPIO(JF) == MYPROC) THEN
    IFIELDS=IFIELDS+1
  ENDIF
ENDDO
IF (LOUTPUT) THEN
  WRITE(NULOUT,*) 'PKSURFA : IFIELDS = ',IFIELDS, ' IASPIO = '
  WRITE(NULOUT,'(15(1X,I4))') IASPIO
ENDIF

!        3.  OPEN A SCRATCH FILE ARPEGE
!            --------------------------

IF (IFIELDS > 0) THEN
  CALL FANOUV(IREP,NSCRTCH,.FALSE.,CLSCRTCH,'NEW',.TRUE.,.TRUE.,1,1,INBARI,&
   & CNMCA)  
ENDIF

!        4.  PACK DATA THROUGH WRITE AND READ
!            --------------------------------

ALLOCATE(ZREALL(NGPTOT,IFLDS))
ALLOCATE(ZREALG(NGPTOTG,1))

!        4.1 Extract all fields to pack and send those I do not pack

IST=1
DO JKGLO=1,NGPTOT,NPROMA
  IEND=MIN(NPROMA,NGPTOT-JKGLO+1)
  IPCT=(JKGLO-1)/NPROMA + 1
  DO JF=1,KN
    IF (PRESENT(P2)) THEN
      DO JROF=IST,IEND
        ZREALL(JROF+JKGLO-1,JF)=P2(JROF,JF,IPCT)
      ENDDO
    ELSE
      DO JL=1,KL
        II=KL*(JF-1)+JL
        DO JROF=IST,IEND
          ZREALL(JROF+JKGLO-1,II)=P3(JROF,JL,JF,IPCT)
        ENDDO
      ENDDO
    ENDIF
  ENDDO
ENDDO

DO JF=1,IFLDS
  IF (IASPIO(JF) /= MYPROC) THEN
    CALL DIWRGRID(IASPIO(JF),JF,0,NGPTOT,ZREALL(1,JF))
  ENDIF
ENDDO

!        4.2 Receive, pack and send back the fields I pack

DO JF=1,IFLDS
  IF (IASPIO(JF) == MYPROC) THEN
    ZREALG(1:NGPTOT,1)=ZREALL(1:NGPTOT,JF)
    CALL DIWRGRID(IASPIO(JF),JF,1,NGPTOTG,ZREALG)
    CALL FACOND(IREP,NSCRTCH,'S',0,'FIELD',ZREALG(1,1),.FALSE.,CLNOMA,INOMA,&
     & ZVALCO,ILONGA)  
    CALL FADECO(IREP,NSCRTCH,'S',0,'FIELD',.FALSE.,CLNOMA,INOMA,ZVALCO,&
     & ILONGA,ZREALG(1,1))  
    CALL DISGRID(JF,0,NGPTOTG,ZREALG(1,1),LDC=.TRUE.,KIOPROC=IASPIO(JF))
    ZREALL(1:NGPTOT,JF)=ZREALG(1:NGPTOT,1)
  ENDIF
ENDDO

!        4.3 Receive fields I have not packed and include back all fields

DO JF=1,IFLDS
  IF (IASPIO(JF) /= MYPROC) THEN
    CALL DISGRID(JF,1,NGPTOT,ZREALL(1,JF),LDC=.TRUE.,KIOPROC=IASPIO(JF))
  ENDIF
ENDDO

IST=1
DO JKGLO=1,NGPTOT,NPROMA
  IEND=MIN(NPROMA,NGPTOT-JKGLO+1)
  IPCT=(JKGLO-1)/NPROMA + 1
  DO JF=1,KN
    IF (PRESENT(P2)) THEN
      DO JROF=IST,IEND
        P2(JROF,JF,IPCT)=ZREALL(JROF+JKGLO-1,JF)
      ENDDO
    ELSE
      DO JL=1,KL
        II=KL*(JF-1)+JL
        DO JROF=IST,IEND
          P3(JROF,JL,JF,IPCT)=ZREALL(JROF+JKGLO-1,II)
        ENDDO
      ENDDO
    ENDIF
  ENDDO  
ENDDO

DEALLOCATE(ZREALL)
DEALLOCATE(ZREALG)

!        5.  CLOSE AND DELETE THE SCRATCH FILE
!            ---------------------------------

IF (IFIELDS > 0) THEN
  CALL FAIRNO(IREP,NSCRTCH,'DELETE')
ENDIF
DEALLOCATE(IASPIO)

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('PKSURFA',1,ZHOOK_HANDLE)
END SUBROUTINE PKSURFA
