SUBROUTINE AMV_GET_PREDS(kdlen,klen,kobstype, porog, &
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,pclwf5,pciwf5,pccf5, &
 & ptstar5,pt05,plnpr5,palph5,plat,plon,pu,pv,pdp)  

!**** *AMV_GET_PREDS - Calculate predictors for AMV/SATOBs 
!                      pressure reassignment

!  Niels Bormann        ECMWF   22/06/2001

!  Routine to calculate a suite of predictors for AMV height reassignment.
!  The predictors are derived from first guess information and other
!  observational data. 

!**   INTERFACE/ARGUMENTS:
!     --------------------
!     kdlen     = First dimension: Max number of observations, this set
!     klen      = Actual number of obs, this set
!     kobstype  = Observation type
!     porog     = Orography at obs points [m]
!     presh5    = Model half level pressure at obs points [Pa]
!     presf5    = Model full level pressure at obs points [Pa]
!     pxp5, pxpd5 = Intermediate variables 
!     puf5,pvf5 = Model u,v-wind component profiles at obs points [m/s]
!     ptf5      = Model temperature profiles at obs points [K]
!     pqf5      = Model moisture profiles at obs points [kg/kg]
!     po3f5     = Model ozone profiles at obs points
!     pclwf5    = Model cloud liquid water profiles at obs points [kg/kg]
!     pciwf5    = Model cloud ice water profiles at obs points [kg/kg]
!     pccf5     = Model cloud fraction profiles at obs points [1]
!     ptstar5   = Surface temperature [K]
!     pt05      = Surface temperature [K]
!     plnpr5    = LOG. of the ratio of pressure 
!     palph5    = Coefficients of the hydrostatics 
!     plat,plon = Latitude/longitude of obs points [deg]
!     pu,pv     = u, v wind component of AMV [m/s]
!     pdp       = Originally assigned pressure of AMV [Pa]

!     amv_get_preds is called by amv_reassign

!**   METHOD
!     ------
!     Each predictor is calculated as defined and to be stored in the ODB
!     for later use.

!**   EXTERNALS
!     ---------
!     PPOBSA - Equivalents of observed values

!**   MODIFICATIONS
!     -------------
!     14/10/2009     N. Bormann             Modified best-fit pressure calculations

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

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

USE YOMDB                
USE YOMANCS  , ONLY : RMDI
USE yomlun   , ONLY : nulout
USE yomdim   , ONLY : nflevg, nppm
USE yomcst   , ONLY : rg, rpi

IMPLICIT NONE

! Arguments
INTEGER(KIND=JPIM),INTENT(IN)    :: KDLEN ! Number of obs
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN ! Number of obs in set
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBSTYPE ! Observation type
REAL(KIND=JPRB)   ,INTENT(IN)    :: POROG(KDLEN) ! Orography
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESH5(KDLEN,0:NFLEVG) ! Model half level pressure [Pa]
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRESF5(KDLEN,NFLEVG) ! Model full level pressure [Pa]
REAL(KIND=JPRB)   ,INTENT(IN)    :: PXP5(KDLEN,0:NFLEVG,NPPM) ! Intermediate values
REAL(KIND=JPRB)   ,INTENT(IN)    :: PXPD5(KDLEN,0:NFLEVG,NPPM) ! Intermediate values
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PUF5(KDLEN,0:NFLEVG) ! Model U [m/s]
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVF5(KDLEN,0:NFLEVG) ! Model V [m/s]
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTF5(KDLEN,0:NFLEVG) ! Model temperature [K]
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PQF5(KDLEN,0:NFLEVG) ! Model humidity [kg/kg]
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PO3F5(KDLEN,0:NFLEVG) ! Model ozone
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PCLWF5(KDLEN,0:NFLEVG) ! Cloud liquid water
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PCIWF5(KDLEN,0:NFLEVG) ! Cloud ice 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PCCF5(KDLEN,0:NFLEVG) ! Cloud cover
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTSTAR5(KDLEN) ! T*
REAL(KIND=JPRB)   ,INTENT(IN)    :: PT05(KDLEN) ! T0
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLNPR5(KDLEN,NFLEVG) ! Log of the ratio of pressure
REAL(KIND=JPRB)   ,INTENT(IN)    :: PALPH5(KDLEN,NFLEVG) ! Coefficients of the hydrostatics
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLAT(KDLEN) ! Latitude of profile/obs
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLON(KDLEN) ! Longitude of profile/obs
REAL(KIND=JPRB)   ,INTENT(IN)    :: PU(KDLEN) ! U of AMV/SATOB
REAL(KIND=JPRB)   ,INTENT(IN)    :: PV(KDLEN) ! V of AMV/SATOB
REAL(KIND=JPRB)   ,INTENT(IN)    :: PDP(KDLEN) ! Assigned pressure of obs [Pa]
! End arguments

! Local parameters
REAL(KIND=JPRB), PARAMETER                     :: zdeltap = 5000._JPRB  ! [Pa]

! Local variables
!REAL(KIND=JPRB), DIMENSION(kdlen)              :: za, zb    ! Used for zenith angle 
REAL(KIND=JPRB), DIMENSION(kdlen)              :: zff, zdd  ! Speed/direction of AMV
REAL(KIND=JPRB), DIMENSION(kdlen,nflevg)       :: zvdf5     ! Vector difference (AMV-FG)
REAL(KIND=JPRB), DIMENSION(kdlen,0:nflevg)     :: zfff5,zddf5 ! FG speed /dir
REAL(KIND=JPRB), ALLOCATABLE, DIMENSION(:,:)   :: zpres
REAL(KIND=JPRB), ALLOCATABLE, DIMENSION(:,:,:) :: zresult
REAL(KIND=JPRB)                                :: zx1, zx2, zx3, zy1, zy2, zy3
INTEGER(KIND=JPIM), DIMENSION(kdlen)           :: iabove
INTEGER(KIND=JPIM), DIMENSION(kdlen)           :: ibest
INTEGER(KIND=JPIM), DIMENSION(kdlen)           :: i80
INTEGER(KIND=JPIM), DIMENSION(kdlen)           :: icount
INTEGER(KIND=JPIM)                             :: imxcount

INTEGER(KIND=JPIM)                             :: jobs

LOGICAL, DIMENSION(nflevg-2)          :: llmin_mask
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "ppobsa.intfb.h"

#include "openmp_obs.h"

!====================================================

!*  1   Preparation
!       --------------------

!   1.1 Calculate speed and direction for obs and model

IF (LHOOK) CALL DR_HOOK('AMV_GET_PREDS',0,ZHOOK_HANDLE)
zff(1:klen) = SQRT( pu(1:klen)**2 + pv(1:klen)**2)
WHERE(pu(1:klen) == 0.0_JPRB)
  zdd(1:klen) = rpi/2._JPRB + SIGN(1._JPRB,pv(1:klen))*rpi/2._JPRB
ELSEWHERE
  zdd(1:klen) = rpi - ATAN(pv(1:klen)/pu(1:klen))    &
   & + SIGN(1._JPRB,pu(1:klen))*rpi/2._JPRB  
ENDWHERE
zdd(1:klen) = zdd(1:klen) * 180._JPRB / rpi

zfff5(1:klen,1:nflevg)=SQRT(puf5(1:klen,1:nflevg)**2+pvf5(1:klen,1:nflevg)**2)
WHERE(puf5(1:klen,1:nflevg) == 0.0_JPRB)
  zddf5(1:klen,1:nflevg) = rpi/2._JPRB +    &
   & SIGN(1._JPRB,pvf5(1:klen,1:nflevg))*rpi/2._JPRB  
ELSEWHERE
  zddf5(1:klen,1:nflevg) = rpi -            &
   & ATAN(pvf5(1:klen,1:nflevg)/puf5(1:klen,1:nflevg)) &
   & + SIGN(1._JPRB,puf5(1:klen,1:nflevg))*rpi/2._JPRB  
ENDWHERE
zddf5(1:klen,1:nflevg) = zddf5(1:klen,1:nflevg) * 180._JPRB / rpi

!  1.2 Check that values are reasonable

IF(ANY(zdd(1:klen) > 370.0_JPRB .OR. zdd(1:klen) < -370.0_JPRB))THEN
  WRITE(nulout,*) 'WARNING amv_get_preds: some zdd unreasonable.'
ENDIF
IF(ANY(zff(1:klen) > 200._JPRB .OR. zff(1:klen) < 0._JPRB))THEN
  WRITE(nulout,*) 'WARNING amv_get_preds: some zff unreasonable.'
ENDIF
IF(ANY(zddf5(1:klen,1:nflevg) > 370._JPRB    &
   & .OR. zddf5(1:klen,1:nflevg) < -370._JPRB))THEN  
  WRITE(nulout,*) 'WARNING amv_get_preds: some zddf5 unreasonable.'
ENDIF
IF(ANY(zfff5(1:klen,1:nflevg) > 200._JPRB    &
   & .OR. zfff5(1:klen,1:nflevg) < 0._JPRB))THEN  
  WRITE(nulout,*) 'WARNING amv_get_preds: some zfff5 unreasonable.'
ENDIF
IF(ANY(pdp(1:klen) < 10000._JPRB .OR. pdp(1:klen) > 110000._JPRB))THEN
  WRITE(nulout,*) 'WARNING amv_get_preds: some pdp unreasonable.'
ENDIF

!*  2   Calculate predictors
!       --------------------

!   2.1 Local temperature [K]
imxcount = 1
icount = 1
ALLOCATE(zpres(kdlen,imxcount))
zpres(1:klen,1) = pdp(1:klen)
ALLOCATE(zresult(kdlen,1,1))
CALL ppobsa(kdlen,klen,imxcount,'T',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
SATHDR(1:klen,MDB_T_AT_SATOB) = zresult(1:klen,1,1)

IF(ANY(SATHDR(1:klen,MDB_T_AT_SATOB) >  1000._JPRB &
   & .OR. SATHDR(1:klen,MDB_T_AT_SATOB) < -1000._JPRB))THEN  
  WRITE(nulout,*) 'WARNING amv_get_preds: some t unreasonable.'
ENDIF

!   2.2 Temperature at 200 hPa [K]          
zpres(1:klen,1) = 20000._JPRB
CALL ppobsa(kdlen,klen,imxcount,'T',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
SATHDR(1:klen,MDB_T200_AT_SATOB) = zresult(1:klen,1,1)

!   2.3 Temperature at 500 hPa [K]                          
zpres(1:klen,1) = 50000._JPRB
CALL ppobsa(kdlen,klen,imxcount,'T',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
SATHDR(1:klen,MDB_T500_AT_SATOB) = zresult(1:klen,1,1) 

!   2.4 Integrated water vapour above p (currently not SI units)   
zpres(1:klen,1) = pdp(1:klen)
CALL ppobsa(kdlen,klen,imxcount,'Q',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
DO jobs = 1, klen
  iabove(jobs:jobs) = MAXLOC(presf5(jobs,1:nflevg-1),    &
   & MASK = presf5(jobs,1:nflevg-1) <= pdp(jobs)         &
   & .AND. presf5(jobs,1:nflevg-1) >= presf5(jobs,2))  
  IF(iabove(jobs) >= 2)THEN
    SATHDR(jobs,MDB_TOP_WV_AT_SATOB) = SUM(      &
     & (presf5(jobs,2:iabove(jobs)) - presf5(jobs,1:iabove(jobs)-1))&
     & * (pqf5(jobs,2:iabove(jobs)) + pqf5(  jobs,1:iabove(jobs)-1)) )&
     & / (0.2_JPRB * rg)                               &
     & + (pdp(jobs) - presf5(jobs,iabove(jobs)))       &
     & * ( zresult(jobs,1,1) + pqf5(  jobs,iabove(jobs))) &
     & / (0.2_JPRB * rg)                                
  ELSE
    SATHDR(jobs,MDB_TOP_WV_AT_SATOB) = 0.0_JPRB
  ENDIF 
ENDDO
DEALLOCATE(zpres,zresult)

!   2.5 Mean T [K] between 80 hPa and p    
imxcount = 2
icount = 2
ALLOCATE(zpres(kdlen,imxcount))
zpres(1:klen,1) = pdp(1:klen) 
zpres(1:klen,2) = 8000._JPRB
ALLOCATE(zresult(kdlen,imxcount,1))
CALL ppobsa(kdlen,klen,imxcount,'T',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
DO jobs = 1, klen
  i80(jobs:jobs) = MINLOC(presf5(jobs,:),    &
   & MASK = presf5(jobs,:) >= 8000._JPRB)  
  IF(iabove(jobs) >= i80(jobs))THEN
    SATHDR(jobs,MDB_TOP_MEAN_T_AT_SATOB) = ( SUM(            &
     & (  LOG(presf5(jobs,i80(jobs)+1:iabove(jobs)  ))         &
     & - LOG(presf5(jobs,i80(jobs)  :iabove(jobs)-1)) )       &
     & * (      ptf5(  jobs,i80(jobs)+1:iabove(jobs)  )          &
     & +     ptf5(  jobs,i80(jobs)  :iabove(jobs)-1)  ) / 2. )&
     & +   (  LOG(presf5(jobs,i80(jobs))) - LOG(8000._JPRB))       &
     & * (      ptf5(  jobs,i80(jobs))  + zresult(jobs,2,1)) / 2.&
     & +   (  LOG(pdp(jobs)) - LOG(presf5(jobs,iabove(jobs))) )    &
     & * (  zresult(jobs,1,1) + ptf5(jobs,iabove(jobs)) ) / 2.  )&
     & / (  LOG(pdp(jobs)) - LOG(8000._JPRB) )  
  ELSE
    SATHDR(jobs,MDB_TOP_MEAN_T_AT_SATOB) = zresult(jobs,2,1)
  ENDIF
ENDDO

!   2.6 Temperature difference "-zdeltap Pa"-"+zdeltap Pa" [K / (2*zdeltap)] 
imxcount = 2
icount = 2
zpres(1:klen,1) = pdp(1:klen) + zdeltap
zpres(1:klen,2) = pdp(1:klen) - zdeltap
WHERE ( zpres(1:klen,1) > presf5(1:klen,nflevg) ) 
  zpres(1:klen,1) = presf5(1:klen,nflevg)
ENDWHERE
WHERE ( zpres(1:klen,2) < 5000.0_JPRB ) zpres(1:klen,2) = 5000.0_JPRB
CALL ppobsa(kdlen,klen,imxcount,'T',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 1,zresult)  
SATHDR(1:klen,MDB_DT_BY_DP_AT_SATOB) =     &
 & zresult(1:klen,2,1) - zresult(1:klen,1,1)  
DEALLOCATE(zresult)

!   2.7 Speed difference "-zdeltap Pa"-"+zdeltap Pa" [m/s / (2*zdeltap)] 
imxcount = 2
icount = 2
ALLOCATE(zresult(kdlen,imxcount,2))
CALL ppobsa(kdlen,klen,imxcount,'U',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 2,zresult)  
SATHDR(1:klen,MDB_SHEAR_AT_SATOB) =     &
 & SQRT(zresult(1:klen,2,1)*zresult(1:klen,2,1)   &
 & + zresult(1:klen,2,2)*zresult(1:klen,2,2))  &
 & - SQRT(zresult(1:klen,1,1)*zresult(1:klen,1,1)   &
 & + zresult(1:klen,1,2)*zresult(1:klen,1,2))  
DEALLOCATE(zpres,zresult)



!   2.9 Best fit pressure [Pa]
DO jobs = 1, klen

  ! Calculate profile of vector difference

  zvdf5(jobs,:) = SQRT(   (pu(jobs) - puf5(jobs,1:nflevg))**2       &
   & + (pv(jobs) - pvf5(jobs,1:nflevg))**2)    

  ! Mask of all local minima with a vector difference of less than 4 m/s

  llmin_mask = zvdf5(jobs,2:nflevg-1) - zvdf5(jobs,3:nflevg) <= 0.0_JPRB &
     & .AND. zvdf5(jobs,1:nflevg-2) - zvdf5(jobs,2:nflevg-1) >= 0.0_JPRB &
     & .AND. presf5(jobs,2:nflevg-1) >= 10000.0_JPRB                 &
     & .AND. zvdf5(jobs,2:nflevg-1) <= 4.0_JPRB
  llmin_mask(nflevg-2) = zvdf5(jobs,nflevg-1) < zvdf5(jobs,nflevg-2) &
     & .AND. zvdf5(jobs,nflevg-2) <= 4.0_JPRB

  ! Of the above minima, select the one closest to the originally assigned
  ! pressure that also looks like a deep minimum

  IF(ANY(llmin_mask)) THEN
    DO
      ibest(jobs:jobs) = MINLOC(ABS(presf5(jobs,2:nflevg-1) - pdp(jobs)),   &
        & MASK = llmin_mask) + 1            ! "+1" because of "2:nflevg-1"  

      IF(MINVAL(zvdf5(jobs,:), DIM = 1, MASK = ABS(presf5(jobs,:)&
          &  - presf5(jobs,ibest(jobs))) >= 10000.0_JPRB) &
          &  < zvdf5(jobs,ibest(jobs)) + 2.0_JPRB) THEN
        llmin_mask(ibest(jobs) - 1) = .False.
        ibest(jobs) = -1
        IF(.NOT.ANY(llmin_mask)) THEN
          SATHDR(jobs,MDB_P_BEST_AT_SATOB) = -2.0_JPRB
          EXIT
        ENDIF
      ELSE
        EXIT
      ENDIF
    ENDDO

    IF(ibest(jobs) > 0)THEN

      ! Determine best fit through parabolic fit (see notes 31 Oct 2000)
      zx1 = presf5(jobs,ibest(jobs)-1)
      zx2 = presf5(jobs,ibest(jobs))
      zx3 = presf5(jobs,ibest(jobs)+1)
      zy1 = zvdf5(jobs,ibest(jobs)-1)
      zy2 = zvdf5(jobs,ibest(jobs))
      zy3 = zvdf5(jobs,ibest(jobs)+1)
      IF(zy2 < zy1 .AND. zy2 < zy3 .AND. zy1 /= zy3)THEN
        SATHDR(jobs,MDB_P_BEST_AT_SATOB) =                &
         & (   (zx1*zx1 - zx3*zx3) * (zy1 - zy2)   &
         & - (zx1*zx1 - zx2*zx2) * (zy1 - zy3) ) &
         & / (2. * (   (zx2 - zx1) * (zy1 - zy3)     &
         & - (zx3 - zx1) * (zy1 - zy2) ) )  
      ELSEIF(zy1 == zy2)THEN
        SATHDR(jobs,MDB_P_BEST_AT_SATOB) = (zx1 + zx2)/2.
      ELSEIF(zy1 == zy3)THEN
        SATHDR(jobs,MDB_P_BEST_AT_SATOB) = (zx1 + zx3)/2.
      ELSEIF(zy2 == zy3)THEN
        SATHDR(jobs,MDB_P_BEST_AT_SATOB) = (zx2 + zx3)/2.
      ELSE
        IF(zy1 > zy3)THEN
          SATHDR(jobs,MDB_P_BEST_AT_SATOB) = zx3
        ELSE
          SATHDR(jobs,MDB_P_BEST_AT_SATOB) = zx1
        ENDIF
      ENDIF
    ENDIF
  ELSE
    SATHDR(jobs,MDB_P_BEST_AT_SATOB) = -1.0_JPRB
  ENDIF
ENDDO

!   2.10 Best fit u & v [m/s]
imxcount = 1
icount = 1
ALLOCATE(zpres(kdlen,imxcount))
zpres(1:klen,1) = SATHDR(1:klen,MDB_P_BEST_AT_SATOB)
WHERE(SATHDR(1:klen,MDB_P_BEST_AT_SATOB) == RMDI) 
  zpres(1:klen,1) = pdp(jobs)
ENDWHERE
ALLOCATE(zresult(kdlen,1,2))
CALL ppobsa(kdlen,klen,imxcount,'U',kobstype,icount,zpres,porog,&
 & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
 & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
 & 2,zresult)  
WHERE(SATHDR(1:klen,MDB_P_BEST_AT_SATOB) /= RMDI)
  SATHDR(1:klen,MDB_U_BEST_AT_SATOB) = zresult(1:klen,1,1)
  SATHDR(1:klen,MDB_V_BEST_AT_SATOB) = zresult(1:klen,1,2)
ELSEWHERE
  SATHDR(1:klen,MDB_U_BEST_AT_SATOB) = RMDI
  SATHDR(1:klen,MDB_V_BEST_AT_SATOB) = RMDI
ENDWHERE

!   2.11 Store old values before reassignment
!SATHDR(1:klen,MDB_P_OLD_AT_SATOB) = pdp(1:klen)
!zpres(1:klen,1) = pdp(1:klen)
!CALL ppobsa(kdlen,klen,imxcount,'U',kobstype,icount,zpres,porog,&
! & presh5,presf5,pxp5,pxpd5,puf5,pvf5,ptf5,pqf5,po3f5,&
! & pclwf5,pciwf5,pccf5,ptstar5,pt05,plnpr5,palph5,&
! & 2,zresult)  
!SATHDR(1:klen,MDB_U_OLD_AT_SATOB) = zresult(1:klen,1,1)
!SATHDR(1:klen,MDB_V_OLD_AT_SATOB) = zresult(1:klen,1,2)
DEALLOCATE(zpres,zresult)

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