SUBROUTINE REDPROF(KLEN)

!**** SUBROUTINE REDPROF - TIME SELECTION OF PROFILER REPORTS

!          Alex DECKMYN    27/11/2001

!*    PURPOSE
!     -------

!        PERFORM REDUNDANCY CHECKS FOR PROFILER OBSERVATIONS

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

!     ***CALL REDPROF(KLEN)
!     WHERE KLEN   = DB LEN

!        REDPROF IS CALLED BY SUBROUTINE REDUN

!*    METHOD
!     ------

!     * SELECTION OF MULTILEVEL PROFILER PILOT REPORTS:
!         CONSIDER PROFILER PILOTS FROM ONE TIME WINDOW (6h IN 3D-VAR,
!         1h IN 4D-VAR, OR ALTERNATIVELY WHOLE 6h DATA WINDOW ALSO IN
!         ALSO IN 4D-VAR)
!         KEEP ONLY THE REPORT CLOSEST TO ANALYSIS TIME.

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

!       NGENADA
!       NGERSTA
!       REFTIM

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

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

USE YOMSCC   , ONLY : LSCDPR
USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMCOCTP , ONLY : NWPPCD   ,NEWPPCD 
USE YOMNMEV  , ONLY : NR1EVENT
USE YOMDB
USE ecsort_mix   , ONLY : keysort
USE YOMANA   , ONLY : NANDAT   ,NANTIM
IMPLICIT NONE

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

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

INTEGER(KIND=JPIM) :: ICOUNT, ILEN, INADA, &
 & IGLPROF, INGLPROF, &
 & IPR1, IPR2, IAN, &
 & JOBS1, JOBS2, &
 & IREFPO, IRFITP, IRFONM, IRFOTP, &
 & IRFCTP, IRFDAT, IRFETM, IRF, &
 & IOBS  , IOBITP, ICMONM, IOBOTP, &
 & IOBCTP, IOBDAT, IOBETM, ICU  
LOGICAL :: LLEXIT_GLOBAL_LOOP, LLPRINT

REAL(KIND=JPRB) :: ZREFID

CHARACTER (LEN=8) ::  CLSTID
CHARACTER (LEN=7) ::  CLOBCHAR
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.       INITIALIZE
!                 ----------

IF (LHOOK) CALL DR_HOOK('REDPROF',0,ZHOOK_HANDLE)
IF(LSCDPR) THEN
  WRITE(NULOUT,'(''     PROFILER REDUNDANCY (TIME SELECTION) CHECK '')')
ENDIF

!*          0.1   LEN

ILEN = KLEN
!*
!     ------------------------------------------------------------------

!        1.       STUDY OBSERVATIONS
!                 ------------------

!*
!           1.1   LOOP OVER OBSERVATIONS

IGLPROF = 0
OBS_LOOP1: DO IOBS = 1, ILEN
  IOBCTP = ROBHDR(IOBS,MDB_CODETYPE_AT_HDR)

  IF(IOBCTP /= NWPPCD .AND. IOBCTP /= NEWPPCD) CYCLE OBS_LOOP1

!*          1.2   ACCEPT ACTIVE REPORTS ONLY

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

!*          1.3   ACCEPT ONLY REPORTS CONTAINING ACTIVE DATA

  CALL NGENADA(IOBS,INADA)
  IF(INADA == 0) CYCLE OBS_LOOP1

!*          1.4   UPDATE COUNTER

  IGLPROF = IGLPROF + 1

!*          1.5   CLOSE THE LOOP

ENDDO OBS_LOOP1

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

!        2.       ALLOCATE AND PRESET GLOBAL ARRAYS
!                 ---------------------------------

!*          2.0   INFORM

IF(LSCDPR) THEN
  WRITE(NULOUT,'('' *** NO. OF ACTIVE PROFILER REPORTS:'',I10)') IGLPROF
ENDIF
INGLPROF = IGLPROF
IF(INGLPROF == 0)  GO TO 7

!*          2.4        POINTER/SORT ARRAY

ALLOCATE(ZGLPROF(3,INGLPROF))
IF(LSCDPR) THEN
  WRITE(NULOUT,9990) 'ZGLPROF   ',SIZE(ZGLPROF   ),SHAPE(ZGLPROF   )
ENDIF
ZGLPROF(:,:) = 0.0_JPRB

!*          2.5        FORMAT

9990 FORMAT(1X,'ARRAY ',A10,' ALLOCATED ',8I8)

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

!        3.       FILL GLOBAL ARRAYS

IGLPROF = 0

!*
!           3.1   LOOP OVER OBSERVATIONS

OBS_LOOP2: DO IOBS = 1, ILEN
  IOBCTP = ROBHDR(IOBS,MDB_CODETYPE_AT_HDR)

  IF(IOBCTP /= NWPPCD .AND. IOBCTP /= NEWPPCD) CYCLE OBS_LOOP2
  ICMONM    = ROBHDR(IOBS,MDBONM)

!*          3.2   ACCEPT ACTIVE REPORTS ONLY

  CALL NGERSTA(INT(ROBHDR(IOBS,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(IOBS,INADA)
  IF(INADA == 0) CYCLE OBS_LOOP2

!*          3.4   UPDATE COUNTER

  IGLPROF = IGLPROF + 1

!           3.5   FILL ARRAY

  ZGLPROF( 1,IGLPROF) = IOBS
  ZGLPROF( 2,IGLPROF) = ROBHDR(IOBS,MDBSID)
  ZGLPROF( 3,IGLPROF) = ICMONM
 
!           3.6   CLOSE THE LOOP

ENDDO OBS_LOOP2

!           3.7   CROSS CHECK

IF(IGLPROF /= INGLPROF) THEN
  WRITE(NULERR,'('' *** ERROR IN REDPROF (1): '')')
  WRITE(NULERR,'(''     IGLPROF = '',I10)') IGLPROF
  WRITE(NULERR,'(''     INGLPROF= '',I10)') INGLPROF
  CALL ABOR1('REDPROF: ERROR 1')
ENDIF
!*
!     ------------------------------------------------------------------

!        4.       SORT
!                 ----

I_MKEY(1) = 2
I_MKEY(2) = 3
isize = INGLPROF
CALL KEYSORT(iret, ZGLPROF, isize,multikey=I_MKEY, transposed=.TRUE.)

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

!         5.          OUTER LOOP
!                     ----------

!*          5.1   LOOP OVER ALL OBS

LOOP_GL1: DO JOBS1 = 1, INGLPROF

  LLEXIT_GLOBAL_LOOP = .FALSE.
  LLPRINT = .FALSE.

  IREFPO = ZGLPROF(1,JOBS1)

!*          5.2   OBSERVATION TYPE & CHARACTERISTICS

  IRFOTP = ROBHDR(IREFPO,MDBOTP)
  IRFCTP = ROBHDR(IREFPO,MDB_CODETYPE_AT_HDR)

!*          5.3   SELECT PROFILER REPORTS

  IF(IRFCTP /= NWPPCD .AND. IRFCTP /= NEWPPCD) CYCLE LOOP_GL1

!           5.4   GET REPORT STATUS

  CALL NGERSTA(INT(ROBHDR(IREFPO,MDBRST)),ICOUNT,IRSTA)
!*
!           5.5   CHECK WHETHER THE REPORT STATUS IS PAS/REJ/BLA

  IF(IRSTA(2) == 1.OR. IRSTA(3) == 1.OR. IRSTA(4) == 1) CYCLE LOOP_GL1

!           5.6   COLLECT HEADER INFORMATION OF REFERENCE REPORT

  IRFONM = ROBHDR(IREFPO,MDBONM)
  ZREFID = ROBHDR(IREFPO,MDBSID)
  IRFITP = ROBHDR(IREFPO,MDB_INSTTYPE_AT_HDR)

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

!         6.         INNER LOOP
!                    ----------

  GLOBAL_LOOP: DO JOBS2 = JOBS1+1, INGLPROF

!*          6.0   STILL AT SAME STATION ID ?

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

!*          6.1   CHECK OBSERVATION TYPE

    IOBOTP = ROBHDR(IOBS,MDBOTP)
    IF(IRFOTP /= IOBOTP) 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   CHECK 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.4  UNIQUE OBSERVATION SEQUENCE NUMBER

    ICMONM = ROBHDR(IOBS,MDBONM)
    IF(IRFONM == ICMONM) CYCLE GLOBAL_LOOP

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

    IOBDAT = ROBHDR(IOBS,MDBDAT)
    IOBETM = ROBHDR(IOBS,MDBETM)
    CALL REFTIM(IOBDAT,IOBETM,ICU)

!*
!           7.2   GET THE REFERENCE TIME

    IRFDAT = ROBHDR(IREFPO,MDBDAT)
    IRFETM = ROBHDR(IREFPO,MDBETM)
    CALL REFTIM(IRFDAT,IRFETM,IRF)
!*
!           7.3   GET THE ANALYSIS TIME

    CALL REFTIM(NANDAT,NANTIM,IAN)

!*
!           7.4   COMPOSE THE PRIORITY FIGURES

    IPR1 = ABS(IRF-IAN)
    IPR2 = ABS(ICU-IAN)

!*
!           7.5   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.6   PRINT WHILE TESTING

    IF(LSCDPR .AND. LLPRINT) THEN
      CLSTID=TRANSFER(ZREFID,CLSTID)
      CLOBCHAR='UNKNOWN'
      IF(IRFCTP == NWPPCD) CLOBCHAR='NWPPCD '
      IF(IRFCTP == NEWPPCD) CLOBCHAR='NEWPPCD'
      
      WRITE(NULOUT,'('' REDUNDANT PROFILER REPORT  ID '',A8,'' TYPE '',A7,'' AN-TIME '',I8,1X,I6,'' REF: DT '',&
       & I4,'' OBS: DT '',I4)')&
       & CLSTID,CLOBCHAR,NANDAT,NANTIM,(IRF-IAN),(ICU-IAN)  
      LLPRINT = .FALSE.
    ENDIF
!*
!           7.7   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
!                 ------

DEALLOCATE(ZGLPROF)

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

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