!OPTION! -pvctl noouterunroll -pvctl noouterstrip
SUBROUTINE FPMODPREC(KGP,YD_PGPBUF,KFLDPTP)

!**** *FPMODPREC*  - MODIFY PRECIPITATION FIELDS FOR POST-PROCESSING

!     PURPOSE.
!     --------
!        To modify precipitation fields before horizontal post-processing.

!**   INTERFACE.
!     ----------
!       *CALL* *FPMODPREC*

!        EXPLICIT ARGUMENTS
!        --------------------

!        INPUT:
!        KGP       - number of fields to modify
!        KFLDPTP   - array of field pointers for extraction

!        INPUT/OUTPUT:
!        YD_PGPBUF - memory buffer (used in case of no real IO)

!        IMPLICIT ARGUMENTS
!        --------------------
!        See above 'use yom...'.

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

!     EXTERNALS.
!     ----------
!      * Is called by FPMODCFU and FPMODXFU.

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

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

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 96-08-06
!        K. YESSAD (APRIL 1997): parallelisation of FULL-POS.
!        R. El Khatib 98-01-12 : Fullpos Aladin DM
!        R. El Khatib 98-02-06 : Several changes.
!        K. YESSAD (JAN 1998): merge of some FULL-POS and SL routines
!          relative to the halo.
!          - call to FPEXTPOL replaced by call to SLEXTPOL.
!          - call to FPREAD+FPWRIT replaced by call to SLCOMM.
!          - call to FPADD3P replaced by a simple memory transfer.
!        R. El Khatib 98-07-24 : enable LSPLIT=.TRUE.
!        Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!         - INIPEX looses one argument.
!         - for SM INCR is now zero: of course ZREAL does not contain any
!           polar value and non polar values are stored in the elements
!           1 to NGPTOTG.
!        R. El Khatib 98-12-15 : cleanups
!    R. El Khatib : 99-12-28 remove poles rows
!    R. El Khatib : 00-11-03 Optional communications in extgpf
!    G.Mozdzynski : 02-10-01 support for radiation on-demand comms
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      10-Jan-2004 CY28R1 Cleaning
!   R. El Khatib  20-May-2005 NFPWIDE moved to YOMWFPDS
!   R. El Khatib  17-Oct-2008 bf for ALADIN fullpos with equal distribution
!                             of C+I+E (RDISTR_E=1.)
!   K. Yessad Dec 2008: merge SLCOMM+SLCOMM1 -> SLCOMM.
!   K. Yessad Dec 2008: merge the different (E)SLEXTPOL.. -> (E)SLEXTPOL.
!      E. Sevault 18-May-2009 : SX9 compiler workaround : optimisations
!            "outerunroll" and "outerstrip" manually switched off to prevent
!            unexpected numerical variations. Note that this workaround may
!            be irrelevent when the source code of this subroutine is deeply 
!            re-written.
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCT0   , ONLY : NPROC    ,LELAM
USE YOMDIM   , ONLY : NDGLG    ,NDGUXG   ,NDLUXG   ,NDGSAL    ,&
 & NPROMA   ,NDGENL  ,NDGSAG   ,NDGENG  
USE YOMGEM   , ONLY : NLOENG   ,NGPTOT   ,NGPTOT_CAP
USE YOMWFPDS , ONLY : NFPWIDE
USE YOMMP    , ONLY : MY_REGION_EW   ,NSTA     ,NONL     ,&
 & NFPSTA   ,NFPONL   ,NFPOFF   ,NFPEXT   ,NAFPB1   ,&
 & NFRSTLOFF,NPTRFLOFF,NFPCOMM  ,&
 & NFPPROCS ,NFPRPT  ,NFPSPT   ,&
 & NFPSENDPOS,NFPRECVPOS,NFPSENDPTR,NFPRECVPTR,&
 & NFPCORE,&
 & MYFRSTACTLAT,MYLSTACTLAT  
USE GRIDPOINT_BUFFERS_MIX , ONLY : gridpoint_buffer
USE YOMFPG  , ONLY : LFPOSBUF

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

IMPLICIT NONE

TYPE(GRIDPOINT_BUFFER),INTENT(INOUT) :: YD_PGPBUF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KGP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLDPTP(YD_PGPBUF%IFIELDS) 

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

INTEGER(KIND=JPIM) :: INBTOPG(NDGLG), INBBOTG(NDGLG)
INTEGER(KIND=JPIM) :: ILAT(NGPTOT),ILON(NGPTOT),ILOTOP(NGPTOT),ILOBOT(NGPTOT)
INTEGER(KIND=JPIM) :: IL0(NPROMA,0:2)
REAL(KIND=JPRB) :: ZLON(NGPTOT), ZWTOP(NGPTOT), ZWBOT(NGPTOT)
REAL(KIND=JPRB) :: ZPARFP1(KGP)
REAL(KIND=JPRB) :: ZGPP(NPROMA,YD_PGPBUF%IFIELDS)
REAL(KIND=JPRB) :: ZDATAI(NAFPB1,KGP)

INTEGER(KIND=JPIM) :: IB, IEND, IFLDPTP, IGLG, IGLO, ILEN, IROF, IST
INTEGER(KIND=JPIM) :: JF, JGL, ILA2G, ILO
INTEGER(KIND=JPIM) :: JKGLO, JLON, JROF, ILA0, ILA0G, ILA1, ILA1G, ILA2
INTEGER(KIND=JPIM) :: ILO1, ILO2, IROF0, IDUMARR(2)
INTEGER(KIND=JPIM) :: IGPCOMP

REAL(KIND=JPRB) :: ZRATIO
REAL(KIND=JPRB) :: Z0, ZVAL0, ZVALE, ZVALN, ZVALNE, ZVALNW, ZVALS, ZVALSE
REAL(KIND=JPRB) :: ZVALW, ZVALX, ZVALSW
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!     INBTOPG: number of neighbour points on top for each latitude
!     INBBOTG: number of neighbour points on bottom for each latitude
!     ILOTOP : local longitude index of nearest top left point
!     ILOBOT : local longitude index of nearest bottom left point
!     IWTOP  : weight of nearest top left point
!     IWBOT  : weight of nearest bottom left point
!     ZLON   : (work array) longitude abcissa (real) 
!               of the current point on top (bottom) row 
!     ILAT   : current local latitude index
!     ILON   : current local longitude index

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

#include "sc2rdg.intfb.h"
#include "sc2wrg.intfb.h"
#include "slcomm.intfb.h"
#include "slextpol.intfb.h"
#include "eslextpol.intfb.h"

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

!*       1. FIND NEIGHBOUR POINTS
!           ---------------------

! Changed NGPTOT into IGPCOMP in order to pass properly
! the scan of NFPCORE values for the LAM models
IF (LELAM.AND.LFPOSBUF) THEN
  IGPCOMP=MIN(NGPTOT,NGPTOT_CAP)
ELSE
  IGPCOMP=NGPTOT
ENDIF

INBTOPG(1)=1
DO JGL=2,NDGLG
  IF (NLOENG(JGL-1) == NLOENG(JGL)) THEN
    INBTOPG(JGL)=1
  ELSE
    INBTOPG(JGL)=2
  ENDIF
ENDDO
DO JGL=1,NDGLG-1
  IF (NLOENG(JGL+1) == NLOENG(JGL)) THEN
    INBBOTG(JGL)=1
  ELSE
    INBBOTG(JGL)=2
  ENDIF
ENDDO
INBBOTG(NDGLG)=1

IB=MY_REGION_EW
IROF0=0
! Loop on all the local latitudes + the possible split ones
DO JGL=1,NDGENL
  IGLG=JGL+NFRSTLOFF ! global adressing for latitudes
  IGLO=JGL+NPTRFLOFF ! global adressing for NSTA, NONL including lat. splitting
  ILEN=NONL(IGLO,IB)
  IROF=IROF0
  DO JLON=NSTA(IGLO,IB),NSTA(IGLO,IB)+ILEN-1
    IROF=IROF+1
    ILAT(IROF)=JGL
    ILON(IROF)=JLON
  ENDDO
  IROF=IROF0
  IF (INBTOPG(IGLG) == 1) THEN
    DO JLON=NSTA(IGLO,IB),NSTA(IGLO,IB)+ILEN-1
      IROF=IROF+1
      ILOTOP(IROF)=JLON
      ZWTOP (IROF)=1.0_JPRB
    ENDDO
  ELSE
    ZRATIO=REAL(NLOENG(MAX(IGLG-1,1)),JPRB)/REAL(NLOENG(IGLG),JPRB)
    DO JLON=NSTA(IGLO,IB),NSTA(IGLO,IB)+ILEN-1
      IROF=IROF+1
      ZLON  (IROF)=REAL(JLON-1,JPRB)*ZRATIO + 1.0_JPRB
      ILOTOP(IROF)=INT(ZLON(IROF))
      ZWTOP (IROF)=1.0_JPRB-(ZLON(IROF)-REAL(ILOTOP(IROF),JPRB))
    ENDDO
  ENDIF
  IROF=IROF0
  IF (INBBOTG(IGLG) == 1) THEN
    DO JLON=NSTA(IGLO,IB),NSTA(IGLO,IB)+ILEN-1
      IROF=IROF+1
      ILOBOT(IROF)=JLON
      ZWBOT (IROF)=1.0_JPRB
    ENDDO
  ELSE
    ZRATIO=REAL(NLOENG(MIN(IGLG+1,NDGLG)),JPRB)/REAL(NLOENG(IGLG),JPRB)
    DO JLON=NSTA(IGLO,IB),NSTA(IGLO,IB)+ILEN-1
      IROF=IROF+1
      ZLON  (IROF)=REAL(JLON-1,JPRB)*ZRATIO + 1.0_JPRB
      ILOBOT(IROF)=INT(ZLON(IROF))
      ZWBOT (IROF)=1.0_JPRB-(ZLON(IROF)-REAL(ILOBOT(IROF),JPRB))
    ENDDO
  ENDIF
  IROF0=IROF0+ILEN
ENDDO

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

!*       2. FIELD MODIFICATION.
!           -------------------

ZPARFP1(:)=1.0_JPRB
IST=1

!          *** Extraction by SC2RDG, then transfer data in a buffer ZDATAI.

DO JKGLO=1,IGPCOMP,NPROMA
  IEND=MIN(NPROMA,NGPTOT-JKGLO+1)
  CALL SC2RDG(YD_PGPBUF,JKGLO,IST,IEND,ZGPP)
  DO JF=1,KGP
    IFLDPTP=KFLDPTP(JF)
    DO JROF=IST,IEND
      ZDATAI(NFPCORE(JROF+JKGLO-1),JF)=ZGPP(JROF,IFLDPTP)
    ENDDO
  ENDDO
ENDDO

!          *** Complete buffer for extra-longitudes and
!              compute halo (call to SLCOMM)
!              and extra-polar latitudes (call to SLEXTPOL).

IF (NPROC > 1) THEN
  CALL SLCOMM(NAFPB1,NFPPROCS,NFPRPT,NFPSPT,NFPSENDPOS,&
   & NFPRECVPOS,NFPSENDPTR,NFPRECVPTR,NFPCOMM,&
   & IDUMARR,KGP,.FALSE.,0,ZDATAI)  
ENDIF
IF (LELAM) THEN
  CALL ESLEXTPOL(NFPWIDE,NFPWIDE,&
   & NAFPB1,NDGSAG,NDGENG,NDGSAL,NDGENL,KGP,NFPSTA,NFPONL,NFPOFF,&
   & NLOENG,NFRSTLOFF,MYFRSTACTLAT,MYLSTACTLAT,IDUMARR,1,&
   & ZDATAI)
ELSE
  CALL SLEXTPOL(NFPWIDE,NFPWIDE,&
   & NAFPB1,NDGSAG,NDGENG,NDGSAL,NDGENL,KGP,NFPSTA,NFPONL,NFPOFF,&
   & NDGLG,NLOENG,NFRSTLOFF,MYFRSTACTLAT,MYLSTACTLAT,IDUMARR,1,&
   & ZPARFP1,ZDATAI)  
ENDIF

!          *** Store modified field
!              then save ZGPP-data by SC2WRG.

DO JKGLO=1,IGPCOMP,NPROMA
  IEND=MIN(NPROMA,NGPTOT-JKGLO+1)

  DO JROF=IST,IEND
!         * Latitude of current row:
    ILA1=ILAT(JROF+JKGLO-1)
    ILA1G=ILAT(JROF+JKGLO-1)+NFRSTLOFF
!         * Latitude of southern row:
    ILA2G =ILA1G+1
    ILA2=MIN(MAX(ILA2G,1),NDGUXG)-NFRSTLOFF
!         * Latitude of northern row:
    ILA0G =ILA1G-1
    ILA0=MIN(MAX(ILA0G,1),NDGUXG)-NFRSTLOFF
!         * longitudes :
    ILO =MIN(MAX(ILOTOP(JROF+JKGLO-1),1),NDLUXG)-1
    ILO1=MIN(MAX(ILON(JROF+JKGLO-1),1),NDLUXG)-1
    ILO2=MIN(MAX(ILOBOT(JROF+JKGLO-1),1),NDLUXG)-1
    IL0(JROF,0)=NFPOFF(ILA0)+NFPEXT(ILO ,ILA0)
    IL0(JROF,1)=NFPOFF(ILA1)+NFPEXT(ILO1,ILA1)
    IL0(JROF,2)=NFPOFF(ILA2)+NFPEXT(ILO2,ILA2)
  ENDDO

  CALL SC2RDG(YD_PGPBUF,JKGLO,IST,IEND,ZGPP)

  DO JF=1,KGP
    IFLDPTP=KFLDPTP(JF)
    DO JROF=IST,IEND

      ZVAL0 =ZDATAI(IL0(JROF,1)+1,JF)
      ZVALE =ZDATAI(IL0(JROF,1)+2,JF)
      ZVALSW=ZDATAI(IL0(JROF,2)+1,JF)
      ZVALSE=ZDATAI(IL0(JROF,2)+2,JF)
      ZVALNW=ZDATAI(IL0(JROF,0)+1,JF)
      ZVALNE=ZDATAI(IL0(JROF,0)+2,JF)
      ZVALW =ZDATAI(IL0(JROF,1)  ,JF)

      ZVALS=(1.0_JPRB-ZWBOT(JROF+JKGLO-1))*ZVALSE + ZWBOT(JROF+JKGLO-1)*ZVALSW
      ZVALN=(1.0_JPRB-ZWTOP(JROF+JKGLO-1))*ZVALNE + ZWTOP(JROF+JKGLO-1)*ZVALNW

      ZVALX=MAX(ZVALN,ZVALS,ZVALW,ZVALE)
      Z0=MAX(0.0_JPRB,-SIGN(1.0_JPRB,-ZVAL0))
      ZGPP(JROF,IFLDPTP) = Z0*ZVAL0 -(1.0_JPRB-Z0)*ZVALX

    ENDDO
  ENDDO

  CALL SC2WRG(YD_PGPBUF,JKGLO,IST,IEND,ZGPP)

ENDDO

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

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

