SUBROUTINE GPTENC(KPROF,KSTGLO,PSPT0,PSPT0L,PSPT0M,&
 & PSPT9,PSPT9L,PSPT9M)  

!**** *GPTENC* - Tendency coupling for surface pressure

!     Purpose.
!     --------
!         Apply tendency coupling for surface pressure to decrease the
!         possible imbalances generated by the interpolation to the 
!         high resolution orography. t1 coupling + this subroutine 
!         together result in the tendency coupling for surface pressure 

!**   Interface.
!     ----------
!        *CALL* *GPTENC(...)

!        Explicit arguments :
!        --------------------
!                 KPROF:  length of the packet
!                 KSTGLO: offset
!                 PSPT0,PSPT0L,PSPT0M: t0 surf. pressure and derivatives
!                 PSPT9,PSPT9L,PSPT9M: t9 surf. pressure and derivatives

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

!     Method.
!     -------
!        See documentation

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

!     Reference.
!     ----------

!     Author.
!     -------
!        Tamas Szabo

!     Modifications.
!     --------------
!      Original : 20-04-2001
!      02-09-15 C. Moussy   : Calcul des latitudes IGL1, IGL2 localement
!      03-04-10 P. Termonia : rewrite to adapt to Radnoti's new design
!                             (IGL1,IGL2 removed) 
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        JM. Audoin    20-jan-2004 new reading according to GFL structure
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMDIM   , ONLY : NFLEVG   ,NDLUXG   ,NDGUXG,  NPROMA     
USE YEMDIM   , ONLY : NGALEF   ,NBZONL   ,NBZONG
USE YOMMP    , ONLY : LSPLIT
USE YOMCT0   , ONLY : NPRGPEW  ,RTENC    ,LALLTC
USE YEMCT0   , ONLY : LQCPL
USE YEMCT3   , ONLY : NETLS1
USE YOMCT3   , ONLY : NSTEP
USE YEMGT3B  , ONLY : NEDLST, NLATGPP, NLONGPP
USE YOMLUN   , ONLY : NULOUT
USE YEMBICU  , ONLY : EALFA    ,EALFAL   ,EALFAM   ,NFALFA
USE YEMDYN   , ONLY : NDIMCPL
USE YOMGMV   , ONLY : YT0

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

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTGLO 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPT0(KPROF) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPT0L(KPROF) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PSPT0M(KPROF) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSPT9(KPROF) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSPT9L(KPROF) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSPT9M(KPROF) 

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

REAL(KIND=JPRB) :: ZSP39(KPROF),ZSP39L(KPROF),ZSP39M(KPROF)
REAL(KIND=JPRB) :: ZGT3GMV(NEDLST,NFLEVG,YT0%NDIM)
REAL(KIND=JPRB) :: ZGT3GMVS(NEDLST,YT0%NDIMS)
REAL(KIND=JPRB) :: ZGT3GFL(NEDLST,NFLEVG,NDIMCPL)

INTEGER(KIND=JPIM) :: ITIMLEV,IALFP,&
 & IGPTOT,JROF,IND,ILATG,ILONG,IBL,JGPBLKS  

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "esc2r.intfb.h"

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

IF (LQCPL.AND.NSTEP == NETLS1 .AND. LHOOK) CALL DR_HOOK('GPTENC',1,ZHOOK_HANDLE)
IF (LQCPL.AND.NSTEP == NETLS1) RETURN
IF (.NOT.LALLTC.AND.NSTEP == NETLS1 .AND. LHOOK) CALL DR_HOOK('GPTENC',1,ZHOOK_HANDLE)
IF (.NOT.LALLTC.AND.NSTEP == NETLS1) RETURN

IF (NPRGPEW > 1.OR.LSPLIT) THEN
  WRITE(NULOUT,*) ' GPTENC: ERROR: NPRGPEW > 1.OR.LSPLIT '
  CALL ABOR1('GPTENC: ABOR1 CALLED: NPRGPEW > 1.OR.LSPLIT')
ENDIF

IF (LQCPL.AND.LALLTC) THEN
  CALL ABOR1 ('GPTENC: ABOR1 CALLED: LQCPL.AND.LALLTC')
ENDIF

IALFP = MIN(NFALFA(4),NGALEF)

!  This routine now longer works as routine SC2CGAP has been removed as
!  part of the GFL introduction. I can't
!  fix it without access to routine ESC2R so I have to leave it to someone
!  else. Mats  Hamrud (ECMWF)

!CALL ABOR1('GPTENC - THIS ROUTINE IS BROKEN/GFL')

ITIMLEV=9
!CALL ESC2R(ITIMLEV,LLGP,IFIELDS3,ZAUX,NEDLST)
CALL ESC2R(ITIMLEV,ZGT3GMV,ZGT3GMVS,ZGT3GFL,NEDLST)

IBL=(KSTGLO-1)/NPROMA+1
IND=0
DO JGPBLKS=1,IBL-1
  DO JROF=1,NPROMA
    IF (NLATGPP(JROF,JGPBLKS) > 0) THEN
      ILATG=NLATGPP(JROF,JGPBLKS)
      ILONG=NLONGPP(JROF,JGPBLKS)
      IF (ILONG <= NBZONL.OR.ILONG > NDLUXG-NBZONL&
         & .OR.ILATG <= NBZONG.OR.ILATG > NDGUXG-NBZONG) THEN  
        IND=IND+1
      ENDIF
    ENDIF
  ENDDO
ENDDO
IGPTOT=0
DO JROF=1,NPROMA
  IF (NLATGPP(JROF,IBL) > 0 ) THEN
    ILATG=NLATGPP(JROF,IBL)
    ILONG=NLONGPP(JROF,IBL)
    IGPTOT=IGPTOT+1
    IF (IGPTOT > KPROF) CALL ABOR1("GPTENC: IGPTOT OUT OF RANGE")
    IF (ILONG <= NBZONL.OR.ILONG > NDLUXG-NBZONL&
       & .OR.ILATG <= NBZONG.OR.ILATG > NDGUXG-NBZONG) THEN  
      IND=IND+1
      ZSP39(IGPTOT)=ZGT3GMVS(IND,YT0%MSP)
      ZSP39L(IGPTOT)=ZGT3GMVS(IND,YT0%MSPL)
      ZSP39M(IGPTOT)=ZGT3GMVS(IND,YT0%MSPM)
    ELSE
      ZSP39(IGPTOT)=0.0_JPRB
      ZSP39L(IGPTOT)=0.0_JPRB
      ZSP39M(IGPTOT)=0.0_JPRB
    ENDIF
  ENDIF
ENDDO

PSPT0(:)=PSPT0(:)+RTENC*EALFA(KSTGLO:KSTGLO+KPROF-1,IALFP)*(PSPT9(:)-ZSP39(:))
PSPT0L(:)=PSPT0L(:)+RTENC*(EALFA(KSTGLO:KSTGLO+KPROF-1,IALFP)*&
 & (PSPT9L(:)-ZSP39L(:))+&
 & EALFAL(KSTGLO:KSTGLO+KPROF-1,IALFP)*(PSPT9(:)-ZSP39(:)))  
PSPT0M(:)=PSPT0M(:)+RTENC*(EALFA(KSTGLO:KSTGLO+KPROF-1,IALFP)&
 & *(PSPT9M(:)-ZSP39M(:))+&
 & EALFAM(KSTGLO:KSTGLO+KPROF-1,IALFP)*(PSPT9(:)-ZSP39(:)))  

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