SUBROUTINE REDRP(KLEN)

!**** SUBROUTINE REDRP - FIND REDUNDANT REPORTS

!          HEIKKI JARVINEN   ECMWF          15/MAR/1995
!          DRASKO VASILJEVIC ECMWF          21/10/1999

!*    PURPOSE
!     -------

!       FIND REDUNDANT REPORTS GLOBALLY. THE REFERENCE REPORT IS FROM
!     THE LOCAL CMA, BUT THE SEARCH IS PERFORMED GLOBALLY THROUGH A TIME-
!     LOCATION ARRAY.
!     SHIP SYNOPS AND DRIBUS ARE HANDLED IN REDGL, AND AIREPS IN MOVPL.

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

!        CALL REDRP(KLEN)
!     WHERE KLEN = LEN OF DB

!        REDRP IS CALLED BY SUBROUTINE REDUN

!*    METHOD
!     ------

!        REDUNDANT REPORTS ARE SEARCED FOR GLOBALLY. USUALLY FOR THE
!     "STATIC" PLATFORMS ONLY THE REPORT CLOSEST TO THE ANALYSIS TIME
!     IS RETAINED AND THE REST ARE REDUNDANT.

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

!        NGERSTA - GET REPORT STATUS
!        REFTIM  - GET REFERENCE TIME
!        NGENADA - GET NUMBER OF ACTIVE DATA

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

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

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

USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMCOCTP , ONLY : NSYNOP   ,NDRIBU   ,NPAOB    ,NSRSCD ,NATSCD  ,&
       &  NSYRCD, NRADOH, NSHSCD
USE YOMANA   , ONLY : NANDAT   ,NANTIM
USE YOMANCS  , ONLY : RDEGREES
USE YOMSCREE , ONLY : NGLSYN   
USE YOMSCC   , ONLY : LSCDPR
USE YOMNMEV  , ONLY : NR1EVENT
USE YOMDB
USE ecsort_mix   , ONLY : keysort

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEN 
REAL(KIND=JPRB),allocatable :: ZGLSYN(:,:)

INTEGER(KIND=JPIM) :: IRSTA(4)
CHARACTER (LEN=8) ::  CLSTID
CHARACTER (LEN=5) ::  CLOBTYP
LOGICAL :: LLPRINT

INTEGER(KIND=JPIM) :: IACD1, IACD2, IAN, ICMONM, &
 & ICOUNT, ICU, IOBCTP, IOBDAT, IOBS, &
 & IOBETM, IOBITP, IOBTYP, IPR1, IPR2, &
 & IREFPO, IRF, IRFCTP, IRFDAT, IRFETM, &
 & IRFITP, IRFONM, IRFOTP, ICDTYP, &
 & JOBS, ILEN, IGLSYN, INADA, JOBS1, JOBS2  

INTEGER(KIND=JPIM) :: iret, isize, I_MKEY(2)

LOGICAL :: LLEXIT_GLOBAL_LOOP

REAL(KIND=JPRB) :: ZOBLAT, ZOBLON, ZREFID, ZRFLAT, ZRFLON
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "ngenada.intfb.h"
#include "ngersta.intfb.h"
#include "reftim.intfb.h"

#include "fcobs.h"

#include "openmp_obs.h"
!*
!     ------------------------------------------------------------------
!        0.       INITIALSE
!                 ---------

IF (LHOOK) CALL DR_HOOK('REDRP',0,ZHOOK_HANDLE)
ILEN = KLEN

!*
!           0.1   LOOP OVER ALL OBS

IGLSYN = 0
OBS_LOOP1: DO JOBS = 1 , ILEN
  IOBTYP = ROBHDR(JOBS,MDBOTP)
  IF(IOBTYP /= NSYNOP .AND. IOBTYP /= NPAOB) THEN
    WRITE(NULERR,'('' *** ERROR IN REDRP; NOT EXPECTED OBS TYPE '')')
    WRITE(NULERR,'(''     IOBTYP= '',3I10)') IOBTYP,NSYNOP,NPAOB
    CALL ABOR1('REDRP; NOT EXPECTED OBS TYPE')
  ENDIF
  IF(IOBTYP == NSYNOP) THEN
    ICDTYP = ROBHDR(JOBS,MDB_CODETYPE_AT_HDR)
IF(ICDTYP /= NSRSCD .AND. ICDTYP /= NATSCD .AND. ICDTYP /= NSYRCD &
         &   .AND. ICDTYP /= NRADOH .AND. ICDTYP /= NSHSCD) CYCLE OBS_LOOP1
  ENDIF
!*          0.2   ACCEPT ACTIVE REPORTS ONLY

  CALL NGERSTA(INT(ROBHDR(JOBS,MDBRST)),ICOUNT,IRSTA)
  IF(IRSTA(2) == 1.OR. IRSTA(3) == 1.OR. IRSTA(4) == 1) CYCLE OBS_LOOP1

!*          0.3   ACCEPT ONLY REPORTS CONTAINING ACTIVE DATA

  CALL NGENADA(JOBS,INADA)

  IF(INADA == 0) CYCLE OBS_LOOP1

!*          0.4   UPDATE COUNTER

  IGLSYN = IGLSYN + 1

!*          0.5   CLOSE THE LOOP

ENDDO OBS_LOOP1
!*
!     ------------------------------------------------------------------
!        1.       ALLOCATE
!                 --------

NGLSYN = IGLSYN
IF(NGLSYN == 0) GO TO 10

!*          2.1        POINTER/SORT ARRAY

isize = NGLSYN + mod(NGLSYN+1,2) ! mod()-hassle to avoid memory bank/cache conflicts
ALLOCATE(ZGLSYN(isize,3))
IF(LSCDPR) THEN
  WRITE(NULOUT,9991) 'NGLSYN   ',NGLSYN
  WRITE(NULOUT,9990) 'ZGLSYN   ',SIZE(ZGLSYN   ),SHAPE(ZGLSYN   )
ENDIF
ZGLSYN(:,:) = 0.0_JPRB

!*          2.5        FORMAT

9990 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)
9991 FORMAT(1X,A10,' =    ',I8)
!*
!     ------------------------------------------------------------------

!        3.       FILL THE GLOBAL ARRAYS

IGLSYN = 0
!*
!           3.1   LOOP OVER OBSERVATIONS

OBS_LOOP2: DO JOBS = 1, ILEN
  IOBTYP = ROBHDR(JOBS,MDBOTP)
  IF(IOBTYP == NSYNOP) THEN
    ICDTYP = ROBHDR(JOBS,MDB_CODETYPE_AT_HDR)
IF(ICDTYP /= NSRSCD .AND. ICDTYP /= NATSCD .AND. ICDTYP /= NSYRCD &
         &   .AND. ICDTYP /= NRADOH .AND. ICDTYP /= NSHSCD) CYCLE OBS_LOOP2
  ENDIF
  ICMONM    = ROBHDR(JOBS,MDBONM)

!*          3.2   ACCEPT ACTIVE REPORTS ONLY

  CALL NGERSTA(INT(ROBHDR(JOBS,MDBRST)),ICOUNT,IRSTA)
  IF(IRSTA(2) == 1.OR. IRSTA(3) == 1.OR. IRSTA(4) == 1) CYCLE OBS_LOOP2

!*          3.3   ACCEPT ONLY REPORTS CONTAINING ACTIVE DATA

  CALL NGENADA(JOBS,INADA)
  IF(INADA == 0) CYCLE OBS_LOOP2

!*          3.4   UPDATE COUNTER

  IGLSYN = IGLSYN + 1

!           3.5   FILL ARRAY

  ZGLSYN(IGLSYN,1) = JOBS
  ZGLSYN(IGLSYN,2) = ROBHDR(JOBS,MDBSID)
  ZGLSYN(IGLSYN,3) = ICMONM

!           3.6   CLOSE THE LOOP

ENDDO OBS_LOOP2

!           3.7   CROSS CHECK

IF(IGLSYN /= NGLSYN) THEN
  WRITE(NULERR,'('' *** ERROR IN REDPL (1): '')')
  WRITE(NULERR,'(''     IGLSYN= '',I10)') IGLSYN
  WRITE(NULERR,'(''     NGLSYN= '',I10)') NGLSYN
  CALL ABOR1('REDPL: ERROR 1')
ENDIF
!*
!     ------------------------------------------------------------------

!        4.       SORT
!                 ----
I_MKEY(1) = 2
I_MKEY(2) = 3

!WRITE(NULOUT,'('' REDRP; ZGLSYN BEFORE SORT'')')
!DO JPR=1,ILEN
!WRITE(NULOUT,'('' '',I5,1x,F15.2,1X,A8,1x,F15.2)') JPR,&
!&ZGLSYN(jpr,1),TRANSFER(ZGLSYN(jpr,2),CLSTID),ZGLSYN(jpr,3)
!ENDDO
!CALL FLUSH(NULOUT)

CALL KEYSORT(iret, ZGLSYN, NGLSYN, multikey=I_MKEY, transposed=.FALSE.)

!WRITE(NULOUT,'('' REDRP; ZGLSYN AFTER SORT'')')
!DO JPR=1,ILEN
!WRITE(NULOUT,'('' '',I5,1x,F15.2,1X,A8,1x,F15.2)') JPR,&
!&ZGLSYN(jpr,1),TRANSFER(ZGLSYN(jpr,2),CLSTID),ZGLSYN(jpr,3)
!ENDDO
!CALL FLUSH(NULOUT)

!*
!     ------------------------------------------------------------------
!        5.       SEARCH
!                 ------
 
!*          5.0   LOOP OVER ALL DATA

CALL REFTIM(NANDAT,NANTIM,IAN)

LOOP_GL1: DO JOBS1 = 1, NGLSYN

!*          5.0.1 LOGICAL SWITCHES

  LLEXIT_GLOBAL_LOOP = .FALSE.
  LLPRINT = .FALSE.

!*          5.1   FIND OUT OBSERVATION POINTER TO REFERENCE REPORT

  IREFPO = ZGLSYN(JOBS1,1)
!*
!           5.2   CHECK REPORT STATUS FOR REFERENCE REPORT

  CALL NGERSTA(INT(ROBHDR(IREFPO,MDBRST)),ICOUNT,IRSTA)
  IF(IRSTA(2) == 1.OR. IRSTA(3) == 1.OR. IRSTA(4) == 1) CYCLE LOOP_GL1

!*
!           5.3   COLLECT HEADER INFORMATION OF REFERENCE REPORT

  IRFDAT = ROBHDR(IREFPO,MDBDAT)
  IRFETM = ROBHDR(IREFPO,MDBETM)
  IRFONM = ROBHDR(IREFPO,MDBONM)
  IRFOTP = ROBHDR(IREFPO,MDBOTP)
  IRFCTP = ROBHDR(IREFPO,MDB_CODETYPE_AT_HDR)
  IRFITP = ROBHDR(IREFPO,MDB_INSTTYPE_AT_HDR)
  ZREFID = ROBHDR(IREFPO,MDBSID)
!*
!           5.4   GET THE REFERENCE TIME

  CALL REFTIM(IRFDAT,IRFETM,IRF)
!*
!           5.5   GET THE NUMBER OF ACTIVE DATA IN REFERENCE REPORT

  CALL NGENADA(IREFPO,IACD1)
!*
!     ------------------------------------------------------------------

!        6.       STUDY THE GLOBAL TIME-LOCATION ARRAY FOR SYNOPTIC REPS.
  ZRFLAT = ROBHDR(IREFPO,MDBLAT)
  ZRFLON = ROBHDR(IREFPO,MDBLON)
!                 -------------------------------------------------------

!*          6.0   LOOP OVER THE GLOBAL ARRAY

  GLOBAL_LOOP: DO JOBS2 = JOBS1+1, NGLSYN

    IOBS = ZGLSYN(JOBS2,1)
    IF(ROBHDR(IOBS,MDBSID) /= ZREFID) EXIT GLOBAL_LOOP

!*          6.1   OBSERVATION TYPE

    IOBTYP = ROBHDR(IOBS,MDBOTP)
    IF(IRFOTP /= IOBTYP) CYCLE GLOBAL_LOOP

!*          6.2   CHECK WHETHER REPORT STILL ACTIVE

    CALL NGERSTA(INT(ROBHDR(IOBS,MDBRST)),ICOUNT,IRSTA)
    IF(IRSTA(2) == 1.OR. IRSTA(3) == 1.OR. IRSTA(4) == 1)CYCLE GLOBAL_LOOP

!*          6.3   LATITUDE, LONGITUDE

    ZOBLAT = ROBHDR(IOBS,MDBLAT)
    ZOBLON = ROBHDR(IOBS,MDBLON)
    IF(ZRFLAT /= ZOBLAT) CYCLE GLOBAL_LOOP
    IF(ZRFLON /= ZOBLON) CYCLE GLOBAL_LOOP

!*          6.4   CODE AND INSTRUMENT TYPE

    IOBCTP = ROBHDR(IOBS,MDB_CODETYPE_AT_HDR)
    IOBITP = ROBHDR(IOBS,MDB_INSTTYPE_AT_HDR)
    IF(IRFCTP /= IOBCTP) CYCLE GLOBAL_LOOP
    IF(IRFITP /= IOBITP) CYCLE GLOBAL_LOOP
!*
!           6.5   UNIQUE OBSERVATION SEQUENCE NUMBER

    ICMONM = ROBHDR(IOBS,MDBONM)
    IF(IRFONM == ICMONM) CYCLE GLOBAL_LOOP
!*
!           6.8   DATE, TIME, OWNER, POINTER AND NO. ACTIVE DATA

    IOBDAT = ROBHDR(IOBS,MDBDAT)
    IOBETM = ROBHDR(IOBS,MDBETM)
    CALL NGENADA(IOBS,IACD2)
!*
!     ------------------------------------------------------------------

!        7.       FIND OUT THE OBSERVATION WITH HIGHER PRIORITY
!                 ---------------------------------------------
!*
!           7.1   GET THE REFERENCE TIME

    CALL REFTIM(IOBDAT,IOBETM,ICU)
!*
!           7.2   COMPOSE THE PRIORITY FIGURES

    IPR1 = 1000*ABS(IRF-IAN) + 10*(99-IACD1)
    IPR2 = 1000*ABS(ICU-IAN) + 10*(99-IACD2)
    IF(IRFONM > ICMONM) IPR1 = IPR1 + 1
    IF(IRFONM < ICMONM) IPR2 = IPR2 + 1
!*
!           7.3   SELECT THE ONE WITH LOWER PRIORITY FIGURE

    IF(IPR1 <= IPR2) THEN
      ROBHDR(IOBS,MDBRST) = ZCHSTAT_REJECT( ROBHDR(IOBS,MDBRST))
      ROBHDR(IOBS,MDBREV1) = ZCHEV1( ROBHDR(IOBS,MDBREV1),NR1EVENT(10))
    ELSE
      ROBHDR(IREFPO,MDBRST) = ZCHSTAT_REJECT( ROBHDR(IREFPO,MDBRST))
      ROBHDR(IREFPO,MDBREV1) = ZCHEV1( ROBHDR(IREFPO,MDBREV1),NR1EVENT(10))
      LLEXIT_GLOBAL_LOOP = .TRUE.
    ENDIF
    LLPRINT = .TRUE.
!*
!           7.4   PRINT WHILE TESTING

    IF(LSCDPR .AND. LLPRINT) THEN
      CLSTID = TRANSFER(ROBHDR(IOBS,MDBSID), CLSTID)
      IF(IOBTYP == NSYNOP) CLOBTYP = 'SYNOP'
      IF(IOBTYP == NDRIBU) CLOBTYP = 'DRIBU'
      IF(IOBTYP == NPAOB ) CLOBTYP = ' PAOB'
      WRITE(NULOUT,'('' REDUNDANT '',A5,'' ID '',A8,'' AT '',&
       & 2(F7.2,1X),'' AN-TIME '',I8,1X,I6,'' REF: DT/NDATA '',&
       & I4,''/'',I1,'' OBS: DT/NDATA '',I4,''/'',I1)')&
       & CLOBTYP,CLSTID,ZOBLAT*RDEGREES,ZOBLON*RDEGREES,&
       & NANDAT,NANTIM,(IRF-IAN),IACD1,(ICU-IAN),IACD2  
      LLPRINT = .FALSE.
    ENDIF
!*
!           7.5   IS IT TIME TO EXIT GLOBAL_LOOP

    IF(LLEXIT_GLOBAL_LOOP) THEN
      EXIT GLOBAL_LOOP
    ENDIF

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

!        8.       CLOSE LOOPS
!                 -----------

  ENDDO GLOBAL_LOOP
ENDDO LOOP_GL1
!*
!     ------------------------------------------------------------------

!        9.       DEALOC
!                 ------

9 CONTINUE
DEALLOCATE(ZGLSYN)
!*
!     ------------------------------------------------------------------
!*

!        10.      RETURN
!                 ------
10 CONTINUE
IF (LHOOK) CALL DR_HOOK('REDRP',1,ZHOOK_HANDLE)
END SUBROUTINE REDRP
