#ifdef RS6K
@PROCESS NOCHECK
#endif
SUBROUTINE SLEXTPOL(KSLWIDEN,KSLWIDES,KASLB1,KDGSAG,KDGENG,KDGSAL,KDGENL, &
 & KFLDSLB,KSLSTA,KSLONL,KSLOFF,KDGLG,KLOENG,&
 & KFRSTLOFF,KYFRSTACTLAT,KYLSTACTLAT,KFIXFLD,KTYP, &
 & PARSLB,PB1A,KMASK2,KMASK3)

!****-------------------------------------------------------------------
!**** *SLEXTPOL* - Communication for horizontal interpolations: 
!                  Special Pole treatment.

!                  This routine is called only if distributed memory.
!                  Computations are DM-local.
!                  This routine assumes that there are exactly three 
!                  extra-longitudes: jlon=0, jlon=ndlon+1, jlon=ndlon+2.
!****-------------------------------------------------------------------
!     Purpose.
!     --------
!**   Interface.
!     ----------
!        *CALL* *SLEXTPOL(...)*

!        Explicit arguments :
!        --------------------
!        INPUT:
!        - KSLWIDEN   : number of nothern rows required for halo
!        - KSLWIDES   : number of southern rows required for halo
!        - KASLB1     : local inner dimension of interpolation buffer.
!        - KDGSAG     : Global version of KDGSA
!        - KDGENG     : Global version of KDGEN
!        - KDGSAL     : Local version of KDGSA , always 1
!        - KDGENL     : No. of latitude rows for which this proc has grid points
!        - KFLDSLB    : number of fields.
!        - KSLSTA     : interpolation buffer start position of grid columns 
!                       on latitudes.
!        - KSLONL     : interpolation buffer number of grid column on latitudes.
!        - KSLOFF     : interpolation buffer offset to start of each row in
!                       the interpolation buffer.
!        - KDGLG      : number of latitude rows
!        - KLOENG     : Number of grid points per latitude
!        - KFRSTLOFF  : offset for first lat of own a-set in grid-point space,
!                        i.e. kfrstloff=kfrstlat(my_region_ns)-1
!        - KYFRSTACTLAT: first actual lat on this PE in grid-point space,
!                        it is kfrstlat(my_region_ns)
!        - KYLSTACTLAT : last actual lat on this PE in grid-point space,
!                        it is klstlat(my_region_ns)
!        - KFIXFLD    : description of 'fixed' fields (to be processed)
!        - KTYP       : type of communication.
!                       KTYP=1: equivalent of the CY35 version of SLEXTPOL
!                       KTYP=2: equivalent of the CY35 version of SLEXTPOL2
!                       KTYP=3: equivalent of the CY35 version of SLEXTPOL1
!                               if KMASK2 is provided.
!                               equivalent of the CY35 version of SLEXTPOL1A
!                               if KMASK3 is provided.
!        - PARSLB     : parity for extra-polar calculations.

!        INPUT/OUTPUT:
!        - PB1A       : fields to be computed at the extra-polar latitudes.

!        OPTIONAL OUTPUT:
!        At least one of these masks should be present if KTYP=3.
!        - KMASK2     : Mask2 for on demand-comms.
!        - KMASK3     : Mask3 for on demand-comms.

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

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

!     Method.
!     -------

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

!     Author.
!     -------
!       Lars ISAKSEN (ECMWF), OCTOBER 1995.

!     Modifications.
!     --------------
!       K. YESSAD (JAN 1998): 
!        - extension to any value of NDGSUR.
!        - merge with FPEXTPOL: can now be used also for FULL-POS buffers. 
!        - some cleaning.
!       Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!       99-06-21  Remove !OCL SCALAR   D.SALMOND
!       02-10-01  G.Mozdzynski     support for radiation on-demand comms
!       M.Hamrud      01-Oct-2003 CY28 Cleaning
!       K.Yessad  (Oct 2008) Unified version
!     ------------------------------------------------------------------

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

USE YOMLUN   , ONLY : NULOUT

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KSLWIDEN
INTEGER(KIND=JPIM),INTENT(IN)    :: KSLWIDES
INTEGER(KIND=JPIM),INTENT(IN)    :: KASLB1 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGSAG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGENG 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGSAL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KDGENL 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLDSLB 
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)    :: KLOENG(KDGSAG:KDGENG) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFRSTLOFF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KYFRSTACTLAT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KYLSTACTLAT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFIXFLD(2)
INTEGER(KIND=JPIM),INTENT(IN)    :: KTYP
REAL(KIND=JPRB)   ,INTENT(IN)    :: PARSLB(KFLDSLB) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PB1A(KASLB1,KFLDSLB,1) 
INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMASK2(KASLB1+4)
INTEGER(KIND=JPIM),OPTIONAL,INTENT(OUT) :: KMASK3(KASLB1+4)

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

INTEGER(KIND=JPIM) :: IEND, IGLGLO, IGLLOC, IGLSGLO, IGLSLOC, ILFB,&
 & ILPT, ILSB, IPT, IPTF, IST, JFLD, JGLLOC, JLP  

LOGICAL :: LLNOR, LLSUD
INTEGER(KIND=JPIM) :: IJPT
INTEGER(KIND=JPIM) :: IPTA(KASLB1),IJPTA(KASLB1)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"

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

! KTYP=1: equivalent of the old SLEXTPOL
!  (assumes KFIXFLD(1)=1 ,KFIXFLD(2)=KFLDSLB, no mask required).
! KTYP=2: equivalent of the old SLEXTPOL2.
! KTYP=3: equivalent of the old SLEXTPOL1 and SLEXTPOL1A
!  (on-demand communications); requires the calculation of KMASK2 or KMASK3.

IF (PRESENT(KMASK2)) KMASK2(1:KASLB1)=0

!     ** Search through all latitudes within halo region.

ILSB=MAX(KDGSAG,KYFRSTACTLAT-KSLWIDEN)-KFRSTLOFF
ILFB=MIN(KDGENG,KYLSTACTLAT +KSLWIDES)-KFRSTLOFF

!     ** Fix extra data required that has not been communicated:
!        1) pole mimics from core data.
!        2) end of latitude star copies.

IF (KTYP == 1) CALL GSTATS(1133,0)
IF (KTYP == 2) CALL GSTATS(1131,0)
IF (KTYP == 3) CALL GSTATS(1834,0)

DO JGLLOC=ILSB,ILFB

  IGLGLO=JGLLOC+KFRSTLOFF
  LLNOR=(IGLGLO >= KDGSAG).AND.(IGLGLO <= 0)
  LLSUD=(IGLGLO >= KDGLG+1).AND.(IGLGLO <= KDGENG)

  IF (LLNOR.OR.LLSUD) THEN

    IF (LLNOR) IGLSGLO=1-IGLGLO
    IF (LLSUD) IGLSGLO=2*KDGLG+1-IGLGLO

    ! * Local view also required.

    IGLLOC=IGLGLO-KFRSTLOFF
    IGLSLOC=IGLSGLO-KFRSTLOFF

    ! * Determine which mimic points come from this processors core region.

    DO JLP=KSLSTA(IGLLOC),KSLONL(IGLLOC)+KSLSTA(IGLLOC)-1

      ILPT=MOD(JLP-1+KLOENG(IGLGLO),KLOENG(IGLGLO))+1
      IPT =KSLOFF(IGLLOC)+&
       & MOD(ILPT-KSLSTA(IGLLOC)+KLOENG(IGLGLO),KLOENG(IGLGLO))  
      IPTF=KSLOFF(IGLSLOC)+&
       & MOD(ILPT-KSLSTA(IGLSLOC)+KLOENG(IGLSGLO),KLOENG(IGLSGLO))  
      IF(IPT >= KASLB1 .OR. IPT < 1 .OR. IPTF >= KASLB1 .OR. IPTF < 1 ) THEN
        WRITE(NULOUT,'(A,14I8)') ' ***** SLEXTPOL ERROR ***** ',&
         & IPT,IPTF,ILPT,JLP,IGLLOC,IGLGLO,IGLSLOC,&
         & KASLB1,KSLOFF(IGLLOC),KSLOFF(IGLSLOC),&
         & KSLSTA(IGLLOC),KSLSTA(IGLSLOC),&
         & KLOENG(IGLGLO),KLOENG(IGLSGLO)  
        CALL ABOR1(' SLEXTPOL ERROR ')
      ENDIF
     
      ! update only if the polar mimic points are required on this processor

      IF (KTYP == 1) THEN
        IF ( (KSLOFF(IGLSLOC) <= IPTF).AND.&
         & (IPTF <= KSLOFF(IGLSLOC)+KSLONL(IGLSLOC)-1) ) THEN  
          DO JFLD=1,KFLDSLB
            PB1A(IPT+1,JFLD,1)=PB1A(IPTF+1,JFLD,1)
          ENDDO
        ENDIF
        ! The mirrored latitudes close to the poles require correction for
        !  symmetric and antisymmetric properties (PARSLB).
        DO JFLD=1,KFLDSLB
          PB1A(IPT+1,JFLD,1)=PARSLB(JFLD)*PB1A(IPT+1,JFLD,1)
        ENDDO
      ELSEIF (KTYP == 2 .OR. KTYP == 3) THEN
        IJPT=IPT
        IF ( (KSLOFF(IGLSLOC) <= IPTF).AND.&
         & (IPTF <= KSLOFF(IGLSLOC)+KSLONL(IGLSLOC)-1) ) IJPT=IPTF
        IPTA(JLP-KSLSTA(IGLLOC)+1)=IPT
        IJPTA(JLP-KSLSTA(IGLLOC)+1)=IJPT
      ENDIF

    ENDDO

    ! The mirrored latitudes close to the poles require correction for 
    !  symmetric and antisymmetric properties (PARSLB).

    IF (KTYP == 2) THEN
!$OMP PARALLEL PRIVATE(JFLD,JLP)
!$OMP DO SCHEDULE(STATIC)
      DO JFLD=1,KFIXFLD(1)-1
        DO JLP=1,KSLONL(IGLLOC)
          PB1A(IPTA(JLP)+1,JFLD,1)=PARSLB(JFLD)*PB1A(IJPTA(JLP)+1,JFLD,1)
        ENDDO
      ENDDO
!$OMP END DO
!$OMP DO SCHEDULE(STATIC)
      DO JFLD=KFIXFLD(2)+1,KFLDSLB
        DO JLP=1,KSLONL(IGLLOC)
          PB1A(IPTA(JLP)+1,JFLD,1)=PARSLB(JFLD)*PB1A(IJPTA(JLP)+1,JFLD,1)
        ENDDO
      ENDDO
!$OMP END DO
!$OMP END PARALLEL
    ELSEIF (KTYP == 3) THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JLP)
      DO JFLD=KFIXFLD(1),KFIXFLD(2)
        DO JLP=1,KSLONL(IGLLOC)
          PB1A(IPTA(JLP)+1,JFLD,1)=PARSLB(JFLD)*PB1A(IJPTA(JLP)+1,JFLD,1)
        ENDDO
      ENDDO
!$OMP END PARALLEL DO
      IF (PRESENT(KMASK2)) THEN
        DO JLP=1,KSLONL(IGLLOC)
          KMASK2(IJPTA(JLP)+1)=1
        ENDDO
      ENDIF
      IF (PRESENT(KMASK3)) THEN
        DO JLP=1,KSLONL(IGLLOC)
          KMASK3(IJPTA(JLP)+1)=2
        ENDDO
      ENDIF
    ENDIF

  ENDIF

ENDDO
!     ** If complete latitude present we correct for additional points
!        required at start/finish for interpolation star.

IF (KTYP == 1) THEN

!$OMP PARALLEL PRIVATE(JFLD,JGLLOC,IST,IEND)
!$OMP DO SCHEDULE(STATIC)
  DO JGLLOC=ILSB,ILFB
    IF (KLOENG(JGLLOC+KFRSTLOFF) == KSLONL(JGLLOC)) THEN
      IST =KSLOFF(JGLLOC)-1
      IEND=KSLOFF(JGLLOC)+KLOENG(JGLLOC+KFRSTLOFF)
      DO JFLD=1,KFLDSLB
        PB1A(IST +1,JFLD,1)=PB1A(IEND ,JFLD,1)
        PB1A(IEND+1,JFLD,1)=PB1A(IST+2,JFLD,1)
        PB1A(IEND+2,JFLD,1)=PB1A(IST+3,JFLD,1)
      ENDDO
    ENDIF
  ENDDO
!$OMP END DO
!$OMP END PARALLEL

ELSEIF (KTYP == 2) THEN

!$OMP PARALLEL PRIVATE(JFLD,JGLLOC,IST,IEND)
!$OMP DO SCHEDULE(STATIC)
  DO JFLD=1,KFIXFLD(1)-1
    DO JGLLOC=ILSB,ILFB
      IF (KLOENG(JGLLOC+KFRSTLOFF) == KSLONL(JGLLOC)) THEN
        IST =KSLOFF(JGLLOC)-1
        IEND=KSLOFF(JGLLOC)+KLOENG(JGLLOC+KFRSTLOFF)
        PB1A(IST +1,JFLD,1)=PB1A(IEND ,JFLD,1)
        PB1A(IEND+1,JFLD,1)=PB1A(IST+2,JFLD,1)
        PB1A(IEND+2,JFLD,1)=PB1A(IST+3,JFLD,1)
      ENDIF
    ENDDO
  ENDDO
!$OMP END DO
!$OMP DO SCHEDULE(STATIC)
  DO JFLD=KFIXFLD(2)+1,KFLDSLB
    DO JGLLOC=ILSB,ILFB
      IF (KLOENG(JGLLOC+KFRSTLOFF) == KSLONL(JGLLOC)) THEN
        IST =KSLOFF(JGLLOC)-1
        IEND=KSLOFF(JGLLOC)+KLOENG(JGLLOC+KFRSTLOFF)
        PB1A(IST +1,JFLD,1)=PB1A(IEND ,JFLD,1)
        PB1A(IEND+1,JFLD,1)=PB1A(IST+2,JFLD,1)
        PB1A(IEND+2,JFLD,1)=PB1A(IST+3,JFLD,1)
      ENDIF
    ENDDO
  ENDDO
!$OMP END DO
!$OMP END PARALLEL

ELSEIF (KTYP == 3) THEN

!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JGLLOC,IST,IEND)
  DO JFLD=KFIXFLD(1),KFIXFLD(2)
    DO JGLLOC=ILSB,ILFB
      IF (KLOENG(JGLLOC+KFRSTLOFF) == KSLONL(JGLLOC)) THEN
        IST =KSLOFF(JGLLOC)-1
        IEND=KSLOFF(JGLLOC)+KLOENG(JGLLOC+KFRSTLOFF)
        PB1A(IST +1,JFLD,1)=PB1A(IEND ,JFLD,1)
        PB1A(IEND+1,JFLD,1)=PB1A(IST+2,JFLD,1)
        PB1A(IEND+2,JFLD,1)=PB1A(IST+3,JFLD,1)
      ENDIF
    ENDDO
  ENDDO
!$OMP END PARALLEL DO

  DO JGLLOC=ILSB,ILFB
    IF (KLOENG(JGLLOC+KFRSTLOFF) == KSLONL(JGLLOC)) THEN
      IST =KSLOFF(JGLLOC)-1
      IEND=KSLOFF(JGLLOC)+KLOENG(JGLLOC+KFRSTLOFF)
      IF (PRESENT(KMASK2)) THEN
        KMASK2(IEND)=1
        KMASK2(IST+2)=1
        KMASK2(IST+3)=1
      ENDIF
      IF (PRESENT(KMASK3)) THEN
        KMASK3(IEND)=2
        KMASK3(IST+2)=2
        KMASK3(IST+3)=2
      ENDIF
    ENDIF
  ENDDO

ENDIF


IF (KTYP == 1) CALL GSTATS(1133,1)
IF (KTYP == 2) CALL GSTATS(1131,1)
IF (KTYP == 3) CALL GSTATS(1834,1)

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

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