SUBROUTINE PHRSET(CDSL,KSLWIDEN,KSLWIDES,&
 & KASLB1,KSLRPTSUR,KSLSPTSUR,&
 & KSLSTA,KSLONL,KSLOFF,&
 & KDGLG,KDLON,KDGSAG,KDGENG,KDGUXL,KDGUXG,KDGSAL,KDGENL,&
 & KFRSTLOFF,KYFRSTACTLAT,KYLSTACTLAT,&
 & KSTA,KONL,KLOENG,KPTRFRSTLAT,KFRSTLAT,KLSTLAT,&
 & KSLPROCS,KSLRPT,KSLSPT,&
 & KSLSENDPOS,KSLRECVPOS,KSENDPTR,KRECVPTR,KSLCOMM)  

!**** *PHRSET * - Routine to initialize parallel environment
!                 necessary for horizontal interpolations - for Coarse Physics. 
!                 Based on SLRSET but with arguements for halo width in each of the
!                 coordinate directions to conserve memory.
!                 Works with a lateral band of KSLWIDE[N,S,W,E] latitudes in the halo. 

!                 For distributed memory computations are DM-local.
!                 This routine is called only if distributed memory.
!                 Called only if NPROC>1.

!     Purpose.
!     --------
!     initialise communication tables and test for horizontal 
!     interpolations.

!**   Interface.
!     ----------
!        *CALL* *PHRSET *

!        Explicit arguments :
!        --------------------
!         INPUT:
!          CDSL        - two letter code, ex:
!                        'RI': initialisation of environment based on NRIWIDE.
!                        'RO': initialisation of environment based on NROWIDE.
!          KSLWIDEN    - number of grid points required for halo (north)
!          KSLWIDES    - number of grid points required for halo (south)
!          KASLB1      - local inner dimension of interpolation buffer.
!          KSLRPTSUR   - integer > or = KSLRPT already computed in SUSC2.
!          KSLSPTSUR   - integer > or = KSLSPT already computed in SUSC2.
!          KSLSTA      - interpolation buffer start position of grid columns.
!          KSLONL      - interpolation buffer number of grid column on latitudes
!          KSLOFF      - interpolation buffer offset to start of each row in.
!          KDGLG       - number of latitude rows
!          KDLON       - length of a row of latitude near equator
!          KDGSAG      - Global version of NDGSA
!          KDGENG      - Global version of NDGEN
!          KDGUXL      - local last row in C+I zone in distributed memory Aladin
!          KDGUXG      - Global version of NDGUX (to be removed !)
!          KDGSAL      - Local version of NDGSA , always 1
!          KDGENL      - No. of latitude rows for which this process has grid points
!          KSTA        - Position of first grid column for the latitudes on 
!                        a processor
!          KONL        - number of grid columns for the latitudes on a processor
!          KLOENG      - Number of grid points per latitude
!          KPTRFRSTLAT - pointer to the first latitude of each a-set in
!                        NSTA and NONL arrays
!          KFRSTLAT    - first lat of each a-set in grid-point space
!          KLSTLAT     - last lat of each a-set in grid-point space
!          KFRSTLOFF   - offset for first lat of own a-set in grid-point space,
!                        i.e. nfrstloff=nfrstlat(myseta)-1
!          KYFRSTACTLAT- first actual lat on this PE in grid-point space,
!                        it is nfrstlat(myseta)
!          KYLSTACTLAT - last actual lat on this PE in grid-point space,
!                        it is nlstlat(myseta)

!         OUTPUT:
!          KSLPROCS    - number of processors to communicate with.
!          KSLRPT      - dimension for KSLRECVPOS.
!                        The number of columns received from other PE's when
!                        computing the halo for interpolations.
!          KSLSPT      - dimension for KSLSENDPOS.
!                        The number of columns sent to other PE's when
!                        computing the halo for interpolations.
!          KSLSENDPOS  - the addresses within the interpolation buffer
!                        of point sent from this PE.
!          KSLRECVPOS  - the addresses within the interpolation buffer
!                        of point received on this PE.
!          KSENDPTR    - pointer to the first point for each of the PE's
!                        that has to receive interpolation halo-data from
!                        this. Used for addressing KSLSENDPOS().
!          KRECVPTR    - pointer to the first point for each of the PE's
!                        that are sending interpolation halo-data to this PE.
!                        Used for addressing KSLRECVPOS().
!          KSLCOMM     - list of the processors this processor has to
!                        communicate with.

!        Implicit arguments :
!        --------------------

!     Method.
!     -------
!        After RDRSET

!     Externals.
!     ----------
!      MPL_SEND, MPL_RECV.
!      Is called by PHCSET.

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS
!        Documentation about FULL-POS.
!        Documentation about distributed memory.

!     Author.
!     -------
!        Deborah Salmond

!     Modifications.
!     --------------
!     ------------------------------------------------------------------

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

USE YOMMP    , ONLY : NPRCIDS, MYPROC,NGPSET2PE
USE YOMTAG   , ONLY : MTAGSLAG
USE YOMCT0   , ONLY : NPROC, N_REGIONS, N_REGIONS_NS, N_REGIONS_EW ,&
 & LOUTPUT, LMPDIAG, LELAM
USE YOMLUN   , ONLY : NULOUT
USE YOMGEM   , ONLY : NGPTOTG
USE MPL_MODULE , ONLY : MPL_SEND, MPL_RECV

IMPLICIT NONE

!     DUMMY:
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLWIDEN
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLWIDES
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLRPTSUR 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLSPTSUR 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGSAG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGENG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGSAL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGENL 
CHARACTER(LEN=2)  ,INTENT(IN)    :: CDSL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KASLB1 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLSTA(KDGSAL-KSLWIDEN:KDGENL+KSLWIDES) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLONL(KDGSAL-KSLWIDEN:KDGENL+KSLWIDES) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLOFF(KDGSAL-KSLWIDEN:KDGENL+KSLWIDES) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGLG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGUXL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGUXG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFRSTLOFF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KYFRSTACTLAT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KYLSTACTLAT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTA(KDGSAG:KDGENG+N_REGIONS_NS-1,N_REGIONS_EW) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KONL(KDGSAG:KDGENG+N_REGIONS_NS-1,N_REGIONS_EW) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLOENG(KDGSAG:KDGENG) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPTRFRSTLAT(N_REGIONS_NS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFRSTLAT(N_REGIONS_NS) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLSTLAT(N_REGIONS_NS) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KSLPROCS 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KSLRPT 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KSLSPT 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KSLSENDPOS(KSLSPTSUR) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: KSLRECVPOS(KSLRPTSUR) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KSENDPTR(NPROC+1) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KRECVPTR(NPROC+1) 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KSLCOMM(NPROC) 
INTEGER(KIND=JPIM) :: IRTPRO(KASLB1), ISTPRO(2*NGPTOTG)
INTEGER(KIND=JPIM) :: IXTPRO(KASLB1), IXTLAT(KASLB1), IXTLON(KASLB1)
INTEGER(KIND=JPIM) :: ISLBUF(KASLB1), IPPROC(KDLON)
INTEGER(KIND=JPIM) :: IPCNT(NPROC)
INTEGER(KIND=JPIM) :: ICOMBUF(2*NGPTOTG)
INTEGER(KIND=JPIM) :: IRLSTLON(KASLB1),IRLSTLAT(KASLB1)
INTEGER(KIND=JPIM) :: ISLSTLON(2*NGPTOTG),ISLSTLAT(2*NGPTOTG)
INTEGER(KIND=JPIM) :: ISENDNUM(NPROC+1),IRECVNUM(NPROC+1)

INTEGER(KIND=JPIM) :: IDF, IDGENG, IDGENL, IDR, IDS, IFL,&
 & IFRSTASET, IFRSTL, IGF, IGLGLO, IGS, ILAT, &
 & ILATG, ILEN, ILL, ILRECV, ILSTASET, ILSTL, &
 & IOFF, IPASA, IPOS, IPROC, &
 & IREMAX, IREMIN, IRLAT, IRLATG, IRLOAD, IRNC, &
 & IRPT, IRSET, ISEMAX, ISEMIN, ISLAT, ISLOAD, &
 & ISLPROCS, ISLPROCSMX, ISNC, ISPROC, ISPT, &
 & ISSET, ISTA, ITAG, JASET, JD, JGLLOC, JLA, &
 & JLON, JN, JNUM, JR, JROC, JROCB, JS, JVAL  

LOGICAL :: LLNOR, LLSUD
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

!        1. PRELIMINARY INITIALISATIONS.
!        -------------------------------

!     Test NPROC > 1; if NPROC=1 most of the following computations are
!      useless and may abort due to the use of unitialised variables, 
!      the remaining (scalar) useful variables are computed in SLCSET.

IF (LHOOK) CALL DR_HOOK('PHRSET',0,ZHOOK_HANDLE)
IF (NPROC == 1) CALL ABOR1(' PHRSET: NPROC MUST BE > 1 ')

!     Quantities depending on LELAM.

IF (LELAM .AND. (CDSL == 'SL')) THEN
  IDGENL=KDGUXL
  IDGENG=KDGUXG
ELSE
  IDGENL=KDGENL
  IDGENG=KDGENG
ENDIF

!     Set receive list length to zero, and process list to -1.

IRLOAD=0
ISLOAD=0

DO JN=1,KASLB1
  ISLBUF(JN)=-1
ENDDO

!     Determine a-set range of interest, beware of split polar mimics,
!     which might increase the search range.

IFL=MAX(MAX(KDGSAG,KYFRSTACTLAT-KSLWIDEN)-KFRSTLOFF,-KSLWIDEN)
ILL=MIN(MIN(IDGENG,KYLSTACTLAT +KSLWIDES)-KFRSTLOFF,IDGENL+KSLWIDES)
IF (IFL+KFRSTLOFF < KDGSAG .OR. IFL+KFRSTLOFF > IDGENG) THEN
  CALL ABOR1(' PHRSET: IFL IS OUT OF BOUNDS ')
ENDIF
IF (ILL+KFRSTLOFF < KDGSAG .OR. ILL+KFRSTLOFF > IDGENG) THEN
  CALL ABOR1(' PHRSET: ILL IS OUT OF BOUNDS ')
ENDIF

IFRSTASET = 1
DO JASET=1,N_REGIONS_NS
  ILATG = IFL+KFRSTLOFF
  IF(ILATG >= KFRSTLAT(JASET) .AND. ILATG <= KLSTLAT(JASET)) THEN
    IFRSTASET = JASET
    EXIT
  ENDIF
ENDDO
ILSTASET = N_REGIONS_NS
DO JASET=N_REGIONS_NS,1,-1
  ILATG = ILL+KFRSTLOFF
  IF(ILATG >= KFRSTLAT(JASET) .AND. ILATG <= KLSTLAT(JASET)) THEN
    ILSTASET = JASET
    EXIT
  ENDIF
ENDDO

!     Set blocks to loop over. Computes ISLBUF.

DO JASET=IFRSTASET,ILSTASET

!       Determine maximum and minimum extent of data to consider
!       choice between halo and block sizes.

  IFRSTL=MAX(IFL,KFRSTLAT(JASET)-KFRSTLOFF)
  ILSTL =MIN(ILL,KLSTLAT (JASET)-KFRSTLOFF)

  DO JGLLOC=IFL,ILL

    IGLGLO=JGLLOC+KFRSTLOFF

!         Correct for extra-polar latitudes.

    LLNOR=(IGLGLO >= KDGSAG).AND.(IGLGLO <= 0).AND.(.NOT.LELAM)
    LLSUD=(IGLGLO >= KDGLG+1).AND.(IGLGLO <= IDGENG).AND.(.NOT.LELAM)
    IF (LLNOR) THEN
      ILAT=1-IGLGLO-KFRSTLOFF
    ELSEIF (LLSUD) THEN
      ILAT=2*KDGLG+1-IGLGLO-KFRSTLOFF
    ELSE
      ILAT=JGLLOC
    ENDIF

!         Check within current range.

    IF (IFRSTL <= ILAT.AND.ILAT <= ILSTL) THEN
      IF (KSLONL(JGLLOC) /= 0) THEN
        ILATG=KPTRFRSTLAT(JASET)+ILAT+KFRSTLOFF-KFRSTLAT(JASET)
        DO JLON=1,KDLON
          IPPROC(JLON)=0
        ENDDO
        DO JROCB=1,N_REGIONS(JASET)
          IPROC=NGPSET2PE(JASET,JROCB)
          IGS=KSTA(ILATG,JROCB)
          IGF=IGS+KONL(ILATG,JROCB)-1
          DO JLA=IGS,IGF
            IPPROC(JLA)=IPROC
          ENDDO
        ENDDO

!             Now set ISLBUF to contain processor numbers

        IDS=KSLSTA(JGLLOC)
        IDF=KSLONL(JGLLOC)+IDS-1
        ISTA=KSLOFF(JGLLOC)
        DO JLA=IDS,IDF
          IPASA=MOD(JLA-1+KLOENG(IGLGLO),KLOENG(IGLGLO))+1
          IF (IPPROC(IPASA) > 0) THEN
            ISLBUF(JLA-IDS+ISTA+1)=IPPROC(IPASA)
          ENDIF
        ENDDO
      ENDIF
    ENDIF

  ENDDO

ENDDO

!     Computes arrays IXTPRO, IXTLAT, IXTLON.

DO JGLLOC=IFL,ILL
  IGLGLO=JGLLOC+KFRSTLOFF
  IDS=KSLSTA(JGLLOC)
  IDF=KSLONL(JGLLOC)+IDS-1
  IF (KSLONL(JGLLOC) /= 0) THEN
    ISTA=KSLOFF(JGLLOC)
    DO JD=IDS,IDF
      ISPROC=ISLBUF(JD-IDS+ISTA+1)
      IF (ISPROC /= MYPROC) THEN
        IDR=MOD(JD-1+KLOENG(IGLGLO),KLOENG(IGLGLO))+1
        IRLOAD=IRLOAD+1
        IF( IRLOAD > KASLB1 )THEN
          CALL ABOR1(' PHRSET IXT ARRAYS TOO SMALL')
        ENDIF
        IXTPRO(IRLOAD)=ISPROC
        IXTLAT(IRLOAD)=IGLGLO
        IXTLON(IRLOAD)=IDR
      ENDIF
    ENDDO
  ENDIF
ENDDO

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

!        2. COMPUTES IPCNT, IRTPRO, IRLSTLAT AND IRLSTLON.
!        -------------------------------------------------

!     Send receive list (lat,lon) to sending processors, but first
!     get receive list into ascending processor order.

DO JROC=1,NPROC
  IPCNT(JROC)=0
ENDDO

DO JVAL=1,IRLOAD
  IPCNT(IXTPRO(JVAL))=IPCNT(IXTPRO(JVAL))+1
ENDDO

DO JROC=1,NPROC
  IF (IPCNT(JROC) > KASLB1) THEN
    CALL ABOR1(' PHRSET: KASLB1 HAS AN INSUFFICIENT VALUE ')
  ENDIF
ENDDO

IOFF=0
DO JROC=1,NPROC
  IF (IPCNT(JROC) /= 0) THEN
    DO JVAL=1,IRLOAD
      IF (IXTPRO(JVAL) == JROC) THEN
        IOFF=IOFF+1
        IF( IOFF > KASLB1 )THEN
          CALL ABOR1(' PHRSET IRT/IRLST ARRAYS TOO SMALL')
        ENDIF
        IRTPRO  (IOFF)=IXTPRO(JVAL)
        IRLSTLAT(IOFF)=IXTLAT(JVAL)
        IRLSTLON(IOFF)=IXTLON(JVAL)
      ENDIF
    ENDDO
  ENDIF
ENDDO

!     Optional prints

IF (LOUTPUT.AND.LMPDIAG) THEN
  WRITE(NULOUT,*) ' BUFFER SIZE IRLOAD: ',IRLOAD
! DO JVAL=1,IRLOAD
!   WRITE(NULOUT,FMT='(1X,A8,I4,1X,I4,1X,I4,1X,I4)')&
!    &' RTABLE ',JVAL,IRTPRO(JVAL),&
!    &IRLSTLAT(JVAL),IRLSTLON(JVAL)
! ENDDO
  CALL FLUSH(NULOUT)
ENDIF

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

!        3. COMPUTES ISLOAD, ISTPRO, ISLSTLAT AND ISLSTLON.
!        --------------------------------------------------

!     Now send recv list to processors my processor wants halo data from,
!     for other processors send a one word message to indicate no halo
!     data required.

IOFF=0
DO JROC=1,NPROC
  IF (IPCNT(JROC) /= 0) THEN
    IPOS=0
    DO JR=1,IPCNT(JROC)
      IOFF=IOFF+1
      IPOS=IPOS+1
      ICOMBUF(IPOS)=IRLSTLAT(IOFF)
      IPOS=IPOS+1
      ICOMBUF(IPOS)=IRLSTLON(IOFF)
    ENDDO
    ITAG=MTAGSLAG
    CALL MPL_SEND(ICOMBUF(1:IPOS),KDEST=NPRCIDS(JROC),KTAG=ITAG, &
     & CDSTRING='PHRSET:')  
  ELSE
    ITAG=MTAGSLAG
    ICOMBUF(1)=-999999999
    CALL MPL_SEND(ICOMBUF(1:1),KDEST=NPRCIDS(JROC),KTAG=ITAG, &
     & CDSTRING='PHRSET:')  
  ENDIF
ENDDO

!     Now receive send list.

DO JROC=1,NPROC
  ITAG=MTAGSLAG
  ILEN=NGPTOTG*2
  CALL MPL_RECV(ICOMBUF(1:ILEN),KSOURCE=NPRCIDS(JROC),&
   & KTAG=ITAG,KOUNT=ILRECV,CDSTRING='PHRSET:')  
  IF ( ILRECV > 1 ) THEN
    IF ( MOD(ILRECV,2) /= 0 ) THEN
      CALL ABOR1(' PHRSET: MESSAGE LENGTH NOT A MULTIPLE OF 2')
    ENDIF
    IF ( ILRECV > 2*NGPTOTG ) THEN
      CALL ABOR1(' PHRSET: MESSAGE LENGTH TOO BIG ')
    ENDIF
    IPOS=0
    DO JS=1,ILRECV/2
      ISLOAD=ISLOAD+1
      IF ( ISLOAD > 2*NGPTOTG ) THEN
        CALL ABOR1(' PHRSET: IST/ISLST ARRAYS TOO SMALL')
      ENDIF
      ISTPRO(ISLOAD)=JROC
      IPOS=IPOS+1
      ISLSTLAT(ISLOAD)=ICOMBUF(IPOS)
      IPOS=IPOS+1
      ISLSTLON(ISLOAD)=ICOMBUF(IPOS)
    ENDDO
  ENDIF
ENDDO

!     Optional prints

IF (LOUTPUT.AND.LMPDIAG) THEN
  WRITE(NULOUT,*) ' BUFFER SIZE ISLOAD: ',ISLOAD
! DO JVAL=1,ISLOAD
!   WRITE(NULOUT,FMT='(1X,A8,I4,1X,I4,1X,I4,1X,I4)')&
!    &' STABLE ',JVAL,ISTPRO(JVAL),&
!    &ISLSTLAT(JVAL),ISLSTLON(JVAL)
! ENDDO
  CALL FLUSH(NULOUT)
ENDIF

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

!        4. COMPUTES ISENDNUM AND IRECVNUM; FINAL PRINTS.
!        ----------------------------------------------------

!     Sort into table pointers.

DO JROC=1,NPROC+1
  ISENDNUM(JROC)=0
  IRECVNUM(JROC)=0
ENDDO

DO JVAL=1,ISLOAD
  ISENDNUM(ISTPRO(JVAL))=ISENDNUM(ISTPRO(JVAL))+1
ENDDO

DO JVAL=1,IRLOAD
  IRECVNUM(IRTPRO(JVAL))=IRECVNUM(IRTPRO(JVAL))+1
ENDDO

IRPT=1
ISPT=1
ISEMAX=-1
ISEMIN=ISLOAD
IREMAX=-1
IREMIN=IRLOAD
IRNC=0
ISNC=0

DO JROC=1,NPROC
  IF (LOUTPUT.AND.LMPDIAG) WRITE(NULOUT,*) ' PROCESSOR ',MYPROC,&
   & JROC,' SENDS ',ISENDNUM(JROC),' RECVS ',IRECVNUM(JROC)  

  IF (IRECVNUM(JROC) > 0) THEN
    IRNC=IRNC+1
    IF (IRECVNUM(JROC) > IREMAX) IREMAX=IRECVNUM(JROC)
    IF (IRECVNUM(JROC) < IREMIN) IREMIN=IRECVNUM(JROC)
  ENDIF
  IF (ISENDNUM(JROC) > 0) THEN
    ISNC=ISNC+1
    IF (ISENDNUM(JROC) > ISEMAX) ISEMAX=ISENDNUM(JROC)
    IF (ISENDNUM(JROC) < ISEMIN) ISEMIN=ISENDNUM(JROC)
  ENDIF
  IRSET=IRPT
  IRPT=IRPT+IRECVNUM(JROC)
  IRECVNUM(JROC)=IRSET
  ISSET=ISPT
  ISPT=ISPT+ISENDNUM(JROC)
  ISENDNUM(JROC)=ISSET
ENDDO
IRECVNUM(NPROC+1)=IRPT
ISENDNUM(NPROC+1)=ISPT
KSLRPT=IRPT-1
KSLSPT=ISPT-1

IF (LOUTPUT.AND.LMPDIAG) THEN
  WRITE(NULOUT,*) ' MINFO TOTAL SEND SIZE ',ISPT
  WRITE(NULOUT,*) ' MINFO TOTAL RECV SIZE ',IRPT
  WRITE(NULOUT,*) ' MINFO SEND ',ISNC,' MAX/MIN ',ISEMAX,ISEMIN
  WRITE(NULOUT,*) ' MINFO RECV ',IRNC,' MAX/MIN ',IREMAX,IREMIN

  DO JROC=1,NPROC+1
    WRITE(NULOUT,*) ' PROCESSOR POINTER ',MYPROC,JROC,' SENDS ',&
     & ISENDNUM(JROC),' RECVS ',IRECVNUM(JROC)  
  ENDDO
  CALL FLUSH(NULOUT)
ENDIF

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

!        5. COMPUTES KSLPROCS AND QUANTITIES DEPENDING ON KSLPROCS.
!        ----------------------------------------------------------

!     Determine how many processors we need to communicate with.
!     Initialise KSLCOMM data structure to contain the list of processors
!     we need to communicate with (either send or receive).

ISLPROCS=0
DO JROC=1,NPROC
  IF( IRECVNUM(JROC+1)-IRECVNUM(JROC) > 0.OR.&
     & ISENDNUM(JROC+1)-ISENDNUM(JROC) > 0 )THEN  
    ISLPROCS=ISLPROCS+1
    KSLCOMM(ISLPROCS)=JROC
    KRECVPTR(ISLPROCS+1)=IRECVNUM(JROC+1)
    KRECVPTR(ISLPROCS)=IRECVNUM(JROC)
    KSENDPTR(ISLPROCS+1)=ISENDNUM(JROC+1)
    KSENDPTR(ISLPROCS)=ISENDNUM(JROC)
  ENDIF
ENDDO
KSLPROCS=ISLPROCS

!     If the requested point is on a polar mimic latitude, the data is
!     extracted from a latitude within the real range 1 to KDGLG (ISLAT).

DO JNUM=1,KSENDPTR(KSLPROCS+1)-1
  IGLGLO=ISLSTLAT(JNUM)
  LLNOR=(IGLGLO >= KDGSAG).AND.(IGLGLO <= 0).AND.(.NOT.LELAM)
  LLSUD=(IGLGLO >= KDGLG+1).AND.(IGLGLO <= IDGENG).AND.(.NOT.LELAM)
  IF (LLNOR) THEN
    ISLAT=1-IGLGLO-KFRSTLOFF
  ELSEIF (LLSUD) THEN
    ISLAT=2*KDGLG+1-IGLGLO-KFRSTLOFF
  ELSE
    ISLAT=IGLGLO-KFRSTLOFF
  ENDIF
  KSLSENDPOS(JNUM)=KSLOFF(ISLAT)+ISLSTLON(JNUM)-KSLSTA(ISLAT)+1
ENDDO

DO JNUM=1,KRECVPTR(KSLPROCS+1)-1
  IRLATG=IRLSTLAT(JNUM)
  IRLAT=IRLATG-KFRSTLOFF
  KSLRECVPOS(JNUM)= MOD(IRLSTLON(JNUM)-KSLSTA(IRLAT)+&
   & KLOENG(IRLATG),KLOENG(IRLATG))+KSLOFF(IRLAT)+1  
ENDDO

!     Find out the maximum of KSLPROCS over all processors on master
!     processor and update on all processors.

IF( MYPROC == 1 )THEN
  ISLPROCSMX=KSLPROCS
  ITAG=MTAGSLAG+1
  DO JROC=2,NPROC
    CALL MPL_RECV(ICOMBUF(1:1),KSOURCE=NPRCIDS(JROC),&
     & KTAG=ITAG,CDSTRING='PHRSET:')  
    ISLPROCSMX=MAX(ISLPROCSMX,ICOMBUF(1))
  ENDDO
  ITAG=MTAGSLAG+2
  ICOMBUF(1)=ISLPROCSMX
  DO JROC=2,NPROC
    CALL MPL_SEND(ICOMBUF(1:1),KDEST=NPRCIDS(JROC),KTAG=ITAG, &
     & CDSTRING='PHRSET:')  
  ENDDO
ELSE
  ITAG=MTAGSLAG+1
  ICOMBUF(1)=KSLPROCS
  CALL MPL_SEND(ICOMBUF(1:1),KDEST=NPRCIDS(1),KTAG=ITAG, &
   & CDSTRING='PHRSET:')  
  ITAG=MTAGSLAG+2
  CALL MPL_RECV(ICOMBUF(1:1),KSOURCE=NPRCIDS(1),&
   & KTAG=ITAG,CDSTRING='PHRSET:')  
  ISLPROCSMX=ICOMBUF(1)
ENDIF

IF( ISLPROCSMX <= 0 )THEN
  CALL ABOR1(' PHRSET: ERROR, ISLPROCSMX <= 0')
ENDIF

IF (LOUTPUT) THEN
  WRITE(NULOUT,'(" PHRSET: N",A2,"PROCS=",I6)') CDSL,KSLPROCS
  WRITE(NULOUT,'(" PHRSET: N",A2,"RPT=",I9)') CDSL,KSLRPT
  WRITE(NULOUT,'(" PHRSET: N",A2,"SPT=",I9)') CDSL,KSLSPT
  WRITE(NULOUT,'(" PHRSET: N",A2,"COMM=")') CDSL
  WRITE(NULOUT,'(10(1X,I6))') KSLCOMM(1:KSLPROCS)
  IF (LMPDIAG) THEN
    WRITE(NULOUT,'(" PHRSET: N",A2,"SENDPOS=")') CDSL
    WRITE(NULOUT,'(10(1X,I6))') KSLSENDPOS(1:KSLSPT)
    WRITE(NULOUT,'(" PHRSET: N",A2,"RECVPOS=")') CDSL
    WRITE(NULOUT,'(10(1X,I6))') KSLRECVPOS(1:KSLRPT)
  ENDIF
  IF (CDSL == 'SL') THEN
    WRITE(NULOUT,'(" PHRSET: NSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: NRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'AD') THEN
    WRITE(NULOUT,'(" PHRSET: NSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: NRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'FP') THEN
    WRITE(NULOUT,'(" PHRSET: NFPSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: NFPRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'RI') THEN
    WRITE(NULOUT,'(" PHRSET: NRISENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: NRIRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'RO') THEN
    WRITE(NULOUT,'(" PHRSET: NROSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: NRORECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'PI') THEN
    WRITE(NULOUT,'(" PHRSET: DYN_SL%NSLSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: DYN_SL%NSLRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ELSEIF (CDSL == 'PO') THEN
    WRITE(NULOUT,'(" PHRSET: PHYS_SL%NSLSENDPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KSENDPTR(1:KSLPROCS+1)
    WRITE(NULOUT,'(" PHRSET: PHYS_SL%NSLRECVPTR=")')
    WRITE(NULOUT,'(10(1X,I6))') KRECVPTR(1:KSLPROCS+1)
  ENDIF
  IF (LMPDIAG) CALL FLUSH(NULOUT)
ENDIF

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

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