!-------------------------------------- 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 LISTREJ(lobsSpaceData) 1,71
#if defined (DOC)
*
*
************************************************************************
*
*PURPOSE: LIST ALL OBSERVATIONS REJECTED BY THE VARIATIONAL QC
* SET QC FLAGS CONSISTENT WITH VARQC DECISIONS
* SET GLOBAL FLAG INDICATING REPORT CONTAINS REJECTED OBSERVATION
* AS REQUIRED
*
*
*ARGUMENTS: NONE
*
*AUTHOR: B. BRASNETT (CMDA/MSC) MARCH 2000
*REVISION: B. BRASNETT (CMDA/MSC) NOV 2001
* - Added idtyp 177
* S. Pellerin *ARMA/SMC nov. 2001
* - reordering of declaration dependencies (for Linux compilation)
* N. Wagnewur (CMDA/MSC) Juin 2002
* - Added idtyp 180 for GOES Raidiances
* B. Brasnett (CMDA/MSC) Sept 2003
* - List TOVS rejects
* J. Halle (CMDA/MSC) Sept 2005
* - Added idtyp 182 for MHS.
* A. Beaulne (CMDA/SMC) June 2006
* - Added idtyp 183 for AIRS.
* R. Sarrazin CMDA April 2008
* - added idtyp 185 for CSR
* S. Heilliette
* - added idtyp 186 for IASI
* S. Pellerin (ARMA/MRB) January 2009
* - Use of robdata8(OBS_OMN,*) [2013: now OBS_QCV] as zpost value
* S. Macpherson (ARMA/MRD) Sep 2009
* - List GP family (GPS) rejects (idtyp 189)
* S. Macpherson (ARMA/MRD) Feb 2013
* - added idtyp=192 for ATMS
************************************************************************
#endif
*
use EarthConstants_mod
use MathPhysConstants_mod
use obsSpaceData_mod
use columnData_mod
use bufr
use minimization_mod
IMPLICIT NONE
*
type(struct_obs) :: lobsSpaceData
INTEGER, parameter :: numFamily = 9
CHARACTER(len=2), parameter :: listFamily(numFamily) = (/'UA','AI','SF','SW','PR','RO','GP','SC','TO'/)
INTEGER, parameter :: MAXNUMTYPE=254,NUMITEM=13
CHARACTER *16 CLOBTP(MAXNUMTYPE)
INTEGER ICOUNT(NUMITEM,numFamily)
*
*
INTEGER JFAM,JITEM,INDEX_HEADER
INTEGER INDEX_BODY,INDEX_BODY2,ISTART,ITYP,ISTYP
INTEGER ISPDO,IDIRO,ISPDF,IDIRF,ISPDA,IDIRA,ILEV
INTEGER IDBURP,IOTHER
REAL*8 ZVAR,ZFCST,ZANA,ZPOST,ZLAT,ZLON,ZUU,ZVV
REAL*8 SPD,DEG,ZLEV,ZSLEV,ZCUT
CHARACTER *4 CLITM(NUMITEM),CLDESC
CHARACTER *2 CLUNITS
*
LOGICAL LLOK,LLELREJ
*
* ------NOTE----------
* CURRENTLY SUPPORTED FAMILIES OF DATA 'UA' 'AI' 'SF' 'HU' 'TO' 'GO' 'GP'
*
DATA ZCUT /0.75D0/
DATA CLITM(1), CLITM(2), CLITM(3), CLITM(4), CLITM(5), CLITM(6)
1 /'WND', 'WND', 'HGT', 'TMP', 'DPD', 'STNP'/
DATA CLITM(7), CLITM(8), CLITM(9), CLITM(10), CLITM(11), CLITM(12)
1 /'MSLP', 'TSFC', 'SDPD', 'SWND', 'SWND', 'BTMP'/
DATA CLITM(13) /'ZTD'/
DATA CLOBTP(12), CLOBTP(13), CLOBTP(14), CLOBTP(15)
1 / 'SYNOP', 'SHIP', 'SYNOP MOBIL', 'METAR'/
DATA CLOBTP(16), CLOBTP(18), CLOBTP(20), CLOBTP(32)
1 / 'SPECI', 'DRIFTER', 'RADOB', 'PILOT'/
DATA CLOBTP(33), CLOBTP(34), CLOBTP(35), CLOBTP(36)
1 / 'PILOT SHIP','PILOT MOBIL', 'TEMP', 'TEMP SHIP'/
DATA CLOBTP(37), CLOBTP(38), CLOBTP(39), CLOBTP(40)
1 / 'TEMP DROP', 'TEMP MOBIL', 'ROCOB', 'ROCOB SHIP'/
DATA CLOBTP(42), CLOBTP(54), CLOBTP(61), CLOBTP(62)
1 / 'AMDAR', 'ROFOR', 'MAFOR', 'TRACKOB'/
DATA CLOBTP(63), CLOBTP(64), CLOBTP(65), CLOBTP(67)
1 / 'BATHY', 'TESAC', 'WAVEOB', 'HYDRA'/
DATA CLOBTP(68), CLOBTP(71), CLOBTP(72)
1 / 'HYFOR', 'CLIMAT', 'CLIMAT SHIP'/
DATA CLOBTP(73), CLOBTP(75), CLOBTP(76)
1 / 'NACLI/CLINP', 'CLIMATE TEMP','CLIMATE TEMP SHP'/
DATA CLOBTP(85), CLOBTP(86), CLOBTP(87)
1 / 'SAREP', 'SATEM', 'SARAD'/
DATA CLOBTP(88), CLOBTP(128), CLOBTP(129)
1 / 'SATOB', 'AIREP', 'PIREP'/
DATA CLOBTP(130), CLOBTP(131), CLOBTP(132)
1 / 'PROFILER', 'SUPER SYNOP', 'SUPER AIREP'/
DATA CLOBTP(135), CLOBTP(136), CLOBTP(137)
1 / 'TEMP+PILOT', 'TEMP+SYNOP', 'PILOT+SYNOP'/
DATA CLOBTP(138), CLOBTP(139), CLOBTP(140)
1 /'TEMP+PILOT+SYNOP', 'TEMP SHIP+PILOT', 'TEMP SHIP+SHIP'/
DATA CLOBTP(141), CLOBTP(142), CLOBTP(143)
1 /'PILOT SHIP+SHIP','TEMPSHP+PILOT+SH', 'SAWR'/
DATA CLOBTP(144), CLOBTP(145), CLOBTP(146)
1 /'AUTOMATIC SAWR', 'SYNOP PATROL','AUTOMATIC SYNOP'/
DATA CLOBTP(147), CLOBTP(148), CLOBTP(149)
1 /'AUTOMATIC SHIP', 'SAWR SPECIAL','AUTOSAWR SPECIAL'/
DATA CLOBTP(150), CLOBTP(151), CLOBTP(152)
1 /'ANAL BOGUS SFC', 'ANAL BOGUS ALT','REPAIR BOGUS SFC'/
DATA CLOBTP(153), CLOBTP(157), CLOBTP(158)
1 /'REPAIR BOGUS ALT', 'ACARS', 'HUMSAT'/
DATA CLOBTP(159), CLOBTP(160), CLOBTP(161)
1 /'TEMP MOBIL+PILOT','TEMP MOBIL+SYNOP','PILOT MOBIL+SYNP'/
DATA CLOBTP(162), CLOBTP(163), CLOBTP(164)
1 /'TEMP MOBIL+PI+SY', 'RADAR', 'TOVS AMSU-A'/
DATA CLOBTP(167), CLOBTP(168), CLOBTP(169)
1 / 'ERS-1', 'SSM/I', 'GPSMET'/
DATA CLOBTP(170), CLOBTP(177), CLOBTP(180)
1 / 'OZONE', 'ADS', 'GOES'/
DATA CLOBTP(181), CLOBTP(182), CLOBTP(183)
1 / 'TOVS AMSU-B', 'TOVS MHS', 'AIRS'/
DATA CLOBTP(185), CLOBTP(186), CLOBTP(188)
1 / 'GEORAD', 'IASI', 'SATOB'/
DATA CLOBTP(189), CLOBTP(192), CLOBTP(193)
1 / 'GB-GPS', 'TOVS ATMS', 'CRIS'/
DATA CLOBTP(254)
1 / 'SCATTEROMETER'/
*
IF(.NOT.min_lvarqc) RETURN
DO JFAM=1,numFamily
DO JITEM=1,NUMITEM
ICOUNT(JITEM,JFAM) = 0
ENDDO
ENDDO
WRITE(*,610)
610 FORMAT(//'LIST OF DATA REJECTED BY VARIATIONAL QUALITY CONTROL')
*
*_____LOOP OVER ALL REPORTS, ONE FAMILY AT A TIME
*
FAMILY: DO JFAM = 1,numFamily
WRITE(*,600)
600 FORMAT(1X)
IF (listFamily(JFAM) .NE. 'TO') THEN
WRITE(*,601)
ELSE
WRITE(*,602)
ENDIF
601 FORMAT('IDENT TYPE DESCRIPTION LAT LONG ',
1 'LEVEL ITEM OBSVD BKGND ANAL POST PROB',
2 ' REPORT')
602 FORMAT('IDENT TYPE DESCRIPTION LAT LONG ',
1 'CHNL ITEM OBSVD BKGND ANAL POST PROB',
2 ' REPORT')
*
! loop over all header indices of the family
call obs_set_current_header_list(lobsSpaceData,listFamily(jfam))
HEADER: do
index_header = obs_getHeaderIndex(lobsSpaceData)
if (index_header < 0) exit HEADER
LLELREJ = .FALSE.
IDBURP = obs_headElem_i(lobsSpaceData,OBS_ITY,INDEX_HEADER)
ZLAT = obs_headElem_r(lobsSpaceData,OBS_LAT,INDEX_HEADER)*MPC_DEGREES_PER_RADIAN_R8
ZLON = obs_headElem_r(lobsSpaceData,OBS_LON,INDEX_HEADER)*MPC_DEGREES_PER_RADIAN_R8
! loop over all body indices for this index_header
call obs_set_current_body_list(lobsSpaceData, index_header)
BODY: do
index_body = obs_getBodyIndex(lobsSpaceData)
if (index_body < 0) exit BODY
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY)
IF (ITYP .EQ. BUFR_NETS .OR. ITYP .EQ. BUFR_NEPS .OR.
1 ITYP .EQ. BUFR_NEPN .OR. ITYP .EQ. BUFR_NESS .OR.
2 ITYP .EQ. BUFR_NEUS .OR. ITYP .EQ. BUFR_NEVS .OR.
3 ITYP .EQ. BUFR_NEZD) THEN
LLOK = (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1)
ELSE
LLOK = (obs_bodyElem_i(lobsSpaceData,OBS_ASS,INDEX_BODY) .EQ. 1 .AND.
1 obs_bodyElem_i(lobsSpaceData,OBS_XTR,INDEX_BODY) .EQ. 0) .OR.
2 (obs_bodyElem_i(lobsSpaceData,OBS_XTR,INDEX_BODY) .EQ. 2 .AND.
3 obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY) .EQ. BUFR_NEGZ)
ENDIF
IF (LLOK) THEN
zpost = obs_bodyElem_r(lobsSpaceData,OBS_QCV,INDEX_BODY)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)*MPC_MBAR_PER_PA_R8
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY) .EQ. 2) THEN
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)*MPC_MBAR_PER_PA_R8
CLUNITS = 'MB'
ENDIF
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY) .EQ. 1) THEN
*
*________________VERTICAL COORDINATE IS HEIGHT
*
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
CLUNITS = ' M'
ENDIF
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY) .EQ. -1) THEN
*
*________________TOVS CHANNEL NUMBER
*
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY)
CLUNITS = ' '
ENDIF
ZVAR = obs_bodyElem_r(lobsSpaceData,OBS_VAR,INDEX_BODY)
ZFCST= ZVAR - obs_bodyElem_r(lobsSpaceData,OBS_OMP,INDEX_BODY)
ZANA = ZVAR - obs_bodyElem_r(lobsSpaceData,OBS_OMA,INDEX_BODY)
*
*_____________TREAT WINDS AS SPECIAL CASE
* BUFR_NEUU = 011003 (U COMPONENT) (m/s)
* BUFR_NEVV = 011004 (V COMPONENT) (m/s)
* BUFR_NEUS = 011215 (U COMPONENT AT 10 M) (m/s)
* BUFR_NEVS = 011216 (V COMPONENT AT 10 M) (m/s)
*
IF (((ITYP.EQ.BUFR_NEUU .OR. ITYP .EQ. BUFR_NEUS) .AND.
1 col_varExist('UU')).OR.
2 ((ITYP.EQ.BUFR_NEVV .OR. ITYP .EQ. BUFR_NEVS) .AND.
3 col_varExist('VV'))) THEN
IOTHER = -1
IF (ITYP .EQ. BUFR_NEUU .OR. ITYP .EQ. BUFR_NEUS) THEN
ISTART=obs_headElem_i(lobsSpaceData,OBS_RLN,INDEX_HEADER)
DO INDEX_BODY2=ISTART,INDEX_BODY
ISTYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2)
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY2) .EQ. 2) THEN
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2)*MPC_MBAR_PER_PA_R8
ENDIF
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY2) .EQ. 1) THEN
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2)
ENDIF
IF ((ISTYP .EQ. BUFR_NEVV .OR. ISTYP .EQ. BUFR_NEVS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = INDEX_BODY2
ENDIF
ENDDO
ELSE
ISTART=obs_headElem_i(lobsSpaceData,OBS_RLN,INDEX_HEADER)
DO INDEX_BODY2=ISTART,INDEX_BODY
ISTYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,INDEX_BODY2)
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY2) .EQ. 2) THEN
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2)*MPC_MBAR_PER_PA_R8
ENDIF
IF (obs_bodyElem_i(lobsSpaceData,OBS_VCO,INDEX_BODY2) .EQ. 1) THEN
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,INDEX_BODY2)
ENDIF
IF ((ISTYP .EQ. BUFR_NEUU .OR. ISTYP .EQ. BUFR_NEUS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = INDEX_BODY2
ENDIF
ENDDO
ENDIF
IF (IOTHER .NE. -1) THEN
IF (ITYP .EQ. BUFR_NEVV .OR. ITYP .EQ. BUFR_NEUS) THEN
ZUU = ZVAR
ZVV = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
ELSE
ZVV = ZVAR
ZUU = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
ENDIF
SPD = SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDO = NINT(SPD)
IF (ZUU.EQ.0.D0 .AND. ZVV.EQ.0.D0)THEN
IDIRO = 999
ELSE
DEG = 270. - ATAN2(ZVV,ZUU)*MPC_DEGREES_PER_RADIAN_R8
IF (DEG .GT. 360.D0)DEG = DEG - 360.D0
IF (DEG .LT. 0.D0) DEG = DEG + 360.D0
IDIRO = NINT(DEG)
ENDIF
IF (ITYP .EQ. BUFR_NEUU .OR. ITYP .EQ. BUFR_NEUS) THEN
ZUU = ZFCST
ZVV = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
1 - obs_bodyElem_r(lobsSpaceData,OBS_OMP,IOTHER)
ELSE
ZVV = ZFCST
ZUU = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
1 - obs_bodyElem_r(lobsSpaceData,OBS_OMP,IOTHER)
ENDIF
SPD=SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDF = NINT(SPD)
IF (ZUU .EQ. 0.D0 .AND. ZVV .EQ. 0.D0) THEN
IDIRF = 999
ELSE
DEG = 270.D0 - ATAN2(ZVV,ZUU)*MPC_DEGREES_PER_RADIAN_R8
IF (DEG .GT. 360.D0)DEG = DEG - 360.D0
IF (DEG .LT. 0.D0) DEG = DEG + 360.D0
IDIRF = NINT(DEG)
ENDIF
IF (ITYP .EQ. BUFR_NEUU .OR. ITYP .EQ. BUFR_NEUS) THEN
ZUU = ZANA
ZVV = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
1 - obs_bodyElem_r(lobsSpaceData,OBS_OMA,IOTHER)
ELSE
ZVV = ZANA
ZUU = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
1 - obs_bodyElem_r(lobsSpaceData,OBS_OMA,IOTHER)
ENDIF
SPD=SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDA = NINT(SPD)
IF (ZUU.EQ.0.D0 .AND. ZVV.EQ.0.D0) THEN
IDIRA = 999
ELSE
DEG = 270.D0 - ATAN2(ZVV,ZUU)*MPC_DEGREES_PER_RADIAN_R8
IF (DEG .GT. 360.D0)DEG = DEG - 360.D0
IF (DEG .LT. 0.D0) DEG = DEG + 360.D0
IDIRA = NINT(DEG)
ENDIF
ILEV = NINT(ZLEV)
IF (ZPOST .GT. ZCUT) THEN
LLELREJ = .TRUE.
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),9))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,IOTHER,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,IOTHER),9))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),17))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,IOTHER,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,IOTHER),17))
IF (ITYP .EQ. BUFR_NEUU .OR.
1 ITYP .EQ. BUFR_NEVV) THEN
ICOUNT(1,JFAM) = ICOUNT(1,JFAM) + 1
ENDIF
IF (ITYP .EQ. BUFR_NEUS .OR. ITYP .EQ. BUFR_NEVS) THEN
ICOUNT(10,JFAM) = ICOUNT(10,JFAM) + 1
ENDIF
WRITE(*,620)
1 obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),IDBURP,CLOBTP(IDBURP),ZLAT,ZLON,
2 ILEV,CLUNITS,IDIRO,ISPDO,IDIRF,ISPDF,IDIRA,
3 ISPDA,ZPOST,obs_headElem_i(lobsSpaceData,OBS_ONM,INDEX_HEADER)
620 FORMAT(A9,1X,i3,1x,A16,F5.1,2X,F5.1,2X,I4,A2,2X,
1 'WND',3X,I3,'/',I3,3X,I3,'/',I3,3X,I3,
2 '/',I3,2X,F6.4,1X,I5)
ENDIF
ENDIF
ELSE
ILEV = NINT(ZLEV)
IF (ZPOST .GT. ZCUT) THEN
LLELREJ = .TRUE.
IF (ITYP .EQ. BUFR_NEGZ) THEN
CLDESC = CLITM(3)
ICOUNT(3,JFAM) = ICOUNT(3,JFAM) + 1
*
*________________CONVERT FROM GEOPOTENTIAL TO GEOPOTENTIAL HEIGHT
*
ZVAR = ZVAR/RG
ZFCST = ZFCST/RG
ZANA = ZANA/RG
ENDIF
IF (ITYP .EQ. BUFR_NETT) THEN
CLDESC = CLITM(4)
ICOUNT(4,JFAM) = ICOUNT(4,JFAM) + 1
*
*________________CONVERT FROM KELVIN TO CELCIUS
*
ZVAR = ZVAR - MPC_K_C_DEGREE_OFFSET_R8
ZFCST = ZFCST - MPC_K_C_DEGREE_OFFSET_R8
ZANA = ZANA - MPC_K_C_DEGREE_OFFSET_R8
ENDIF
IF (ITYP .EQ. BUFR_NEES) THEN
CLDESC = CLITM(5)
ICOUNT(5,JFAM) = ICOUNT(5,JFAM) + 1
ENDIF
IF (ITYP .EQ. BUFR_NEPS) THEN
CLDESC = CLITM(6)
ICOUNT(6,JFAM) = ICOUNT(6,JFAM) + 1
*
*________________CONVERT FROM PASCALS TO MILLIBARS
*
ZVAR = ZVAR*MPC_MBAR_PER_PA_R8
ZANA = ZANA*MPC_MBAR_PER_PA_R8
ZFCST = ZFCST*MPC_MBAR_PER_PA_R8
ENDIF
IF (ITYP .EQ. BUFR_NEPN) THEN
CLDESC = CLITM(7)
ICOUNT(7,JFAM) = ICOUNT(7,JFAM) + 1
*
*________________CONVERT FROM PASCALS TO MILLIBARS
*
ZVAR = ZVAR*MPC_MBAR_PER_PA_R8
ZANA = ZANA*MPC_MBAR_PER_PA_R8
ZFCST = ZFCST*MPC_MBAR_PER_PA_R8
ENDIF
IF (ITYP .EQ. BUFR_NETS) THEN
CLDESC = CLITM(8)
ICOUNT(8,JFAM) = ICOUNT(8,JFAM) + 1
*
*________________CONVERT FROM KELVIN TO CELCIUS
*
ZVAR = ZVAR - MPC_K_C_DEGREE_OFFSET_R8
ZFCST = ZFCST - MPC_K_C_DEGREE_OFFSET_R8
ZANA = ZANA - MPC_K_C_DEGREE_OFFSET_R8
ENDIF
IF (ITYP .EQ. BUFR_NESS) THEN
CLDESC = CLITM(9)
ICOUNT(9,JFAM) = ICOUNT(9,JFAM) + 1
ENDIF
IF ( ITYP.EQ.BUFR_NBT1 .OR. ITYP.EQ.BUFR_NBT2 .OR.
1 ITYP.EQ.BUFR_NBT3 ) THEN
CLDESC = CLITM(12)
ICOUNT(12,JFAM) = ICOUNT(12,JFAM) + 1
ENDIF
IF (ITYP .EQ. BUFR_NEZD) THEN
CLDESC = CLITM(13)
ICOUNT(13,JFAM) = ICOUNT(13,JFAM) + 1
*
*________________CONVERT ZTD FROM METRES TO MILLIMETRES
*
ZVAR = ZVAR * 1000.D0
ZFCST = ZFCST * 1000.D0
ZANA = ZANA * 1000.D0
ENDIF
*
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),9))
call obs_bodySet_i(lobsSpaceData,OBS_FLG,INDEX_BODY,
1 IBSET(obs_bodyElem_i(lobsSpaceData,OBS_FLG,INDEX_BODY),17))
WRITE(*,630) obs_elem_c(lobsSpaceData,'STID',INDEX_HEADER),IDBURP,
1 CLOBTP(IDBURP),ZLAT,ZLON,ILEV,CLUNITS,CLDESC,
2 ZVAR,ZFCST,ZANA,ZPOST,obs_headElem_i(lobsSpaceData,OBS_ONM,INDEX_HEADER)
630 FORMAT(A9,1X,I3,1X,A16,F5.1,2X,F5.1,2X,I4,A2,2X,
2 A4,2X,F7.1,3X,F7.1,3X,F7.1,2X,F6.4,1X,I5,1X)
ENDIF
ENDIF
ENDIF
ENDDO BODY
*
*_________NOW SET THE GLOBAL FLAGS IN THE BURP RECORD HEADER
*
IF (LLELREJ) THEN
call obs_headSet_i(lobsSpaceData,OBS_ST1,INDEX_HEADER, IBSET( obs_headElem_i(lobsSpaceData,OBS_ST1,INDEX_HEADER), 06))
ENDIF
ENDDO HEADER
ENDDO FAMILY
*
*
WRITE(*,640)
640 FORMAT(//)
WRITE(*,665)
665 FORMAT(' REJECTED DATA ACCORDING TO FAMILY OF REPORT.')
WRITE(*,670)(listFamily(JFAM),JFAM=1,numFamily)
670 FORMAT(5X,11(7X,A2))
DO JITEM=1,NUMITEM
IF ( .NOT. (JITEM .EQ. 2 .OR. JITEM .EQ. 11)) THEN
WRITE(*,680)CLITM(JITEM),(ICOUNT(JITEM,JFAM),JFAM=1,numFamily)
680 FORMAT(1X,A4,11(4X,I5))
ENDIF
ENDDO
WRITE(*,640)
*
RETURN
END