SUBROUTINE OBSCHAR(CDSET,KOBTYP,KCDTYP,PLAT,PLON,KOBCHAR,KSET)

!**** SUBROUTINE OBSCHAR - DEFINE OBSERVATION CHARACTERSTICS

!        D. VASILJEVIC     ECMWF     04/07/94

!     PURPOSE
!     -------

!        CMA OBSERVATION CHARACTERISTICS DEFINITION

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

!        CALL OBSCHAR(CDSET,
!                     KOBTYP,KCDTYP,PLAT,PLON,
!                     KOBCHAR,KSET,CDSET)
!     WHERE:
!           CDSET   = ACTION
!           KOBTYP  = OBS. TYPE
!           KCDTYP  = CODE TYPE
!           PLAT    = LATITUDE
!           PLON    = LONGITUDE
!           KOBCHAR = OBSERVATION CHARACTERISTICS STORE WORD
!           KSET    = OBSERVATION CHARACTERISTICS TO SET

!        OBSCHAR IS CALLED BY SUBROUTINES:

!     METHOD
!     ------

!        AN OBSERVATION CHARACTERISTIC IS SET.

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

!        ENDRUN - ABORT RUN

!     MODIFICATIONS
!     -------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning 

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

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMCMHDR , ONLY : NCDTBP   ,NCDTOC   ,NINSTBP  ,NINSTOC  ,&
 & NRETTBP  ,NRETTOC  ,NARETBP  ,NARETOC  
USE YOMANCS  , ONLY : NMDI     ,NBITS    ,RADIANS
USE YOMLUN   , ONLY : NULOUT

IMPLICIT NONE

CHARACTER(LEN=*)  ,INTENT(IN)    :: CDSET 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBTYP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KCDTYP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLAT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLON 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KOBCHAR 
INTEGER(KIND=JPIM),INTENT(INOUT) :: KSET 
INTEGER(KIND=JPIM) :: IBITBP, IBITOC

REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"

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

#include "fcobs.h"
!        1.             WHAT OBSERVATION CHARACTERISTICS?
!                       ---------------------------------

IF (LHOOK) CALL DR_HOOK('OBSCHAR',0,ZHOOK_HANDLE)
IBITBP = 0
IBITOC = 0

!*          1.1         OBS. CODE TYPE

IF(CDSET == 'CODE TYP')               THEN
  IBITBP = NCDTBP
  IBITOC = NCDTOC

!*          1.2         INSTRUMENT TYPE

ELSEIF(CDSET == 'INST TYP')          THEN
  IBITBP = NINSTBP
  IBITOC = NINSTOC

!*          1.3         RETREIVL TYPE

ELSEIF(CDSET == 'RETR TYP')          THEN
  IBITBP = NRETTBP
  IBITOC = NRETTOC

!*          1.4         GEOGRAPHICAL AREA TYPE

ELSEIF(CDSET == 'AREA TYP')          THEN
  IBITBP = NARETBP
  IBITOC = NARETOC

!*          1.5         UNKNOWN CHARACTERISTICS

ELSE
  WRITE(NULOUT,'(''0ERROR IN SUBROUTINE OBSCHAR'')')
  WRITE(NULOUT,'('' UNKNOWN TYPE OF OBS. CHARACTERISTICS'')')
  WRITE(NULOUT,'('' OBS. TYPE          : '',I10)') KOBTYP
  WRITE(NULOUT,'('' CODE TYPE          : '',I10)') KCDTYP
  WRITE(NULOUT,'('' TYPE OF OBS. CHAR. :'',A)')    CDSET
  CALL ABOR1('SUBROUTINE OBSCHAR')
ENDIF
!*
!-----------------------------------------------------------------------

!        2.             SET OBSERVATION CHARACTERISTICS
!                       -------------------------------

!*          2.1         CHECK BIT DEFINITIONS

!*          2.1.1       CHECK IF DEFINED AT ALL

IF(IBITBP == NMDI.OR.IBITOC == NMDI    )                  THEN
  WRITE(NULOUT,'(''0ERROR IN SUBROUTINE OBSCHAR'')')
  WRITE(NULOUT,'('' BIT DEFINITION NOT DEFINED'')')
  WRITE(NULOUT,'('' OBS. TYPE  : '',I10)') KOBTYP
  WRITE(NULOUT,'('' CODE TYPE  : '',I10)') KCDTYP
  WRITE(NULOUT,'('' OBS. CHAR. :'',A)')    CDSET
  CALL ABOR1('SUBROUTINE OBSCHAR')
ENDIF

!*          2.1.2       CHECK IF IT CAN FIT

IF(KSET == NMDI)                     THEN
  KSET = NBITS (IBITOC)
ENDIF
IF(KSET > NBITS (IBITOC))              THEN
  WRITE(NULOUT,'(''0WARNING IN SUBROUTINE OBSCHAR'')')
  WRITE(NULOUT,'('' VALUE TO BE PACKED LARGER THEN'',&
   & '' NO. OF BITS RESERVED'')')  
  WRITE(NULOUT,'('' ALL BITS SET TO 1'')')
  WRITE(NULOUT,'('' OBS. TYPE  : '',I10)')   KOBTYP
  WRITE(NULOUT,'('' CODE TYPE  : '',I10)')   KCDTYP
  WRITE(NULOUT,'('' LATITUDE   : '',F10.2)') PLAT
  WRITE(NULOUT,'('' LONGITUDE  : '',F10.2)') PLON
  WRITE(NULOUT,'('' OBS. CHAR. :'',A)')      CDSET
  WRITE(NULOUT,'('' VALUE      : '',I10)')   KSET
  WRITE(NULOUT,'('' NO. OF BITS: '',I10)')   IBITOC
  KSET = NBITS (IBITOC)
ENDIF

!*          2.2         STORE IT

KOBCHAR = INSERT(KOBCHAR,KSET,IBITBP)
!*
!-----------------------------------------------------------------------

!        3.             RETURN
!                       ------

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