SUBROUTINE SUPROCGP(KPROCGP)

!**** *SUPROCGP*  - Setup processor number - Fullpos

!     PURPOSE.
!     --------
!        To initialize the array telling for each model point which 
!        processor treats this point

!**   INTERFACE.
!     ----------
!       *CALL* *SUPROCGP*

!        EXPLICIT ARGUMENTS
!        --------------------
!         OUTPUT : 
!         KPROCGP : processor number corresponding to each point

!        IMPLICIT ARGUMENTS
!        --------------------
!        See module above

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

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

!     REFERENCE.
!     ----------
!        ECMWF Research Department documentation of the IFS
!        Documentation about FULL-POS.

!     AUTHOR.
!     -------
!        ???

!     MODIFICATIONS.
!     --------------
!        Original     : ??? 
!        R. El Khatib : 98-10-06 Cleanups
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NULOUT
USE YOMCT0   , ONLY : N_REGIONS,N_REGIONS_NS,N_REGIONS_EW
USE YOMDIM   , ONLY : NDGLG
USE YOMGEM   , ONLY : NLOENG   ,NGPTOTG
USE YOMMP    , ONLY : NSTA     ,NONL     ,NFRSTLAT ,NLSTLAT  ,&
 & NPTRFRSTLAT, NPTRLSTLAT ,NGPSET2PE

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(INOUT) :: KPROCGP(NGPTOTG) 
INTEGER(KIND=JPIM) :: IASET, IBSET, IEND, IFIRST, IFRSTGP, IGL1,&
 & IGL2, IGLL, IGLOFF, IGPTOT, IGPTOTT, ILASTGP, &
 & IPROC, IROF, IST, JA, JB, JGL, JGLA, JGLG, &
 & JGP, JLONG  

!     IGPTOTL : Number of model points in each processor

INTEGER(KIND=JPIM) :: IGPTOTL(N_REGIONS_NS,N_REGIONS_EW)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

!     1. Number of model points in each processor
!        ----------------------------------------

IF (LHOOK) CALL DR_HOOK('SUPROCGP',0,ZHOOK_HANDLE)
IGPTOTT = 0
DO JA=1,N_REGIONS_NS
  DO JB=1,N_REGIONS(JA)
    IGPTOT=0
    DO JGL=NPTRFRSTLAT(JA),NPTRLSTLAT(JA)
      IGPTOT=IGPTOT+NONL(JGL,JB)
    ENDDO
    IGPTOTL(JA,JB)=IGPTOT
    IGPTOTT=IGPTOTT + IGPTOTL(JA,JB)
  ENDDO
ENDDO
IF (IGPTOTT  /=  NGPTOTG) THEN
  WRITE(NULOUT,*) 'SUPROCGP : NGPTOTG = ',NGPTOTG
  WRITE(NULOUT,*) 'SUPROCGP : IGPTOTT = ',IGPTOTT
  CALL ABOR1('SUPROCGP : IGPTOTT  /=  NGPTOTG ! ')
ENDIF

!     2. Processor number each model point belongs
!        -----------------------------------------

IF (N_REGIONS_EW == 1) THEN

!       Optimised initialization of array KPROCGP :
  IFRSTGP=1
  DO JA=1,N_REGIONS_NS
    DO JB=1,N_REGIONS(JA)
      IPROC=NGPSET2PE(JA,JB)
      ILASTGP=IFRSTGP + IGPTOTL(JA,JB) - 1
      DO JGP=IFRSTGP,ILASTGP
        KPROCGP(JGP)=IPROC
      ENDDO
      IFRSTGP=ILASTGP+1
    ENDDO
  ENDDO

ELSE      ! N_REGIONS_EW test

!       General case when N_REGIONS_EW > 1
  IROF = 1
  DO JGLG = 1,NDGLG
    DO JLONG = 1,NLOENG(JGLG)

!           find first a-set
      IASET=1
      DO JA=1,N_REGIONS_NS
        IGLOFF=NPTRFRSTLAT(JA)
        IF (JA > 1) THEN
          IF (NLSTLAT(JA-1) == NFRSTLAT(JA)) THEN
            IFIRST=NLSTLAT(JA-1)
            IF (JGLG > IFIRST) THEN
              IASET=JA
            ELSEIF (JGLG == IFIRST) THEN
              DO JB=1,N_REGIONS(JA)
                IF (NONL(IGLOFF,JB) > 0.AND.NSTA(IGLOFF,JB) <= JLONG) THEN
                  IASET=JA
                ENDIF
              ENDDO
            ENDIF
          ELSE
            IFIRST=NLSTLAT(JA-1)+1
            IF (JGLG >= IFIRST) THEN
              IASET=JA
            ENDIF
          ENDIF
        ENDIF
      ENDDO

!           Then find the b-set
      IBSET=-999
      IGLOFF=NPTRFRSTLAT(IASET)
      IGL1  =NFRSTLAT(IASET)
      IGL2  =NLSTLAT (IASET)
      DO JGLA=IGL1,IGL2
        IF (JGLA == JGLG) THEN
          IGLL=JGLA-IGL1+IGLOFF
          DO JB=1,N_REGIONS_EW
            IST=NSTA(IGLL,JB)
            IEND=NSTA(IGLL,JB)+NONL(IGLL,JB)-1
            IF( IST == 0 .OR. IEND == 0 ) CYCLE
            IF (JLONG >= IST.AND.JLONG <= IEND) THEN
              IBSET=JB
            ENDIF
          ENDDO
        ENDIF
      ENDDO

!           Test the validity and setup
      IF (IASET <= 0.OR.IASET > N_REGIONS_NS.OR.&
         & IBSET <= 0.OR.IBSET > N_REGIONS_EW) THEN  
        WRITE(NULOUT,*) 'ERROR COMPUTING KPROCGP'
        CALL ABOR1('SUPROCGP : ABOR1 CALLED')
      ELSE
        IPROC=NGPSET2PE(IASET,IBSET)
        KPROCGP(IROF) = IPROC
        IROF = IROF+1
      ENDIF

    ENDDO
  ENDDO

ENDIF

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