!-------------------------------------- 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 SOBSSFC 1
#if defined (DOC)
*
***s/r SOBSSFC
*
*Author : P. Koclas *CMC/AES October 1998
*Revision: C.Charette *ARMA/AES MAR 1999
* - REJECT FLAGS IN CMA
* C. Charette *ARMA/AES Jan 2000
* - Added llprint for diagnostics
*Revision: P KOCLAS CMC/CMDA JAN 2000
* -CHANGE HEADER FLAG IN CASE OF REJECT
* C. Charette *ARMA/AES MAR2000
* - Remove setting of qc flags 6 and 9
* C. Charette *ARMA/AES OCT2000
* - Remove displacement of accepted elements 12203,11215,11216
C to the model surface height when the reported height is
C greater than the model surface height.
* S. Macpherson *ARMA/MRD Sep 2007
* - Added GPS (GP) family data (met and ZTD).
* DZMAX from namelist file is used for ZTD.
*
** Purpose:
* Refuse elements which are too far away from the surface.
* Replace the pressure of elements which are slightly below
* the model surface by the pressure of the trial field.
*
*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 "comcst.cdk"
#include "comfilt.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
#include "comgpsgb.cdk"
*
INTEGER JPINEL,JPIDLND
PARAMETER(JPINEL=10,JPIDLND=10)
INTEGER J,JD,JF,JID,JOBS,JDATA,IOBS1,IOBS2,IBAD,IFLG
LOGICAL LLREJ, LLPRINT, LLOK
REAL*8 ZVAL,ZLEV,ZLEV2,ZDIFF,ZHHH,ZMODEL
INTEGER ITYP,IDATA,IDATEND,IDBURP,ITY
INTEGER ILEM,ICRIT,IBEGIN,ILAST
INTEGER ILISTEL(JPINEL),IDLND(JPIDLND)
INTEGER IKOUNTREA(JPINEL),IKOUNTREJ(JPINEL),IKOUNTT
REAL*8 RLISTCRIT(JPINEL)
DATA RLISTCRIT/50.,50.,50.,50.,50.
& ,800.,800.,800.,800.,1000. /
C SYNOP(3) TEMP/PILOT(6) GPS MET(1)
DATA IDLND / 12, 14, 146, 32, 35, 135, 136, 137, 138, 189 /
C
C
C RESET DZMAX FOR GB GPS ZTD TO VALUE IN NAMELIST FILE
C
RLISTCRIT(10) = DZMAX
C
ILISTEL(1)=NEDS
ILISTEL(2)=NEFS
ILISTEL(3)=NEUS
ILISTEL(4)=NEVS
ILISTEL(5)=NESS
ILISTEL(6)=NETS
ILISTEL(7)=NEPS
ILISTEL(8)=NEPN
ILISTEL(9)=NEGZ
ILISTEL(10)=NEZD
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SOBSSFC '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,222)'ELEMENTS ',( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,223)'REJECTION BOUNDARY(METRE) ',(RLISTCRIT(J),J=1,jpinel)
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,* ) ' '
LLPRINT = .FALSE.
ccc LLPRINT = .TRUE.
C
C SET COUNTERS TO ZERO
C
DO J=1,JPINEL
IKOUNTREJ(J)=0
IKOUNTREA(J)=0
END DO
IKOUNTT=0
C
C LOOP OVER OBSERVATIONS
C
DO JF = 1,NFILES
IF ( (CFAMTYP(JF) .EQ. 'SF') .AND.( NBEGINTYP(JF) .GT. 0) .OR.
& (CFAMTYP(JF) .EQ. 'UA') .AND.( NBEGINTYP(JF) .GT. 0) .OR.
& (CFAMTYP(JF) .EQ. 'GP') .AND.( NBEGINTYP(JF) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(JF)
ILAST=NENDTYP(JF)
IOBS1=MOBDATA(NCMOBS,NBEGINTYP(JF))
IOBS2=MOBDATA(NCMOBS,NENDTYP(JF))
WRITE(NULOUT,'(2x,A9,2x,A2)')'FAMILY = ',CFAMTYP(JF)
C
C
DO JOBS=IOBS1,IOBS2
IF(LLPRINT) THEN
ccc CALL PRNTHDR(JOBS,NULOUT)
ccc CALL PRNTBDY(JOBS,NULOUT)
ENDIF
IDATA = MOBHDR(NCMRLN,JOBS)
IDATEND = MOBHDR(NCMNLV,JOBS) + IDATA - 1
DO JDATA= IDATA, IDATEND
LLOK = MOBDATA(NCMVCO,JDATA) .EQ. 1
IF (LLOK) THEN
IKOUNTT=IKOUNTT+1
IFLG = MOBDATA(NCMFLG,JDATA)
ITYP=MOBDATA(NCMVNM,JDATA)
ITY = MOBHDR(NCMITY,JOBS)
IDBURP = MOD(ITY,1000)
ZDIFF=99999.
IF ( (ITYP .eq. NEGZ) ) THEN
LLREJ = .FALSE.
DO JD=1,NFLAGS
IBAD= 13-NLISTFLG(JD)
LLREJ=( BTEST(IFLG,IBAD) ) .OR. LLREJ
END DO
IF ( .NOT. LLREJ ) THEN
ZVAL=ROBDATA8(NCMVAR,JDATA)
ZDIFF= ABS( ( ZVAL-GOMGZHR(NLEVTRL,JOBS) )/RG )
ZLEV=ROBDATA8(NCMPPP,JDATA)
ENDIF
ELSE
ZHHH=ROBDATA8(NCMPPP,JDATA)
ITYP=MOBDATA(NCMVNM,JDATA)
ZDIFF= ABS( ZHHH- GOMGZHR(NLEVTRL,JOBS)/RG )
ZLEV=ROBDATA8(NCMPPP,JDATA)
ENDIF
ZVAL=ROBDATA8(NCMVAR,JDATA)
ITYP=MOBDATA(NCMVNM,JDATA)
ZLEV2=ROBDATA8(NCMPPP,JDATA)
C
C APPLY FILTER TO SELECTED ELEMENTS
C
DO J=1,JPINEL
ICRIT=RLISTCRIT(J)
ILEM=ILISTEL(J)
IF (ZLEV .EQ. ZLEV2 .AND. ITYP .EQ. ILEM ) THEN
IF ( ZDIFF .LE. ICRIT) THEN
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) THEN
IKOUNTREA(J)=IKOUNTREA(J)+1
IF(LLPRINT) THEN
ZMODEL = GOMGZHR(NLEVTRL,JOBS)/RG
write(nulout,*)'Keep OBS:stnid,jobs,ityp,icrit,'
& ,'zlev,zhhh,zmodel,zdiff '
& ,CSTNID(JOBS),JOBS,ITYP,ICRIT
& ,zlev,zhhh,zmodel,zdiff
ENDIF
ENDIF
ELSE
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) THEN
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
IF(LLPRINT) THEN
WRITE(NULOUT,225) 'Reject OBS ',JOBS,ITYP
& ,CSTNID(JOBS),IDBURP
& ,ROBHDR(NCMLAT,JOBS),ROBHDR(NCMLON,JOBS)
ENDIF
MOBDATA(NCMASS,JDATA)=0
IKOUNTREJ(J)=IKOUNTREJ(J)+1
ENDIF
ENDIF
ENDIF
END DO
ENDIF
END DO
END DO
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,222 )'ELEMENTS ', ( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'ACCEPTED ',(IKOUNTREA(J),J=1,JPINEL)
WRITE(NULOUT,222)'REJECTED ',(IKOUNTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,* ) ' '
222 FORMAT(2x,a29,10(2x,i5))
223 FORMAT(2x,a29,10(2x,f5.0))
224 FORMAT(2x,a17,2x,I6,2X,I5,1x,a9,1x,2(2x,f9.2))
225 FORMAT(2x,a13,2x,I6,2X,I5,1x,a9,1x,I6,1x,4(2x,f9.2))
C
ENDIF
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