SUBROUTINE PPUVAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,KLEVB,&
 & LDBELO,LDBLOW,PRPRESC,PRXP,PRXPD,&
 & PUF,PVF,PUPP,PVPP,&
 & PRXP5,PRXPD5,PUF5,PVF5)  

!**** *PPUVAD* - POST-PROCESS WINDS - ADJOINT

!     PURPOSE.
!     --------
!           PERFORMS THE VERTICAL INTERPOLATION OF U AND V TO GIVEN
!       PRESSURE LEVELS

!**   INTERFACE.
!     ----------
!        *CALL* *PPUVAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,KLEVB,
!                     LDBELO,LDBLOW,PRPRESC,PRXP,PRXPD,
!                     PUF,PVF,PUPP,PVPP)
!                     PRXP5,PRXPD5,PUF5,PVF5)

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

!        KPROMA                    - HORIZONTAL DIMENSION.             (INPUT-C)
!        KSTART                    - START OF WORK.                    (INPUT-C)
!        KPROF                     - DEPTH OF WORK.                    (INPUT-C)
!        KFLEV                     - NUMBER OF INPUT PRESSURE LEVELS   (INPUT-C)
!        KLEVP                     - NUMBER OF OUTPUT PRESSURE LEVELS  (INPUT-C)
!        KLEVB(KPROMA,KLEVP,NPPM)  - INPUT LEVEL BELOW PRPRESC         (INPUT-C)
!                                    (SEE PPFLEV)
!        PRPRESC(KPROMA,KLEVP)     - LOG(POST-PROCESSING LEVEL PRES.)  (INPUT-C)
!        LDBELO(KPROMA,KLEVP)      - .TRUE. IF PRESSURE IS UNDER
!                                     LOWEST  MODEL LEVEL              (INPUT-C)
!        LDBLOW(KLEVP)             - FIRST LEVEL OF LDBELO CONTAINING
!                                    AT LEAST ONE .TRUE.               (INPUT-C)
!        PRXP(KPROMA,0:KFLEV,NPPM) - HALF,FULL AND LN HALF,FULL LEVEL
!                                    PRESSURES (SEE PPINIT)            (INPUT)
!        PRXPD(KPROMA,0:KFLEV,NPPM)- 1./D(P) AND 1./D(LN(P))           (INPUT)
!        PUF(KPROMA,0:KFLEV)       - ZONAL WIND ON FULL INPUT LEVELS   (INPUT)
!        PVF(KPROMA,0:KFLEV)       - MERID. WIND ON FULL INPUT LEVELS  (INPUT)

!        PUPP(KPROMA,KLEVP)        - POST-PROCESSED ZONAL WIND         (OUTPUT)
!        PVPP(KPROMA,KLEVP)        - POST-PROCESSED MERIDIONAL WIND    (OUTPUT)

!        IMPLICIT ARGUMENTS :  NONE.
!        --------------------

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

!     EXTERNALS.  PPINTPAD - LINEAR INTERPOLATION
!     ----------  PPITPQAD - QUADRATIC INTERPOLATION FOR TOP LEVELS

!     REFERENCE.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     AUTHOR.
!     -------
!        MATS HAMRUD AND PHILIPPE COURTIER  *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 89-01-26
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMDIM   , ONLY : NPPM
USE YOMCT0   , ONLY : LOLDPP

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEVP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KSTART 
INTEGER(KIND=JPIM),INTENT(IN)    :: KPROF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLOLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEVB(KPROMA,KLEVP,NPPM) 
LOGICAL           ,INTENT(IN)    :: LDBELO(KPROMA,KLEVP) 
LOGICAL           ,INTENT(IN)    :: LDBLOW(KLEVP) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRPRESC(KPROMA,KLEVP) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PRXP(KPROMA,0:KFLEV,NPPM) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PRXPD(KPROMA,0:KFLEV,NPPM) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PUF(KPROMA,0:KFLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVF(KPROMA,0:KFLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PUPP(KPROMA,KLEVP) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVPP(KPROMA,KLEVP) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRXP5(KPROMA,0:KFLEV,NPPM) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRXPD5(KPROMA,0:KFLEV,NPPM) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PUF5(KPROMA,0:KFLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVF5(KPROMA,0:KFLEV) 
INTEGER(KIND=JPIM) :: ISLCT, JL, JLEVP
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "ppintpad.intfb.h"
#include "ppuvad_old.intfb.h"

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('PPUVAD',0,ZHOOK_HANDLE)
IF(LOLDPP) THEN
  CALL PPUVAD_OLD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,KLEVB,&
   & LDBELO,LDBLOW,PRPRESC,PRXP,PRXPD,&
   & PUF,PVF,PUPP,PVPP,&
   & PRXP5,PRXPD5,PUF5,PVF5)  
  IF (LHOOK) CALL DR_HOOK('PPUVAD',1,ZHOOK_HANDLE)
  RETURN
ENDIF

!*       0.    MODIFY TRAJECTORY
!              -------------------
ISLCT=4

!*       0.1   PREPARE FOR EXTRAPOLATION ABOVE TOP MODEL LEVEL.

DO JL=KSTART,KPROF
  PUF5(JL,0)=PUF5(JL,2)+PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)*&
   & (PUF5(JL,1)-PUF5(JL,2))  
  PVF5(JL,0)=PVF5(JL,2)+PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)*&
   & (PVF5(JL,1)-PVF5(JL,2))  
ENDDO
!     ------------------------------------------------------------------

!*       1.    POST-PROCESS WINDS.
!              -------------------

!*       1.4   MODIFY INTERPOLATION/EXTRAPOLATION ABOVE SECOND
!*          FULL MODEL LEVEL. FIT QUADRATIC POLYNOMIAL IN LN(P).

!     CALL PPITPQAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,ISLCT,
!    1              PRPRESC,PRXP,PUF,
!    2              PRXP5,PUF5,
!    3              PUPP)
!     CALL PPITPQAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,ISLCT,
!    1              PRPRESC,PRXP,PVF,
!    2              PRXP5,PVF5,
!    3              PVPP)

!*       1.3   CONSTANT EXTRAPOLATION BELOW LOWEST MODEL LEVEL.

DO JLEVP=KLOLEV,KLEVP
  IF(LDBLOW(JLEVP)) THEN
    DO JL=KSTART,KPROF
      IF ( LDBELO(JL,JLEVP)) THEN
        PUF(JL,KFLEV)=PUF(JL,KFLEV)+PUPP(JL,JLEVP)
        PVF(JL,KFLEV)=PVF(JL,KFLEV)+PVPP(JL,JLEVP)
        PUPP(JL,JLEVP)=0.0_JPRB
        PVPP(JL,JLEVP)=0.0_JPRB
      ENDIF
    ENDDO
  ENDIF
ENDDO

!*       1.2   INTERPOLATE WINDS.
CALL PPINTPAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,KLEVB,&
 & ISLCT,LDBELO,LDBLOW,PRPRESC,PRXP,PRXPD,PUF,PUPP,&
 & PRXP5,PRXPD5,PUF5)  
CALL PPINTPAD(KPROMA,KSTART,KPROF,KFLEV,KLEVP,KLOLEV,KLEVB,&
 & ISLCT,LDBELO,LDBLOW,PRPRESC,PRXP,PRXPD,PVF,PVPP,&
 & PRXP5,PRXPD5,PVF5)  

!*       1.1   PREPARE FOR EXTRAPOLATION ABOVE TOP MODEL LEVEL.

DO JL=KSTART,KPROF
  PUF(JL,2)=PUF(JL,2)+PUF(JL,0)
  PRXP(JL,2,ISLCT)=PRXP(JL,2,ISLCT)+PUF(JL,0)*&
   & PRXPD5(JL,1,ISLCT)*(PUF5(JL,1)-PUF5(JL,2))  
  PRXPD(JL,1,ISLCT)=PRXPD(JL,1,ISLCT)+PUF(JL,0)*&
   & PRXP5(JL,2,ISLCT)*(PUF5(JL,1)-PUF5(JL,2))  
  PUF(JL,1)=PUF(JL,1)+PUF(JL,0)*PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)
  PUF(JL,2)=PUF(JL,2)-PUF(JL,0)*PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)

  PVF(JL,2)=PVF(JL,2)+PVF(JL,0)
  PRXP(JL,2,ISLCT)=PRXP(JL,2,ISLCT)+PVF(JL,0)*&
   & PRXPD5(JL,1,ISLCT)*(PVF5(JL,1)-PVF5(JL,2))  
  PRXPD(JL,1,ISLCT)=PRXPD(JL,1,ISLCT)+PVF(JL,0)*&
   & PRXP5(JL,2,ISLCT)*(PVF5(JL,1)-PVF5(JL,2))  
  PVF(JL,1)=PVF(JL,1)+PVF(JL,0)*PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)
  PVF(JL,2)=PVF(JL,2)-PVF(JL,0)*PRXP5(JL,2,ISLCT)*PRXPD5(JL,1,ISLCT)
ENDDO

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

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