SUBROUTINE REDSM_NO_SQ(KLEN)

!**** SUBROUTINE REDSM_NO_SQ - FIND SYNOP MASS OBSERVATIONS REDUNDANT TO TEMP

!          HEIKKI JARVINEN   ECMWF          31/DEC/1996
!          DRASKO VASILJEVIC ECMWF          21/10/1999

!*    PURPOSE
!     -------

!        FIND SYNOP MASS OBSERVATIONS REDUNDANT TO TEMP

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

!        CALL REDSM_NO_SQ(KLEN)
!     WHERE KLEN  = DB LEN

!        REDSM_NO_SQ IS CALLED BY SUBROUTINE REDUN

!*    METHOD
!     ------

!        LOOP OVER THE GLOBAL ARRAY OF TEMP/SYNOP REPORTS AND FIND THE
!     PAIRS.

!     REFERENCE REPORT A TEMP:

!     * SYNOP REPORT:
!       - MASS OBSERVATION IS REDUNDANT FOR TEMP MASS OBSERVATION,
!         IF TEMP DATUM BELOW (SYNOP DATUM PRESSURE - 50hPa)

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

!        REFTIM - GET REFERENCE TIME
!        REDTS  - TEMP/SYNOP MASS INFO REDUNDANCY

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

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

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

USE YOMLUN   , ONLY : NULOUT   ,NULERR
USE YOMCOCTP , ONLY : NSYNOP   ,NTEMP
USE YOMANA   , ONLY : NANDAT   ,NANTIM
USE YOMANCS  , ONLY : RDEGREES
USE YOMSCC   , ONLY : LSCDPR
USE YOMDB
USE YOMOBS
USE ecsort_mix   , ONLY : keysort

IMPLICIT NONE

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

!     DUMY INTEGER SCALARS
CHARACTER (LEN=5) ::  CLRFTYP,CLOBTYP

INTEGER(KIND=JPIM) :: IAN, ICU, IEND, INSQ, IOBDAT, IOBETM, IOBTYP, &
 & IRF, IRFDAT, IRFETM, IRFTYP, JPR, &
 & ISTA, ISYNPO, ITEMPO, JOBS, IOBS, IREFPO,&
 & JREF, JSEQ, ILEN, ICOUNT, IGLMAS, INGLMAS, INADA,&
 & INSTA, INEND, IDIM, ICMONM  
INTEGER(KIND=JPIM),DIMENSION(:), ALLOCATABLE :: JSTA(:), JEND(:)

REAL(KIND=JPRB)   , ALLOCATABLE :: ZKEY  (:,:)

INTEGER(KIND=JPIM), PARAMETER   :: icolumns0=7,ipo=1,idt0=2,itm0=3,ilt=4,iln=5,icom=6,irn0=7

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

REAL(KIND=JPRB) :: Z_ST, ZIDOBS, ZIDREF, ZOBLAT, ZOBLON, ZRFLAT, ZRFLON
LOGICAL :: LL_PRINT
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "fcobs.h"

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

!        0.       INFORM
!                 ------

IF (LHOOK) CALL DR_HOOK('REDSM_NO_SQ',0,ZHOOK_HANDLE)
IF(LSCDPR) WRITE(NULOUT,'('' REDSM_NO_SQ; REDUNDANT SYNOP/TEMP MASS INFO '')')
LL_PRINT=LTHINNER_PRINT
ILEN = KLEN

!           0.1   PRESORT OBS PER DATE, TIME, LAT, LON AND ...
!                 TO AVOID USING OBS SEQUENCE NO.

ALLOCATE(ZKEY (ILEN,icolumns0))
CALL THIN_RED_PRESORT(ILEN,'REDSM',ZKEY,icolumns0,&
 & IPO,IDT0,ITM0,ILT,ILN,ICOM,IRN0 )  

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

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

!*
!           1.1   LOOP OVER OBSERVATIONS

IGLMAS = 0
OBS_LOOP1: DO JOBS = 1, ILEN
  IOBS      = ZKEY(JOBS,1)
  IOBTYP    = ROBHDR(IOBS,MDBOTP)
  IF(IOBTYP /= NSYNOP .AND. IOBTYP /=NTEMP) 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

  IGLMAS = IGLMAS+ 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 TEMP/SYNOP REPORTS:'',I10)') IGLMAS
ENDIF
INGLMAS = IGLMAS
IF(INGLMAS == 0)  GO TO 10

!*          2.1   PRESET

INSTA  = 1
INEND  = INGLMAS
IDIM   = INGLMAS

!*          2.2

ALLOCATE(JSTA(IDIM))
IF(LSCDPR) THEN
  WRITE(NULOUT,9990) 'JSTA  ',SIZE(JSTA),SHAPE(JSTA)
ENDIF

!*          2.3

ALLOCATE(JEND(IDIM))
IF(LSCDPR) THEN
  WRITE(NULOUT,9990) 'JEND  ',SIZE(JEND),SHAPE(JEND)
ENDIF

!*          2.4        POINTER/SORT ARRAY

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

!*          2.5        FORMAT

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

!        3.       FILL GLOBAL ARRAYS

IGLMAS = 0

!*
!           3.1   LOOP OVER OBSERVATIONS

OBS_LOOP2: DO JOBS = 1, ILEN
  IOBS      = ZKEY(JOBS,IPO)
  IOBTYP    = ROBHDR(IOBS,MDBOTP)
  IF(IOBTYP /= NSYNOP .AND. IOBTYP /=NTEMP) 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

  IGLMAS = IGLMAS + 1

!           3.5   FILL ARRAY

  ZGLMAS( 1,IGLMAS) = IOBS
  ZGLMAS( 2,IGLMAS) = ROBHDR(IOBS,MDBSID)
  ZGLMAS( 3,IGLMAS) = ZKEY(JOBS,IRN0)
! ZGLMAS( 3,IGLMAS) = IRAND (IOBS)
! ZGLMAS( 3,IGLMAS) = ICMONM

!           3.6   CLOSE THE LOOP

ENDDO OBS_LOOP2

!           3.7   CROSS CHECK

IF(IGLMAS /= INGLMAS) THEN
  WRITE(NULERR,'('' *** ERROR IN REDSM_NO_SQ (1): '')')
  WRITE(NULERR,'(''     IGLMAS = '',I10)') IGLMAS
  WRITE(NULERR,'(''     INGLMAS= '',I10)') INGLMAS
  CALL ABOR1('REDSM_NO_SQ: ERROR 1')
ENDIF
!*
!     ------------------------------------------------------------------

!        4.       SORT
!                 ----
IF(LL_PRINT) THEN
  WRITE(NULOUT,'('' REDSM_NO_SQ; ZKEY'')')
  DO JPR=1,ILEN
    WRITE(NULOUT,'('' '',I6,1X,6(F15.2,1X))') JPR,&
     & ZKEY(JPR,2),ZKEY(JPR,3),&
     & ZKEY(JPR,4),ZKEY(JPR,5),&
     & ZKEY(JPR,6),&
     & ZKEY(JPR,7)  
  ENDDO
  CALL FLUSH(NULOUT)
ENDIF

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

IF(LL_PRINT) THEN
  WRITE(NULOUT,'('' REDSM_NO_SQ; ZGLMAS '')')
  DO JPR=1,INGLMAS
    IOBS = ZGLMAS(1,JPR)
    WRITE(NULOUT,'('' '',I5,1X,2(F15.2,1X))') JPR,&
     & ROBHDR(IOBS,MDBLAT)*RDEGREES,ROBHDR(IOBS,MDBLON)*RDEGREES  
  ENDDO
  CALL FLUSH(NULOUT)
ENDIF

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

!        5.       PRECALCULATE POINTERS TO STATION SEQUENCES
!                 ------------------------------------------
!*
!           5.0   INITIALIZE

INSQ = 0
ISTA = 1
IEND = 1
IOBS = ZGLMAS(1,1)
Z_ST = ROBHDR(IOBS,MDBSID)
!*
!           5.1   LOOP OVER THE GLOBAL TEMP/SYNOP ARRAY

DO JOBS = 2, INEND
  IOBS = ZGLMAS(1,JOBS)

!*          5.2   SEARCH FOR A SEQUENCE OF MORE THAN 2 SAME STATION IDS
!                 AND COMPOSE THE INITIAL ENTRIES FOR DISTRIBUTION

  IF(ROBHDR(IOBS,MDBSID) == Z_ST) THEN
    IEND = JOBS
  ELSE
    IF(IEND > ISTA) THEN
      INSQ = INSQ + 1
      JSTA(INSQ) = ISTA
      JEND(INSQ) = IEND
    ENDIF
    Z_ST = ROBHDR(IOBS,MDBSID)
    ISTA = JOBS
    IEND = JOBS
  ENDIF
ENDDO
IF(IEND > ISTA) THEN
  INSQ = INSQ + 1
  JSTA(INSQ) = ISTA
  JEND(INSQ) = IEND
ENDIF
!*
!     ------------------------------------------------------------------

!        6.       STUDY ALL THE SEQUENCES
!                 -----------------------
!*
!           6.1   START THE LOOP OVER THE SEQUENCES

SEQUENCE_LOOP: DO JSEQ = 1, INSQ
!*
!           6.2   START THE LOOP OVER THE SEQUENCES

  OUTER_LOOP: DO JREF = JSTA(JSEQ), JEND(JSEQ)
    IREFPO = ZGLMAS(1,JREF)

!*          6.3   OBSERVATION TYPE: ONLY TEMP ALLOWED

    IRFTYP = ROBHDR(IREFPO,MDBOTP)
    IF(IRFTYP /= NTEMP) CYCLE OUTER_LOOP
!*
!           6.4   COLLECT HEADER INFORMATION OF REFERENCE REPORT

    ZRFLAT = ROBHDR(IREFPO,MDBLAT)
    ZRFLON = ROBHDR(IREFPO,MDBLON)
    ZIDREF = ROBHDR(IREFPO,MDBSID)
!*
!           6.5   START THE INNER LOOP

    INNER_LOOP: DO JOBS = JSTA(JSEQ), JEND(JSEQ)
      IOBS = ZGLMAS(1,JOBS)

!*          6.6   EXCLUDE INCEST

      IF(JOBS == JREF) CYCLE INNER_LOOP

!*          6.7   OBSERVATION TYPE

      IOBTYP = ROBHDR(IOBS,MDBOTP)
      IF(IOBTYP /= NSYNOP) CYCLE INNER_LOOP

!           6.10  LATITUDE, LONGITUDE

      ZOBLAT = ROBHDR(IOBS,MDBLAT)
      ZOBLON = ROBHDR(IOBS,MDBLON)
      IF(ZRFLAT /= ZOBLAT) CYCLE INNER_LOOP
      IF(ZRFLON /= ZOBLON) CYCLE INNER_LOOP
!*
!           6.11  STATION ID

      ZIDOBS = ROBHDR(IOBS,MDBSID)
      IF(ZIDREF /= ZIDOBS) CYCLE INNER_LOOP
!*
!     ------------------------------------------------------------------

!        7.       COMPARE OBSERVATIONS
!                 --------------------

!*          7.0   INITIALIZE POINTERS TO SYNOP REPORT

      ISYNPO = IOBS

!*          7.1   INITIALIZE POINTERS TO TEMP  REPORT

      ITEMPO = IREFPO

!*          7.2   REDUNDANT MASS INFO IN TEMP/SYNOP PAIR

      CALL REDTS(ITEMPO,ISYNPO)

!*          7.3   INFORM

      IF(LSCDPR) THEN
        CLRFTYP = ' TEMP'
        CLOBTYP = 'SYNOP'
        ITEMPO = JREF
        IRFDAT = ROBHDR(ITEMPO,MDBDAT)
        IRFETM = ROBHDR(ITEMPO,MDBETM)
        IOBDAT = ROBHDR(ISYNPO,MDBDAT)
        IOBETM = ROBHDR(ISYNPO,MDBETM)
        CALL REFTIM(IRFDAT,IRFETM,IRF)
        CALL REFTIM(IOBDAT,IOBETM,ICU)
        CALL REFTIM(NANDAT,NANTIM,IAN)
        WRITE(NULOUT,'('' REDSM_NO_SQ; REDUNDANT(2) '',A5,''/'',A5,&
         & '' AT '',2(F7.2,1X),&
         & '' AN-TIME '',I8,1X,I6,'' REF: DT '',I4,&
         & '' OBS: DT '',I4)')&
         & CLRFTYP,CLOBTYP,ZOBLAT*RDEGREES,&
         & ZOBLON*RDEGREES,NANDAT,NANTIM,(IRF-IAN),(ICU-IAN)  
      ENDIF

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

!        8.       CLOSE THE LOOP OVER ...
!                 -----------------------

!*          8.1   ... THE OBSERVATIONS

    ENDDO INNER_LOOP

!*          8.2   ... THE OBSERVATIONS

  ENDDO OUTER_LOOP

!*          8.3   ... THE SEQUENCES

ENDDO SEQUENCE_LOOP
!*
!     ------------------------------------------------------------------

!        9.       DEALOC
!                 ------

9 CONTINUE
DEALLOCATE(JSTA)
DEALLOCATE(JEND)
DEALLOCATE(ZGLMAS)

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

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