SUBROUTINE OBATABS(KTSLOTNO,&
 & KOBTOT ,KOBTOV ,KOBNTV ,KOBSCA ,&
 & KOFFTOT,KOFFTOV,KOFFNTV,KOFFSCA)  

!**** SUBROUTINE OBATABS - CREATE NEEDED OBS. TABLES

!          D. VASILJEVIC     ECMWF          20/5/1991

!*    METHOD
!     ------
!        THE OBS. (CMA) ARRAY FILE IS SEARCHED AND TABLES CREATED.1RAY

!*    EXTERNALS
!     ---------
!        CALL OBATABS(...)

!        OBATABS IS CALLED BY SUBROUTINE SUOBS AND OBSM.

!**   MODIFICATIONS
!     -------------
!        Heikki Jarvinen 95-09-20 : New CMA- file format
!        Mats hamrud     95-09-20 : New CMA- file format
!        Erik Andersson  97-01-08 : Prepare for RTOVS
!        R. Randriamampianina 97-04-17 : ALADIN 3DVAR
!        Modified 98-08-10 by K. YESSAD: removal of LRPOLE option.
!         - removal of LRPOLE in YOMCT0 and of code under LRPOLE.
!        W.Sadiki, C.Soci 99-june : TOVS for ALADIN in sm case; 
!        A. Horanyi 99-07-19 : avoid controlling the number of obs if aladin
!        Elias Holm    2000-02-28 : Added ozone (NSTRO3) to TOVS observations
!        M. Janousek 01-04-16 : Replace EGGDIR by ELALO2XY
!        S. Kertesz 02-06 : Corrected ELON1, ELON2 for LAM test
!        C. Fischer 03-04-09 : cleaned out lam+tovs+sm case (obsolete)
!        C. Fischer 04-10-07 : print warning if obs outside LAM domain
!                              with a 'grepgeom' tag for listing check
!        JD. Gril 23-Nov-2004 : Modifs for Mercator Rotated Tilted
!        R. Randriamampianina 28-May-2009 : Skip first area check of obs.
!                                           if LRPLANE
!     ------------------------------------------------------------------------

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

USE YOMCT0   , ONLY : LELAM    ,LRPLANE
USE YOMDIM   , ONLY : NDGUNG   ,NDGUXG   ,NDLUNG   ,NDLUXG
USE YOMDIMO  , ONLY : NACTIM
USE YOMCMA   , ONLY : NMXOTP
USE YOMECTAB , ONLY : NOOPOT   
USE YOMLUN   , ONLY : NULERR   ,NULOUT
USE YOMCST   , ONLY : RPI      
USE YOMCOCTP , ONLY : NSATEM   ,NSTMCD   ,NSTOVS   ,NSTRO3   ,&
 & NGTHR1   ,NGTHRB   ,NGTHR2   ,NSSMI   ,NSCATT, NSMOS, NTCWC 
USE YOMGEM   , ONLY : NSTTYP   ,RMUCEN   ,RLOCEN   ,RSTRET
USE YEMGEO   , ONLY : ELON1    ,ELAT1    ,ELON2    ,ELAT2    ,&
 & EDELX    ,EDELY    ,ELON0    ,ELAT0    ,ELONC    ,ELATC    ,&
 & LMRT  
USE YOMANCS  , ONLY : RMDI
USE YOMDB
USE PARDIMO  , ONLY : JPXTIM

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KTSLOTNO
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBTOT
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBTOV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBNTV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOBSCA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOFFTOT 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOFFTOV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOFFNTV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KOFFSCA 
REAL(KIND=JPRB) :: ZSLAR(KOBTOT), ZSLOR(KOBTOT), ZCLOR(KOBTOT)
REAL(KIND=JPRB) :: ZSLAC(KOBTOT), ZSLOC(KOBTOT), ZCLOC(KOBTOT)
REAL(KIND=JPRB) :: Z_PGX(KOBTOT), Z_PGY(KOBTOT)
INTEGER(KIND=JPIM) :: IOBNUMA(KOBTOT)
   
INTEGER(KIND=JPIM) :: IAD, ICDTYP, ICHECK, &
 & ILEN, INONTOVS, INOOBS, INOTOVS, &
 & IOBS, IOTP, ISCATT, ITYP, &
 & JOBS, JT0, IRET, INFO(1)  

REAL(KIND=JPRB) :: Z2PI, ZCLAP, ZCLOP, ZELAT1, ZELAT2, ZELON1,&
 & ZELON2, ZEXT, ZFACDI, ZLAT, ZLON, ZSLAP, &
 & ZSLOP, ZTLON, ZX, ZX1, ZX2, ZY, ZY1, ZY2, ZINFO(1)  
REAL(KIND=JPRB) :: ZLON1, ZLAT1, ZLON0, ZLAT0, ZLONC, ZLATC, Z180SPI
REAL(KIND=JPRB) , ALLOCATABLE :: ZGELAM(:), ZGELAT(:), ZGNORX(:), ZGNORY(:)

LOGICAL, SAVE :: LLFIRST_TIME = .TRUE.
LOGICAL, SAVE :: LLCALLED(-1:JPXTIM)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "getdb.h"
#include "putdb.h"
#include "abortdb.h"
END INTERFACE

#include "abor1.intfb.h"
#include "elalo2xy.intfb.h"
#include "trareca.intfb.h"

#include "openmp_obs.h"
!     ------------------------------------------------------------------
!*       1.       CREATE REQUIRED TABLES
!                 ----------------------

!*          1.0   PRESET

IF (LHOOK) CALL DR_HOOK('OBATABS',0,ZHOOK_HANDLE)
IF (LLFIRST_TIME) THEN
  LLCALLED(:) = .FALSE.
  LLFIRST_TIME = .FALSE.
ENDIF

IF (LLCALLED(KTSLOTNO) .AND. LHOOK) CALL DR_HOOK('OBATABS',1,ZHOOK_HANDLE)
IF (LLCALLED(KTSLOTNO)) RETURN ! THIS OPTIMIZATION THAT PAYS OFF IN MINIMIZATION/FORECAST ERROR CALC.

IRET = 0
CALL GSTATS(1793,0)
CALL GETDB('OBATABS', 0, IRET, INFO, 0, ZINFO, 0, &
 & -1, KTSLOTNO, -1, -1, -1, -1)  
CALL GSTATS(1793,1)

IF (IRET /= KOBTOT) THEN
  WRITE(NULERR,'('' ** INCONSISTENT NO. OF OBSERVATIONS FROM GETDB'')')
  WRITE(NULERR,*)'Expecting KOBTOT=',KOBTOT,', but got =',IRET
  CALL ABORTDB('OBATABS','INCONSISTENCIES FROM GETDB',IRET)
ENDIF

INOOBS   = 0
INOTOVS  = KOFFTOV
INONTOVS = KOFFNTV
ISCATT   = KOFFSCA
Z2PI     = 2.0_JPRB*RPI
Z180SPI  = 180._JPRB/RPI
DO JT0 = 1 , NMXOTP
  NOOPOT(JT0) = 0
ENDDO

!*          1.1

DO JOBS = 1 , KOBTOT
  IOBS = KOFFTOT+JOBS
  INOOBS = INOOBS + 1

!*          1.1.4 FIND OUT OBS. TYPE

  IOTP = ROBHDR(JOBS,MDBOTP)
  IF (IOTP < 1 .or. IOTP > NMXOTP) THEN
    WRITE(NULERR,*)'***ERROR IN OBATABS: INVALID OBSTYPE IOTP=',IOTP,' AT JOBS=',JOBS 
    CALL ABORTDB('OBATABS','INVALID OBSTYPE IOTP',IOTP)
  ENDIF
  NOOPOT(IOTP) = NOOPOT(IOTP) + 1

!*          1.1.5 MAPPING OF OBS. ARRAY TO MODEL ARRAYS

  IF (IOTP == NSATEM) THEN
    ICDTYP = ROBHDR(JOBS,MDB_CODETYPE_AT_HDR)
    IF (ICDTYP == NGTHR1 .OR. ICDTYP == NGTHR2 .OR.&
       & ICDTYP == NGTHRB .OR.&
       & ICDTYP == NSTMCD .OR.&
       & ICDTYP == NSTOVS .OR.&
       & ICDTYP == NSTRO3 .OR.&
       & ICDTYP == NSSMI .OR. ICDTYP == NSMOS .OR. ICDTYP == NTCWC) THEN  
      INOTOVS = INOTOVS + 1
    ELSE
      WRITE(NULERR,*)'***ERROR IN OBATABS: INVALID SATEM CODETYPE=',ICDTYP,' AT JOBS=',JOBS
      CALL ABORTDB('OBATABS','INVALID SATEM CODETYPE',ICDTYP)
    ENDIF
  ELSEIF(IOTP == NSCATT) THEN
    ISCATT = ISCATT + 1
  ELSE
    INONTOVS = INONTOVS + 1
  ENDIF

ENDDO

!*          1.3   CHECK THE CHANGE OF THE ROW??

IF ( .NOT.LELAM ) THEN

  IF (NSTTYP  ==  1) THEN
    DO JOBS = 1 , KOBTOT
      IAD = JOBS
      ROBHDR(IAD,MDBTLA) = ROBHDR(IAD,MDBLAT)
      IF (ROBHDR(IAD,MDBLON) < 0.0_JPRB) THEN
        ROBHDR(IAD,MDBTLO) = Z2PI + ROBHDR(IAD,MDBLON)
      ELSE
        ROBHDR(IAD,MDBTLO) = ROBHDR(IAD,MDBLON)
      ENDIF
    ENDDO
  ELSEIF (NSTTYP == 2) THEN
    DO JOBS = 1 , KOBTOT
      IAD = JOBS
      ZSLAR(JOBS) = SIN(ROBHDR(IAD,MDBLAT))
      ZSLOR(JOBS) = SIN(ROBHDR(IAD,MDBLON))
      ZCLOR(JOBS) = COS(ROBHDR(IAD,MDBLON))
    ENDDO
    ZSLAP  = RMUCEN
    ZCLAP  = SQRT(1.0_JPRB - RMUCEN**2)
    ZSLOP  = SIN(RLOCEN)
    ZCLOP  = COS(RLOCEN)
    ZFACDI = RSTRET
    ITYP   = 2
    CALL TRARECA(ZSLAC,ZSLOC,ZCLOC,ZSLAR,ZSLOR,ZCLOR,KOBTOT,&
     & ZSLAP,ZCLAP,ZSLOP,ZCLOP,ZFACDI,ITYP)  
    DO JOBS = 1 , KOBTOT
      IAD = JOBS
      ROBHDR(IAD,MDBTLA) = ASIN(ZSLAC(JOBS))
      IF ( ZSLOC(JOBS) < 0 ) THEN
        ROBHDR(IAD,MDBTLO) = Z2PI - ACOS(ZCLOC(JOBS))
      ELSE
        ROBHDR(IAD,MDBTLO) = ACOS(ZCLOC(JOBS))
      ENDIF
    ENDDO
  ENDIF

ELSE

!         For the limited area model ALADIN

  ZEXT = (15._JPRB*RPI)/180._JPRB
  ZELAT1 = ELAT1 - ZEXT
  ZELAT2 = ELAT2 + ZEXT
  ZELON1 = ELON1 - ZEXT
  ZELON2 = ELON2 + ZEXT

  IF (ZELON1 < 0.0_JPRB) ZELON1 = ZELON1 + Z2PI
  IF (ZELON2 < 0.0_JPRB) ZELON2 = ZELON2 + Z2PI

!  calculation of the limites of the domain C+I in the working grid
  ZX1 = REAL(NDLUNG-1,JPRB)
  ZX2 = REAL(NDLUXG-1,JPRB)
  ZY1 = REAL(NDGUNG-1,JPRB)
  ZY2 = REAL(NDGUXG-1,JPRB)

!  initialisation (X,Y) coordinates to the missing value (RMDI)
  DO JOBS = 1 , KOBTOT
    IAD = JOBS
    ROBHDR(IAD,MDBTLA) = RMDI
    ROBHDR(IAD,MDBTLO) = RMDI
  ENDDO

!  transformation from the sphere to the working grid
  IOBS = 0
  DO JOBS = 1 , KOBTOT
    IAD  = JOBS
    ZLAT = ROBHDR(IAD,MDBLAT)
    ZLON = ROBHDR(IAD,MDBLON)
    IF (ZLON < 0.0_JPRB) ZLON = ZLON + Z2PI
    IF (ELON1 < 0.0_JPRB .OR. ELON1 > Z2PI) CALL ABOR1('ELON1')
    IF (ELON2 < 0.0_JPRB .OR. ELON2 > Z2PI) CALL ABOR1('ELON2')
    IF (ZLON < 0.0_JPRB .OR. ZLON > Z2PI) CALL ABOR1('ZLON')
    ZTLON = (ZLON-ZELON1)*(ZLON-ZELON2)*(ZELON2-ZELON1)
    IF ((ZLAT >= ZELAT1.AND.ZLAT <= ZELAT2.AND.ZTLON <= 0.0_JPRB) &
     &  .OR.LRPLANE) THEN
      IOBS          = IOBS+1
      IOBNUMA(IOBS) = JOBS
      Z_PGY(IOBS)     = ZLAT
      Z_PGX(IOBS)     = ZLON
    ELSE
      WRITE(NULOUT,*) 'GREPGEOM Obs at position lat = ',ROBHDR(IAD,MDBLAT),&
                     &' lon = ',ROBHDR(IAD,MDBLON),' not found in between corners.'
    ENDIF
  ENDDO
  ILEN = IOBS

  IF (LRPLANE) THEN
    ALLOCATE(ZGELAM(ILEN)) ; ALLOCATE(ZGELAT(ILEN))
    ALLOCATE(ZGNORX(ILEN)) ; ALLOCATE(ZGNORY(ILEN))
    ZGELAM(1:ILEN)=Z_PGX(1:ILEN) ; ZGELAT(1:ILEN)=Z_PGY(1:ILEN)
    ZLON0=ELON0*Z180SPI ; ZLAT0=ELAT0*Z180SPI
    ZLON1=ELON1*Z180SPI ; ZLAT1=ELAT1*Z180SPI
    ZLONC=ELONC*Z180SPI ; ZLATC=ELATC*Z180SPI

    WRITE(NULOUT,*) 'Call ELALO2XY by OBATABS'

    CALL ELALO2XY(ILEN,ZLON0,ZLAT0,ZLON1,ZLAT1,ZLONC,ZLATC,LMRT,ZGELAM,ZGELAT,&
     & Z_PGX,Z_PGY,ZGNORX,ZGNORY)  
    DEALLOCATE(ZGELAM) ; DEALLOCATE(ZGELAT)
    DEALLOCATE(ZGNORX) ; DEALLOCATE(ZGNORY)
  ELSE
    Z_PGX(1:ILEN)=Z_PGX(1:ILEN)-ELON1
    Z_PGY(1:ILEN)=Z_PGY(1:ILEN)-ELAT1
  ENDIF

!  Initial. of the (X,Y) coord. for the obs. inside the C+I domain
  DO JOBS = 1 , ILEN
    IAD = IOBNUMA(JOBS)
    ZY  = Z_PGY(JOBS) / EDELY
    ZX  = Z_PGX(JOBS) / EDELX

    IF ( ZX >= ZX1.AND. ZX <= ZX2.AND.ZY >= ZY1.AND. ZY <= ZY2 ) THEN
      ROBHDR(IAD,MDBTLA) = ZY
      ROBHDR(IAD,MDBTLO) = ZX
    ELSE
      WRITE(NULOUT,*) 'GREPGEOM Obs at position lat = ',ROBHDR(IAD,MDBLAT),&
       & ' lon = ',ROBHDR(IAD,MDBLON),' not found in C+I '
    ENDIF
  ENDDO
ENDIF

!     ------------------------------------------------------------------
!*       2.       TERMINATE SCAN
!                 --------------

!*          2.1   CHECK ACTUAL NOS OF OBSERVATIONS

IF (.NOT.LELAM) THEN

  INOTOVS  = INOTOVS  - KOFFTOV
  INONTOVS = INONTOVS - KOFFNTV
  ISCATT   = ISCATT   - KOFFSCA

  ICHECK = 1
  IF (KOBTOT /= INOOBS) THEN
    WRITE(NULERR,'('' ** TOTAL NO. OF OBSERVATIONS INCONSISTENT'')')
    WRITE(NULERR,'('' ** KOBTOT (COMING FROM THE SETUP-PREOB):'',I10)') KOBTOT
    WRITE(NULERR,'('' ** INOOBS (FOUND IN SUOBA)             :'',I10)') INOOBS
    ICHECK = 0
  ENDIF
  IF (KOBTOV /= INOTOVS) THEN
    WRITE(NULERR,'('' ** NO. OF TOVS OBS. INCONSISTENT'')')
    WRITE(NULERR,'('' ** KOBTOV (COMING FROM THE SETUP-PREOB):'',I10)') KOBTOV
    WRITE(NULERR,'('' ** INOTOVS (FOUND IN SUOBA)            :'',I10)') INOTOVS
    ICHECK = 0
  ENDIF
  IF (KOBNTV /= INONTOVS) THEN
    WRITE(NULERR,'('' ** NO. OF NON-TOVS OBS. INCONSISTENT'')')
    WRITE(NULERR,'('' ** KOBNTV (COMING FROM THE SETUP-PREOB):'',I10)') KOBNTV
    WRITE(NULERR,'('' ** INONTOVS (FOUND IN SUOBA)           :'',&
     & I10)') INONTOVS  
    ICHECK = 0
  ENDIF
  IF (KOBSCA /= ISCATT) THEN
    WRITE(NULERR,'('' ** NO. OF SCATT. OBS. INCONSISTENT'')')
    WRITE(NULERR,'('' ** KOBSCA (COMING FROM THE SETUP-PREOB):'',I10)') KOBSCA
    WRITE(NULERR,'('' ** ISCATT (FOUND IN SUOBA)           :'',I10)') ISCATT
    ICHECK = 0
  ENDIF
  IF (ICHECK /= 1) THEN
    CALL ABOR1(' OBATABS: INCONSISTENCIES')
  ENDIF

ENDIF

!     ------------------------------------------------------------------
9 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

CALL GSTATS(1793,0)
CALL PUTDB('OBATABS', 0, IRET, INFO, 0, ZINFO, 0)
CALL GSTATS(1793,1)

LLCALLED(KTSLOTNO) = .TRUE.
IF (KTSLOTNO == -1) LLCALLED(1:NACTIM) = .TRUE.

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