SUBROUTINE ASCATIN  (KSCATP,&
 & KOBTYP,KCDTYP,KOBSQNO,KCDSQNO,&
 & LDMESAGE,LDTAKEN)  

!**** SUBROUTINE ASCATIN - PROCESS INPUT SCATTEROMETERS

!        H. HERSBACH       ECMWF     21/11/06 
!        D. VASILJEVIC     ECMWF     12/12/00 

!     PURPOSE
!     -------

!        PROCESS INPUT ASCAT SCATTEROMETERS

!**   INTERFACE
!     ---------

!        CALL ASCATIN  (KSCATP,
!                     KOBTYP,KCDTYP,KOBSQNO,KCDSQNO,
!                     LDMESAGE,LDTAKEN)

!     WHERE:
!            KSCATP   = SCAT REP POINTER

!        ASCATIN IS CALLED BY SUBROUTINE SCAT_OB

!     METHOD
!     ------

!        THE CMA SCAT. RECORD IS BUILT UP FROM THE EXPANDED BUFR ARRAYS.
!        ORIGINAL FROM ERSIN TEMPLATE

!     EXTERNALS
!     ---------

!        ASCATIF  - ASCAT. PROCESSING INTERFACE
!        PRLMCHK  - PRELIMINARY CHECKS
!        GETSETE  - GET/SET BODY ENTRY
!        FILFBDE  - UPDATE  BODY ENTRY
!        ERRSTAT  - OBS. ERROR
!        PPVAFL   - PRESSURE/VARIABLE FLAG RESET
!        OBINSTP  - INSTRUMENT TYPE
!        OBSCHAR  - OBS. CHARACTERISTICS

!     MODIFICATIONS
!     -------------
!        2007-06  C. Payan : CY32T0 instype initialized by MDB_INSTTYPE_AT_HDR (producter
!        code at Meteo-France), set to NMDI (in OBINSTP) only if initial value is 0
!        2008-05-05 K. Scipal: ASCAT soil moisture added

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE PARERSCA
USE YOMDB
USE YOMVNMB  , ONLY : NVNUMB
USE YOMANCS  , ONLY : NMDI ,RMDI ,RDEGREES ,RADIANS,RUPMLIM,RDWMLIM, &
                    & EPSMAC,RTICE,RTWAT,R2ES,R3LES,R3IES,R4LES,R4IES,RTT
USE YOMNMCOD , ONLY : NSCACVC
USE YOMMKODB , ONLY : LSCATINT ,NMKCMVSE ,LTOTREM
USE YOMNMEV  , ONLY : ND1EVENT
USE YOMLUN   , ONLY : NULOUT

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KSCATP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBTYP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KCDTYP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBSQNO 
INTEGER(KIND=JPIM),INTENT(IN)    :: KCDSQNO 
LOGICAL           ,INTENT(INOUT) :: LDMESAGE 
LOGICAL           ,INTENT(OUT)   :: LDTAKEN 

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

REAL(KIND=JPRB)    , ALLOCATABLE :: ZROBODY(:,:), ZSATBODY(:,:)
INTEGER(KIND=JPIM) , ALLOCATABLE :: IBODY  (:,:), IORDER(:)

REAL(KIND=JPRB) ::&
 &  ZBRINC (JPBRADS)  ,  ZBRAZI (JPBRADS)  ,  ZBRS0  (JPBRADS)&
 & ,ZBRLFR (JPBRADS)  ,  ZBRKP  (JPBRADS)  ,  ZNOISEM(JPBRADS)&
 & ,ZRETU  (JPBRASWI)  , ZRETV  (JPBRASWI) ,  ZINRES (JPBRASWI)

INTEGER(KIND=JPIM) :: IS0QF(JPBRADS), IKPQF(JPBRADS)

INTEGER(KIND=JPIM), PARAMETER :: IVAR=5
INTEGER(KIND=JPIM)            ::&
 &  JVAR(0:IVAR),JVARMAX(0:IVAR),JVARNUM(0:IVAR),JVNM(0:IVAR)

INTEGER(KIND=JPIM) :: INWIND, INBODY, IVNM,&
 & IOBDATE,IOBTIME, ISTID, &
 & INSTYP, IREPST, ISATID, ICELLNO, IPROFLAG

INTEGER(KIND=JPIM) :: JALL, IALL, IV,JV,IH,INDXU,INDXV,IWIND,&
 & IAUSTAT, IAUEVEN1, IAUEVEN2, IAURDBFL, IAUANFLG, &
 & IAUPFLG, IAUFLG  , IAUVERCO  

LOGICAL :: LLNOSOL, LLRESORT, LLFAIL, LLREMOVE, LLUNKNOWN

CHARACTER (LEN = 8) :: CLSTID

REAL(KIND=JPRB) :: ZDIRSKI, ZWE, ZLAT, ZLON, ZTIMDIF

REAL(KIND=JPRB) :: ZAU, ZAUPRES, ZAUPRL, &
 & ZAUPERR, ZAUOERR, ZAUFERR, ZAURERR, &
 & ZAUFGER, ZAUFGCC1, ZAUFGCC2, &
 & ZAUFGDEP, ZAUANDEP  

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "ascatif.intfb.h"
#include "finoerr.intfb.h"
#include "filfbde.intfb.h"
#include "getsete.intfb.h"
#include "obinstp.intfb.h"
#include "ppvafl.intfb.h"
#include "prlmchk.intfb.h"

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

#include "fcobs.h"

#include "stmfun_ifs.h"

#include "openmp_obs.h"

!*
!        1.             PRESET
!                       ------

IF (LHOOK) CALL DR_HOOK('ASCATIN',0,ZHOOK_HANDLE)

LLRESORT = .true.

!*           REST      AMBIG U   AMBIG V    SIGMA0    ,1+1 SOIL MOISTURE
JVAR     = (/NMDI     ,62       ,61        ,53        ,89        ,90        /)
JVARMAX  = (/0        ,JPBRASWI ,JPBRASWI  ,JPABODYS0 ,JPABODYSM ,JPABODYSM /)

JVNM(0)=0
DO IV=1, IVAR
   JVNM(IV)=NVNUMB(JVAR(IV))
ENDDO

!*
!-----------------------------------------------------------------------

!        2.             GENERAL OBSERVATION INFO.
!                       -------------------------
!*          2.1         GET OBS. PARAMETERS FROM ODB HEADER

ZLAT   = ROBHDR(KSCATP,MDBLAT) * RDEGREES
ZLON   = ROBHDR(KSCATP,MDBLON) * RDEGREES
IOBDATE= ROBHDR(KSCATP,MDBDAT)
IOBTIME= ROBHDR(KSCATP,MDBETM)
CLSTID = TRANSFER(ROBHDR(KSCATP,MDBSID), CLSTID)
ISTID  = 0
READ(CLSTID(1:8),'(A8)') ISTID
IREPST = ROBHDR(KSCATP,MDBRST)


!*          2.2         DEFINE INSTRUMENT TYPE

INSTYP  = 0
CALL OBINSTP(ZLAT,ZLON,ISTID,&
 & KOBTYP,KCDTYP,&
 & INSTYP)  

!*          2.3         SET INSTRUMENT TYPE INTO OBSERVATION
!                       CHARACTERISTICS

IF (ROBHDR(KSCATP,MDB_INSTTYPE_AT_HDR) == 0._JPRB) ROBHDR(KSCATP,MDB_INSTTYPE_AT_HDR) = INSTYP

!*
!-----------------------------------------------------------------------

!        3.             PRELIMINARY CHECKS
!                       ------------------

!*          3.1         REPORT PARAMETERS

LLFAIL   = .FALSE.
LLREMOVE = .FALSE.
CALL PRLMCHK(KOBTYP,KCDTYP,ZLAT,ZLON,IOBDATE,IOBTIME,IREPST,ZTIMDIF,&
 & LDMESAGE,LLFAIL,LLREMOVE)  

!*          3.1.0       UPDATE REPORT STATUS

ROBHDR(KSCATP,MDBRST) = IREPST

!*          3.1.1       FAILED/REMOVED REPORT

IF(LLFAIL .OR. LLREMOVE  ) THEN
  IF(LTOTREM) THEN
    IF(LDMESAGE)           THEN
      WRITE(NULOUT,'('' LAT.     :'',F10.2)') ZLAT
      WRITE(NULOUT,'('' LON.     :'',F10.2)') ZLON
      CALL FLUSH(NULOUT)
    ENDIF
!*        3.1.2         PREMATURE EXIT FROM ROUTINE
    IF (LHOOK) CALL DR_HOOK('ASCATIN',1,ZHOOK_HANDLE)
    RETURN
  ENDIF
ENDIF

!*          3.2.1       SATHDR

!*          3.2.1.1     SAT ID

ISATID   = SATHDR(KSCATP,MDB_SATID_AT_SAT)

!*          3.2.1.3     CELL NO.

ICELLNO  = SATHDR(KSCATP,MDBSCCNO)

!*
!-----------------------------------------------------------------------

!*          3.3         CHECK BODY/SCATT_BODY PARAMETERS

!*          3.3.1       INITIALIZATION

JVARNUM(:)=0

ZBRS0 (:) = RMDI
IS0QF (:) = NMDI
IKPQF (:) = NMDI
ZBRINC(:) = RMDI
ZBRAZI(:) = RMDI
ZBRKP (:) = RMDI
ZBRLFR(:) = RMDI

!*          3.3.2       LOOP OVER ALL BODIES
CHECK_BODIES: DO JALL = MLNKH2B(KSCATP),MLNKH2B(KSCATP+1)-1

  IVNM = ROBODY(JALL,MDBVNM)
  LLUNKNOWN=.TRUE.
  IV=0
  DO IH=1,IVAR
    IF(IVNM == JVNM(IH)) THEN
      IV=IH
      LLUNKNOWN=.FALSE.
      JVARNUM(IH)=JVARNUM(IH)+1
    ENDIF
  ENDDO
  IF(LLUNKNOWN) THEN 
    LDMESAGE = .TRUE.
    WRITE(NULOUT,'('' ASCATIN  ; UNEXPECTED VARIABLE: '',I10)') IVNM
  ENDIF

!*          3.3.3       GET SIGMA'S, GEOMETRY, ETC. FOR WIND RETRIEVAL

  IF(IVNM == NVNUMB( 53) .AND. JVARNUM(IV) <= JPBRADS) THEN
     JV=JVARNUM(IV)
     ZBRS0 (JV) = ROBODY (JALL,MDBVAR  )
     IS0QF (JV) = SATBODY(JALL,MDBSCS0Q)
     IKPQF (JV) = SATBODY(JALL,MDBSCKPQ)
     ZBRINC(JV) = SATBODY(JALL,MDBSCBIA)
     ZBRAZI(JV) = SATBODY(JALL,MDBSCBAA)
     ZBRKP (JV) = SATBODY(JALL,MDBSCKP )
     ZBRLFR(JV) = SATBODY(JALL,MDBSCLFR)
  ENDIF

!*          3.3.4       CLOSE THE LOOP
ENDDO CHECK_BODIES

!*          3.3.5       WE REQUIRE: 2 AMBIG U, 2 ABIG V, 3 SIGMA0, 1+1 SOIL MOISTURE

IF( MINVAL(JVARNUM-JVARMAX) < 0) THEN
  WRITE(NULOUT,'('' ERROR IN SUBROUTINE ASCATIN; '')')
  WRITE(NULOUT,'('' INSUFFICIENT NUMBER OF BODIES; '')')
  DO IV=1,IVAR
    WRITE(NULOUT,'('' IV,JVARNUM,JVARMAX : '',3(I2,1X))')&
     & IV,JVARNUM(IV),JVARMAX(IV)
  ENDDO
  CALL ABOR1(' ASCATIN : ')
ENDIF


!*
!-----------------------------------------------------------------------

!        4.             WIND RETRIEVAL
!                       --------------

!*          4.1         PRESET VALUES
IPROFLAG   = 0          !* PRODUCT FLAG
ZRETU  (:) = RMDI       !* WIND COMPONENTS
ZRETV  (:) = RMDI
ZINRES (:) = RMDI       !* INVERSION RESIDUALS
ZNOISEM(:) = RMDI       !* MODELLED NOISE
ZDIRSKI    = RMDI       !* DIRECTIONAL SKILL
ZWE        = RMDI       !* WIND COMPONENT OBSERVATION ERROR
INWIND     = JPBRASWI   !* MAXIMUM NUMBER OF ALLOWED WIND SOLUTIONS
LLNOSOL    = .TRUE.     !* WIND INVERSION UNSUCCESFUL

!*          4.2         CALL INTERFACE 
IF(LSCATINT)  THEN
  CALL ASCATIF(ISATID,ICELLNO,IS0QF,IKPQF,&
   & ZBRAZI  ,ZBRINC ,ZBRS0 ,ZBRKP ,ZBRLFR ,INWIND,&
   & IPROFLAG,ZRETU  ,ZRETV  ,ZINRES ,ZDIRSKI,ZNOISEM,ZWE,&
   & LLNOSOL                                               )  

!*          4.3           IN CASE OF UNSUCCESSFUL INVERSION 
!*                        ENSURE THAT ALL WINDS ARE UNDEFINED
  IF(LLNOSOL) THEN
    ZRETU(:) = RMDI
    ZRETV(:) = RMDI
  ENDIF
ENDIF

!*
!-----------------------------------------------------------------------

!        5.             MODIFY SATHEADER
!                       -----------------

!*          5.1         PRODUCT FLAG

SATHDR(KSCATP,MDBSCPFL) = IPROFLAG

!*
!-----------------------------------------------------------------------

!        6.             UPDATE BODY/SCATT_BODY ELEMENTS
!                       -------------------------------

!*          6.1         ALLOCATION/INITIALIZATION

INBODY=MLNKH2B(KSCATP+1)-MLNKH2B(KSCATP)
IF(INBODY <= 0) THEN
  IF (LHOOK) CALL DR_HOOK('ASCATIN',1,ZHOOK_HANDLE)
  RETURN
ENDIF

ALLOCATE(IBODY(0:IVAR,INBODY))
IBODY(:,:) = 0
JVARNUM(:) = 0

!*          6.2         LOOP OVER BODY ELEMENTS
UPDATE_BODIES: DO JALL = MLNKH2B(KSCATP),MLNKH2B(KSCATP+1)-1

!*          6.3         CHECK ON BUFR MISSING INDICATOR

!*          6.4.1       PRESSURE
   IF( (ROBODY(JALL ,MDBPPP) <= RUPMLIM)   .AND. &
   &   (ROBODY(JALL ,MDBPPP) >= RDWMLIM) ) ROBODY(JALL ,MDBPPP ) = RMDI

!*          6.3.2       VARIABLE
   IF( (ROBODY(JALL ,MDBVAR) <= RUPMLIM)   .AND. &
   &   (ROBODY(JALL ,MDBVAR) >= RDWMLIM) ) ROBODY(JALL ,MDBVAR ) = RMDI


!*          6.4         PRESET/GET LOCAL COPY FROM ODB BODY
!*                      OBS VALUE, PRESSURES, ERRORS, DEPATURES ARE PRESET TO RMDI
   CALL GETSETE(JALL ,&
    & ZAUPRES,ZAUPRL,ZAU ,&
    & ZAUFGER,ZAUFGCC1,ZAUFGCC2,&
    & ZAUPERR,ZAUOERR,ZAUFERR,ZAURERR,&
    & ZAUFGDEP,ZAUANDEP,&
    & IAUSTAT,IAUEVEN1,IAUEVEN2,IAURDBFL,IAUANFLG,&
    & IAUFLG,IAUPFLG)  

   ZAUPRES = ROBODY(JALL,MDBPPP)     !* OVERWRITE PRESETED VALUE RMDI
   ZAU     = ROBODY(JALL,MDBVAR)     !* OVERWRITE PRESETED VALUE RMDI

   IVNM    = ROBODY(JALL,MDBVNM)
   IAUVERCO= ROBODY(JALL,MDBVCO)

!*          6.6         CHECK OBSERVATION IDENTITY
   IV=0
   DO IH=1,IVAR
      IF((IVNM == JVNM(IH)).AND.(JVARNUM(IH) < JVARMAX(IH))) IV=IH
   ENDDO
   JVARNUM(IV)=JVARNUM(IV)+1
   IBODY(IV,JVARNUM(IV))=JALL

!*          6.7         UPDATE BODY/SCATT_BODY FOR AMBIGUOUS WIND
   IF((JVAR(IV) == 62) .OR. (JVAR(IV) == 61)) THEN
      IWIND=JVARNUM(IV)
      IF (JVAR(IV) == 62) ZAU=ZRETU(IWIND)  ! AMBIGUOUS U COMP
      IF (JVAR(IV) == 61) ZAU=ZRETV(IWIND)  ! AMBIGUOUS V COMP

      SATBODY(JALL,MDBSCRES) = ZINRES(IWIND)
      SATBODY(JALL,MDBSCDIS) = ZDIRSKI

      ZAUOERR = ZWE
      CALL FINOERR(ZAUPERR,ZAUOERR,ZAUFERR)
      IAUVERCO = NSCACVC
      ZAUPRES  = IWIND
   ENDIF

!*          6.8         STATUS, EVENTS, FLAGS
   IF(ZAU == RMDI) THEN
      IAUSTAT=ICHSTAT_REJECT(IAUSTAT)
   ENDIF

   IF(IV == 0) THEN
      IAUSTAT = ICHSTAT_REJECT( IAUSTAT )
      IAUEVEN1=ICHEV1(IAUEVEN1,ND1EVENT(17))
   ELSE
      IAUPFLG=0
      IAUFLG=0
      IF(NMKCMVSE(JVAR(IV),KCDSQNO,KOBSQNO) == 0) THEN
         IAUSTAT = ICHSTAT_REJECT( IAUSTAT )
      ENDIF
   ENDIF
   CALL PPVAFL(IAUPFLG,IAUFLG,IAURDBFL)

!*          6.8         DEPARTURES

!*          6.9         PUT UPDATED BODY ELEMENT BACK IN ODB
   CALL FILFBDE(JALL ,IVNM   ,IAUVERCO ,&
    & ZAUPRES ,ZAUPRL,ZAU ,&
    & ZAUFERR ,ZAUOERR ,ZAURERR ,ZAUPERR,&             !* NOTE DIFFERENCE IN ORDER
    & ZAUFGER ,ZAUFGCC1,ZAUFGCC2,&                     !* COMPARED TO GETSE
    & ZAUFGDEP,ZAUANDEP,&
    & IAUSTAT ,IAUEVEN1,IAUEVEN2,IAURDBFL,IAUANFLG) 

!*          6.10        END LOOP
ENDDO UPDATE_BODIES

!*
!-----------------------------------------------------------------------

!        7.             FINISH OFF REPORT CREATION
!                       --------------------------
LDTAKEN = .TRUE.

!*
!-----------------------------------------------------------------------

!        8.             RESORT BODIES
!                       -------------

IF (.NOT.LLRESORT) THEN
  DEALLOCATE(IBODY)
  IF (LHOOK) CALL DR_HOOK('ASCATIN',1,ZHOOK_HANDLE)
  RETURN
ENDIF

!*          8.1         ALLOCATE ARRAYS

ALLOCATE( ZROBODY(INBODY,NCOLS_ROBODY ))
ALLOCATE(ZSATBODY(INBODY,NCOLS_SATBODY))
ALLOCATE( IORDER(INBODY))

!*          8.2         DETERMINE REORDERING
!*                      U,V,U,V,OTHER ACCEPTED VARS,REST
IORDER(:)=0

!* FIRST FIND INDICES FOR U AND V
INDXU=0
INDXV=0
DO IV=1,IVAR
  IF (JVAR(IV) == 62) INDXU=IV
  IF (JVAR(IV) == 61) INDXV=IV
ENDDO

IF (INDXU == 0)                     LLRESORT=.FALSE.
IF (INDXV == 0)                     LLRESORT=.FALSE.
IF (JVARMAX(INDXU)/=JVARMAX(INDXV)) LLRESORT=.FALSE.
IF (.NOT.LLRESORT) THEN
  WRITE(NULOUT,'(''  ASCATIN WARNING: CANNOT REORDER'')')
  WRITE(NULOUT,*)INDXU,INDXV,JVARMAX
  DEALLOCATE(ZROBODY,ZSATBODY,IORDER,IBODY)
  IF (LHOOK) CALL DR_HOOK('ASCATIN',1,ZHOOK_HANDLE)
  RETURN
ENDIF

IALL=0
DO IH=1,JVARMAX(INDXU)
  IALL=IALL+1
  IORDER(IALL)=IBODY(INDXU,IH)   !* U
  IALL=IALL+1
  IORDER(IALL)=IBODY(INDXV,IH)   !* V
ENDDO
DO IV=1,IVAR
  IF(IV == INDXU) CYCLE
  IF(IV == INDXV) CYCLE
  DO IH=1, JVARMAX(IV)
    IALL=IALL+1
    IORDER(IALL)=IBODY(IV,IH)   !* E.G. SIGMA0
  ENDDO
ENDDO
DO IH=1,INBODY
  IF(IBODY(0,IH) /= 0) THEN
    IALL=IALL+1
    IORDER(IALL)=IBODY(0,IH)    !* REST
  ENDIF
ENDDO

IF( MINVAL(IORDER) <  MLNKH2B(KSCATP) .OR. &
 &  MAXVAL(IORDER) >= MLNKH2B(KSCATP+1) ) THEN
  DEALLOCATE(ZROBODY,ZSATBODY,IORDER,IBODY)
  WRITE(NULOUT,'(''   IORDER: '',2(I1,1X))')IORDER
  CALL ABOR1(' ASCATIN : ')
ENDIF

!*          8.2         LOOP OVER BODY ELEMENTS
REORDER_BODIES: DO IALL = 1, INBODY
  JALL=IORDER(IALL)
  ZROBODY(IALL,1:NCOLS_ROBODY ) =  ROBODY(JALL,1:NCOLS_ROBODY )
  ZSATBODY(IALL,1:NCOLS_SATBODY) = SATBODY(JALL,1:NCOLS_SATBODY)
ENDDO REORDER_BODIES

COPY_BODIES: DO IALL = 1, INBODY
    JALL=MLNKH2B(KSCATP)+IALL-1
    ROBODY(JALL,1:NCOLS_ROBODY ) =  ZROBODY(IALL,1:NCOLS_ROBODY )
    ROBODY(JALL,MDBESQN) = IALL
   SATBODY(JALL,1:NCOLS_SATBODY) = ZSATBODY(IALL,1:NCOLS_SATBODY)
ENDDO COPY_BODIES

!*          8.3         CLEAN UP
DEALLOCATE(ZROBODY,ZSATBODY,IORDER,IBODY)
!*
!-----------------------------------------------------------------------

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