!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE SOBSCSBT 1
#if defined (DOC)
*
***s/r SOBSCSBT
*
*Author : R. Sarrazin *CMC/AES June 2008
*Revision:
*
*
** Purpose:
* Refuse data which are too close to the surface.
*
*Arguments:
*
* none
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvohr.cdk"
#include "cvcord.cdk"
*
INTEGER JPINEL
PARAMETER(JPINEL=1)
INTEGER J,JF,JOBS,JDATA,IOBS1,IOBS2
LOGICAL LLPRINT
REAL*8 ZVAL,ZDIFF
INTEGER ITYP,IDATA,IDATEND,IDATYP
INTEGER ILEM,IBEGIN,ILAST
INTEGER IKOUNTREJ(JPINEL),IKOUNTT
INTEGER ILISTEL(JPINEL)
DATA ILISTEL/12163/
REAL*8 RLISTCRIT
DATA RLISTCRIT/800./
C
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SOBSCSBT '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '****************************************************'
WRITE(NULOUT,222)'ELEMENTS ', ( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,223)'REJECTION BOUNDARY(HPA) ', RLISTCRIT
WRITE(NULOUT,* ) '****************************************************'
WRITE(NULOUT,* ) ' '
LLPRINT = .FALSE.
C
C SET COUNTERS TO ZERO
C
DO J=1,JPINEL
IKOUNTREJ(J)=0
END DO
IKOUNTT=0
C
C LOOP OVER OBSERVATION FILES
C
DO JF = 1,NFILES
IF ( (CFAMTYP(JF) .EQ. 'TO') .AND. (NBEGINTYP(JF) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(JF)
ILAST=NENDTYP(JF)
IOBS1=MOBDATA(NCMOBS,NBEGINTYP(JF))
IOBS2=MOBDATA(NCMOBS,NENDTYP(JF))
WRITE(NULOUT,*)' FAMILY = ',CFAMTYP(JF)
C
C
DO JOBS=IOBS1,IOBS2
C
IDATA = MOBHDR(NCMRLN,JOBS)
IDATEND = MOBHDR(NCMNLV,JOBS) + IDATA - 1
IDATYP = MOD(MOBHDR(NCMITY,JOBS),1000)
IF (IDATYP .EQ. 185) THEN
C
C REJECT DATA TOO CLOSE TO THE OROGRAPHY
C
DO JDATA= IDATA, IDATEND
IKOUNTT=IKOUNTT+1
ZDIFF= GOMPSHR(1,JOBS) /100.
IF ( ZDIFF .LT. RLISTCRIT ) THEN
ITYP=MOBDATA(NCMVNM,JDATA)
DO J=1,JPINEL
ILEM=ILISTEL(J)
IF ( ITYP .EQ. ILEM ) THEN
IF(LLPRINT) THEN
WRITE(NULOUT,224) 'Reject OBS '
& ,JOBS,ITYP,ROBDATA8(NCMPPP,JDATA),ZDIFF
ENDIF
MOBDATA(NCMASS,JDATA)=0
IKOUNTREJ(J)=IKOUNTREJ(J)+1
MOBDATA(NCMFLG,JDATA)=IBSET(MOBDATA(NCMFLG,JDATA),18)
ENDIF
END DO
ENDIF
END DO
C
END IF
C
END DO
C
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* )
& '*****************************************************************'
WRITE(NULOUT,222 )'ELEMENTS ', ( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'REJECTED ',(IKOUNTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* )
& '*****************************************************************'
WRITE(NULOUT,* ) ' '
222 FORMAT(2x,a29,5(2x,i5))
223 FORMAT(2x,a29,5(2x,f5.0))
224 FORMAT(2x,a13,2x,I6,2X,I5,2(2x,f9.2))
C
END IF
END DO
C
IKOUNTT=0
DO JDATA=1,NDATA
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) IKOUNTT=IKOUNTT+1
END DO
WRITE(NULOUT
& ,'(1X," NUMBER OF DATA ASSIMILATED BY 3D-VAR AFTER ADJUSTMENTS:",i10)')IKOUNTT
WRITE(NULOUT,* ) ' '
RETURN
END