SUBROUTINE READOBA

!*    ROUTINE TO READ AND EXTRACT OBSERVATIONS FROM OBS. (CMA) ARRAY
!     FILE

!          PER UNDEN         ECMWF          11/4 1989
!          DRASKO VASILJEVIC                06/03/1990

!**   METHOD
!     ------

!      THE OBS. (CMA) ARRAY FILE IS READ.

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

!     CALL READOBA()

!**   EXTERNALS
!     ---------

!**   MODIFICATIONS
!     -------------

!        D. VASILJEVIC 23/05/91 : INTRODUCTION OF PROPER TIME SLOTS
!        D. VASILJEVIC 19/02/92 : INTRODUCTION OF OBS. FILE NAMES
!        H. JARVINEN   95/09/20 : NEW CMA- FILE FORMAT
!        M. HAMRUD     16/09/95 : NEW CMA FORMAT
!        M.HAMRUD      15/10/96 : 4-D VAR
!        S. Saarinen   14/11/97 : Support for the new CMA I/O-library
!        S. Saarinen    4/11/98 : Explicit CMA flp validity check added
!        D.Dent        00-09-01 : convert from MPE to MPL
!        C. Payan      13/04/07 : LMKCMARPL becomes a 2D array

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

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

USE YOMCOCTP
USE YOMCT0   , ONLY : NPROC    ,NPRINTLEV,LALLOPR  ,LSCREEN  ,LCANARI
USE YOMCT0B, ONLY : LECMWF
USE YOMOBA   , ONLY : ROBDD1   ,ROBDD2   ,MOBDD1   ,&
 & MOBDD2   ,COBDD1   ,COBDD2  
USE YOMCMDDR
USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMDB
USE YOMCMA   , ONLY : LECFIO   ,NRESUPD
USE MPL_MODULE
USE YOMMP    , ONLY : MYPROC
USE YOMOBS   , ONLY : LMKCMARPL, LRPLSWAPOUT

IMPLICIT NONE

REAL(KIND=JPRB) :: ZDDRS (NLENCD1+NLENCD2)
INTEGER(KIND=JPIM) :: INFO(2)
LOGICAL :: LLP
INTEGER(KIND=JPIM) :: IRET,ILENDDRS
INTEGER(KIND=JPIM) :: IU
INTEGER(KIND=JPIM) :: J
character(len=20) ::  CL_dbname, CL_dbmode
logical, save :: LLflpcheck = .FALSE.
logical, save :: LLfirst_time = .TRUE.
REAL(KIND=JPRB) :: ZINFO(0)
character(len=1) ::  CL_print_ddrs
INTEGER(KIND=JPIM) :: imxupd, inantim, inandat
INTEGER(KIND=JPIM) :: itslots, ileft_margin, iright_margin
INTEGER(KIND=JPIM) :: i_date, i_time, iref0 , iref
character(len=20) ::  clenv
LOGICAL   :: LLSAVE, LLSWAPOUT
INTEGER(KIND=JPIM) :: inproca, inprocb, idummy, ienv
INTEGER(KIND=JPIM) :: ii, iobstype, icodetype, inmxupd
logical :: LLdummy
logical :: LLfintraj_ECMA, LLsink
REAL(KIND=JPRB) :: ZHOOK_HANDLE

INTERFACE
#include "getdb.h"
#include "putdb.h"
#include "abortdb.h"
#include "opendb.h"
!*AF To be commented out for debugging purpose only closedb
#include "closedb.h"
#include "shuffle_odb.h"
#include "matchupdb.h"
#include "grid_nearest.h"
#include "distribute_odb.h"
END INTERFACE

#include "abor1.intfb.h"
#include "convddr.intfb.h"

#include "openmp_obs.h"
!     ------------------------------------------------------------------
!*       1.       INITIAL DEFINITIONS
!                 -------------------

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

!--ODB
CALL getenv('ODB_CMA', CL_dbname)
if (CL_dbname /= ' ') then
  CALL getenv('ODB_CMA_MODE', CL_dbmode)
  if (CL_dbmode == ' ') CL_dbmode = 'OLD' ! Could be 'READONLY', too; for testing etc. purposes

  if (ANY(LMKCMARPL) .and. LRPLSWAPOUT .and. &
     & (CL_dbmode == 'READONLY' .or. CL_dbmode == 'readonly')) then  
    LRPLSWAPOUT = .false.
  endif

  CALL GSTATS(1791,0)
  CALL OPENDB(trim(CL_dbname), trim(CL_dbmode), INFO, size(INFO))
  CALL GSTATS(1791,1)
  if (MYPROC == 1) THEN
    WRITE(NULERR,*) 'READOBA: Opened ODB-database="'//trim(CL_dbname)//&
     & ' with mode="'//trim(CL_dbmode)//'" : npools & $NMXUPD are ',INFO(1:2),&
     & ' LECFIO=',LECFIO  
  endif

  inmxupd = info(2)
  if (LECMWF .and. .not. LSCREEN .and. CL_dbname == 'CCMA') then
    !-- Reserved no. of updates from MXUP_TRAJ or rely on $NMXUPD in database layout
    CALL GSTATS(1778,0)
    call grid_nearest(.FALSE.) !LDtransform = .FALSE. 
    CALL GSTATS(1778,1)
    LLSAVE    = .TRUE.
    LLSWAPOUT = .FALSE. ! to avoid I/O-burst
    iret=0
!*AF BEGIN CHANGES 13/04/2010
    CALL GSTATS(1791,0)
    CALL GETDB('TIME_INFO',0,iret,info,0,ZINFO,0,-1,-1,-1,-1,-1,-1)
    CALL GSTATS(1791,1)
    if (iret > 0) then
      inandat = int(ROBHDR(1, MDB_ANDATE_AT_DESC))  ! because andate@desc is the same for all rows
      inantim = int(ROBHDR(1, MDB_ANTIME_AT_DESC))
      i_date=int(ROBHDR(1, MDB_INIDATE_AT_DESC))
      i_time=int(ROBHDR(1, MDB_INITIME_AT_DESC))
      CALL ref_time(inandat,inantim,iref0)
      itslots= maxval(ROBHDR(1:IRET,MDB_TIMESLOT_AT_TIMESLOT_INDEX))
      CALL ref_time(i_date,i_time,iref)
      ileft_margin = iref - iref0
      i_date=int(ROBHDR(iret, MDB_ENDDATE_AT_TIMESLOT_INDEX)) 
! last row contains last timeslot because it is ordered in time_info.sql
      i_time=int(ROBHDR(iret, MDB_ENDTIME_AT_TIMESLOT_INDEX))
      CALL ref_time(i_date,i_time,iref)
      iright_margin = iref - iref0
      CALL GSTATS(1791,0)
      CALL PUTDB('TIME_INFO',0,iret,info,0,ZINFO,0)
      CALL GSTATS(1791,1)
    endif
  
   imxupd = -1
    CALL GSTATS(1774,0)
    call distribute_odb(NULOUT, CL_dbname, &
       & LLSAVE, LLSWAPOUT, &
       & inandat, inantim, imxupd, &
       & ileft_margin, iright_margin, &
       & itslots)
    CALL GSTATS(1774,1)
!*AF debug only    CALL CLOSEDB(.TRUE.)  
  elseif (.not. LSCREEN .and. CL_dbname == 'ECMA') then
!*AF Add matchup in the last trajectory only if ODB_MATCHUP_DIRECT=1
    CALL getenv('ODB_MATCHUP_DIRECT', clenv)
    ienv = 0
    if (clenv /= ' ') read(clenv,*) ienv

    if (ienv == 1) then ! perform incore matchusink and keep database open
      CALL getenv('MXUP_TRAJ', clenv)
      if (clenv /= ' ') read(clenv,*) imxupd  !Max number of update
      LLfintraj_ECMA = .TRUE. ! use ECMA for the last trajectory
      LLsink = .TRUE. 
      write(0,*) 'Last trajectory matchup'
      CALL GSTATS(1777,0)
      CALL matchupdb(-1, LLfintraj_ECMA, .FALSE., LLsink, imxupd)
      CALL GSTATS(1777,1)
    endif

!*AF last trajectory 
  elseif ((LSCREEN .OR. LCANARI) .and. CL_dbname == 'ECMA') then ! To reduce I/O ...
    CALL getenv('ODB_MERGEODB_DIRECT', clenv)
    ienv = 0
    if (clenv /= ' ') read(clenv,*) ienv

    if (ienv == 1) then ! perform incore MERGEODB and keep database open
      LLSAVE    = .TRUE.
      LLSWAPOUT = .FALSE. ! to avoid I/O-burst

    !-- Reserved no. of updates from MXUP_TRAJ or rely on $NMXUPD in database layout
      CALL getenv('MXUP_TRAJ', clenv)
      NRESUPD = info(2) ! from OPENDB; the best we can offer as an initial value
      imxupd = -1
      if (clenv /= ' ') then
        read(clenv,*) imxupd
        NRESUPD = imxupd
      endif
  
      !-- Share some settings from CCMA (small change to ifstraj-script required)
      CALL getenv('ODB_CCMA_TSLOTS', clenv)
      itslots = 1
      if (clenv /= ' ') read(clenv,*) itslots
      
      CALL getenv('ODB_CCMA_LEFT_MARGIN', clenv)
      ileft_margin = 0
      if (clenv /= ' ') read(clenv,*) ileft_margin
  
      CALL getenv('ODB_CCMA_RIGHT_MARGIN', clenv)
      iright_margin = 0
      if (clenv /= ' ') read(clenv,*) iright_margin
  
      !-- Analysis date & time (note: NANTIM & NANDAT not available at this stage yet !!)
      if (LECMWF) then
        CALL getenv('BASETIME', clenv) ! Format: YYYYMMDDHH --> dat=YYYYMMDD, tim=HH * 10000
        if (clenv /= ' ') then
          read(clenv,'(i8,i2)') inandat, inantim
          inantim = inantim * 10000
        else
          WRITE(NULERR,*) 'READOBA: Warning : BASETIME environment variable not defined !'
          inandat = -1
          inantim = -1
        endif
      else  ! meteo-france lecture directe sur la base
        iret=0
        CALL GSTATS(1791,0)
        CALL GETDB('TIME_INFO',0,iret,info,0,ZINFO,0,-1,-1,-1,-1,-1,-1)
        CALL GSTATS(1791,1)
        if (iret > 0) then
          inandat = int(ROBHDR(1, MDB_ANDATE_AT_DESC))  ! because andate@desc is the same for all rows
          inantim = int(ROBHDR(1, MDB_ANTIME_AT_DESC))
          if (ileft_margin == 0) then
            CALL ref_time(inandat,inantim,iref0)
            itslots= maxval(ROBHDR(1:IRET,MDB_TIMESLOT_AT_TIMESLOT_INDEX))
            i_date=int(ROBHDR(1, MDB_INIDATE_AT_DESC))
            i_time=int(ROBHDR(1, MDB_INITIME_AT_DESC))
            CALL ref_time(i_date,i_time,iref)
            ileft_margin = iref - iref0
            i_date=int(ROBHDR(iret, MDB_ENDDATE_AT_TIMESLOT_INDEX)) 
! last row contains last timeslot because it is ordered in time_info.sql
            i_time=int(ROBHDR(iret, MDB_ENDTIME_AT_TIMESLOT_INDEX))
            CALL ref_time(i_date,i_time,iref)
            iright_margin = iref - iref0
          endif
        endif
        CALL GSTATS(1791,0)
        CALL PUTDB('TIME_INFO',0,iret,info,0,ZINFO,0)
        CALL GSTATS(1791,1)
      endif

      !-- dummies --
      inproca = NPROC
      inprocb = 1
      LLdummy = .FALSE.
      idummy = 0

      !-- Run incore MERGEODB on already opened ECMA-database
      !   (compare with ../var/writeoba.F90 for CCMA direct creation procedure)
      CALL SHUFFLE_ODB(NULOUT, 'ECMA', 'ECMA', &
       & LLSAVE, LLSWAPOUT, &
       & inandat, inantim, imxupd, &
       & ileft_margin, iright_margin, &
       & itslots, &
       & inproca, inprocb, &
       & idummy, LLdummy, LLdummy, .TRUE.) !*AF last argument is true because run in IFS (to call grid_nearest) 

    endif ! if (ienv == 1) then ...
  endif  
else
  CALL ABOR1('READOBA: Undefined ODB_CMA')
endif

LLP = NPRINTLEV >= 1.OR. LALLOPR
IU = NULOUT
ILENDDRS = NLENCD1+NLENCD2

ZDDRS(1:ILENDDRS) = 0
ZDDRS(NCD1NPU)  = inmxupd  ! We need to initialise NCD1NPU even if empty pool...
IF (LSCREEN) THEN
  ZDDRS(NCD1NUP) = -1
ELSE
  ZDDRS(NCD1NUP) = 0
ENDIF

CALL GETDB('EXP_INFO', 1, IRET, INFO, 0, ZINFO, 0, &
         & -1, -1, -1, -1, -1, -1)  

IF (IRET > 0) THEN
  ZDDRS(NCD1OD)   = ROBHDR(1, MDB_ANDATE_AT_DESC)
  ZDDRS(NCD1OT)   = ROBHDR(1, MDB_ANTIME_AT_DESC)
  ZDDRS(NCD1TSL_NUMSLOTS) = ROBHDR(1, MDB_NUMTSL_AT_DESC)  ! to get the total number of timeslots
  if (CL_dbname == 'ECMA') then
    ZDDRS(NCD1NPU)  = ROBHDR(1, MDB_MXUP_TRAJ_AT_DESC) ! to get the number of planned updates 
  else
    ZDDRS(NCD1NPU)  = inmxupd   ! for CCMA max number of update from ODB was used
  endif
  IRET=0
  CALL PUTDB('EXP_INFO', 1, IRET, INFO, 0, ZINFO, 0)
ENDIF

CALL GETDB('STAT_OBS', 1, IRET, INFO, 0, ZINFO, 0, &
         & -1, -1, -1, -1, -1, -1)  

IF (IRET > 0) THEN
  
  ZDDRS(NCD1DR)   = IRET ! total number of reports for the pools of the PE
  ZDDRS(NCD1MOT)  = maxval(ROBHDR(1:IRET,MDBOTP))            ! max(obstype)
  ZDDRS(NCD1TO)   = ZDDRS(NCD1DR)
  DO ii=1, IRET
    iobstype = ROBHDR(ii, MDBOTP) 
    IF (iobstype == NSYNOP)  ZDDRS(NCD1NSY)  =  ZDDRS(NCD1NSY) + 1
    IF (iobstype == NAIREP)  ZDDRS(NCD1NAI)  =  ZDDRS(NCD1NAI) + 1
    IF (iobstype == NSATOB)  ZDDRS(NCD1NSA)  =  ZDDRS(NCD1NSA) + 1
    IF (iobstype == NDRIBU)  ZDDRS(NCD1NDB)  =  ZDDRS(NCD1NDB) + 1
    IF (iobstype == NTEMP)   ZDDRS(NCD1NTE)  =  ZDDRS(NCD1NTE) + 1
    IF (iobstype == NPILOT)  ZDDRS(NCD1NPI)  =  ZDDRS(NCD1NPI) + 1
    IF (iobstype == NPAOB)   ZDDRS(NCD1NPA)  =  ZDDRS(NCD1NPA) + 1
    IF (iobstype == NSCATT)  ZDDRS(NCD1SC)   =  ZDDRS(NCD1SC)  + 1
    IF (iobstype == NLIMB)   ZDDRS(NCD1NLM)  =  ZDDRS(NCD1NLM) + 1
! SATEM obstype
    IF (iobstype == NSATEM) THEN
      icodetype = ROBHDR(ii,MDB_CODETYPE_AT_HDR)
      if (icodetype == NSTMCD .or. icodetype == NSTOVS) then
        ZDDRS(NCD1NSM)  =  ZDDRS(NCD1NSM) + 1
      ELSEIF (icodetype == NGTHR2.or. icodetype == NGTHR1) then
        ZDDRS(NCD1NT)   =  ZDDRS(NCD1NT) + 1
      ELSEIF (icodetype == NGTHRB)                     then
        ZDDRS(NCD1NAT)  =  ZDDRS(NCD1NAT) + 1
      ELSEIF (icodetype == NSSMI.or. icodetype == NSMOS .or. icodetype == NTCWC) then
        ZDDRS(NCD1NSSM) =  ZDDRS(NCD1NSSM) + 1
      ELSEIF (icodetype == NSTRO3 )                    then
        ZDDRS(NCD1NRO3) =  ZDDRS(NCD1NRO3) + 1
      ENDIF
    ENDIF
  ENDDO
ENDIF

IRET=0
CALL PUTDB('STAT_OBS', 1, IRET, INFO, 0, ZINFO, 0)

IF(.NOT.ALLOCATED(MOBDD1)) THEN
  ALLOCATE(MOBDD1(NLEND1I))
  IF(LLP)WRITE(IU,9) 'MOBDD1   ',SIZE(MOBDD1   ),SHAPE(MOBDD1   )
  ALLOCATE(MOBDD2(NLEND2I))
  IF(LLP)WRITE(IU,9) 'MOBDD2   ',SIZE(MOBDD2   ),SHAPE(MOBDD2   )
  ALLOCATE(ROBDD1(NLEND1R))
  IF(LLP)WRITE(IU,9) 'ROBDD1   ',SIZE(ROBDD1   ),SHAPE(ROBDD1   )
  ALLOCATE(ROBDD2(NLEND2R))
  IF(LLP)WRITE(IU,9) 'ROBDD2   ',SIZE(ROBDD2   ),SHAPE(ROBDD2   )
ENDIF

CALL getenv('ODB_PRINT_DDRS', CL_print_ddrs)
if (CL_print_ddrs == '1') then
  write(nulout,*) '*** READOBA: print of ddrs on pe#',myproc,' ***'
  write(nulout,*) 'start of ddr#1:'
  do j=1,NLENCD1
    write(nulout,'(1x,i4,2x,g25.15)') j,zddrs(j)
  enddo
  write(nulout,*) 'start of ddr#2:'
  do j=NLENCD1+1,NLENCD1+NLENCD2
    write(nulout,'(1x,i4,2x,g25.15)') j-NLENCD1,zddrs(j)
  enddo
  write(nulout,*) '*** READOBA: end of print of ddrs on pe#',myproc,' ***'
endif

CALL CONVDDR(1,ZDDRS,&
 & MOBDD1(1),ROBDD1(1),COBDD1,&
 & MOBDD2(1),ROBDD2(1),COBDD2)  
!  WRITE(NULOUT,*) 'READOBA: ALLOCATING ZERO LENGTH ROBSAR FOR ODB'

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

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