!-------------------------------------- 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 1
#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(ncmomn,*) as zpost value
* S. Macpherson (ARMA/MRD) Sep 2009
* - List GP family (GPS) rejects (idtyp 189)
************************************************************************
#endif
*
IMPLICIT NONE
#include "comlun.cdk"
#include "cvcord.cdk"
#include "comdimo.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
#include "comcst.cdk"
#include "comvfiles.cdk"
#include "comnumbr.cdk"
#include "comstate.cdk"
#include "comphy.cdk"
*
*IMPLICITS:
INTEGER JPMAXTYP,JPMXITM
PARAMETER (JPMAXTYP=254, JPMXITM=13)
CHARACTER *16 CLOBTP(JPMAXTYP)
INTEGER ICOUNT(JPMXITM,JPFILES)
*
*
INTEGER IDATA,J,JJ,JJJ,JREP
INTEGER ITY,JDATA,IDATEND,ITYP,ISTYP
INTEGER ISPDO,IDIRO,ISPDF,IDIRF,ISPDA,IDIRA,ILEV
INTEGER IDBURP,IOTHER,IBEGIN,IBEGINOB,ILAST,ILASTOB
REAL*8 ZVAR,ZFCST,ZOER,ZANA,ZPOST,ZTODEG,ZLAT,ZLON,ZUU,ZVV
REAL*8 SPD,DEG,ZLEV,ZSLEV,ZCUT
CHARACTER *4 CLITM(JPMXITM),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(254)
1 / 'GB-GPS', 'SCATTEROMETER'/
*
ZTODEG = 180./RPI
*
DO J=1,NKOUNT
DO JJJ=1,JPMXITM
ICOUNT(JJJ,J) = 0
ENDDO
ENDDO
WRITE(NULOUT,610)
610 FORMAT(//'LIST OF DATA REJECTED BY VARIATIONAL QUALITY CONTROL')
*
*_____LOOP OVER ALL REPORTS, ONE FAMILY AT A TIME
*
DO J = 1,NFILES
IF (.NOT. (CFAMTYP(J) .EQ. 'HU'
1 .OR. CFAMTYP(J) .EQ. 'GO')) THEN
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
IF (IBEGIN .GT. 0) THEN
IBEGINOB = MOBDATA(NCMOBS,IBEGIN)
ILASTOB = MOBDATA(NCMOBS,ILAST)
WRITE(NULOUT,600)
600 FORMAT(1X)
IF (CFAMTYP(J) .NE. 'TO') THEN
WRITE(NULOUT,601)
ELSE
WRITE(NULOUT,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')
*
DO 10 JREP = IBEGINOB, ILASTOB
LLELREJ = .FALSE.
IDATA = MOBHDR(NCMRLN,JREP)
IDATEND = MOBHDR(NCMNLV,JREP) + IDATA -1
ITY = MOBHDR(NCMITY,JREP)
IDBURP = MOD(ITY,1000)
ZLAT = ROBHDR(NCMLAT,JREP)*ZTODEG
ZLON = ROBHDR(NCMLON,JREP)*ZTODEG
DO JDATA=IDATA, IDATEND
ITYP = MOBDATA(NCMVNM,JDATA)
IF (ITYP .EQ. NETS .OR. ITYP .EQ. NEPS .OR.
1 ITYP .EQ. NEPN .OR. ITYP .EQ. NESS .OR.
2 ITYP .EQ. NEUS .OR. ITYP .EQ. NEVS .OR.
3 ITYP .EQ. NEZD) THEN
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1)
ELSE
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1 .AND.
1 MOBDATA(NCMXTR,JDATA) .EQ. 0) .OR.
2 (MOBDATA(NCMXTR,JDATA) .EQ. 2 .AND.
3 MOBDATA(NCMVNM,JDATA) .EQ. NVNUMB(3))
ENDIF
IF (LLOK) THEN
zpost = ROBDATA8(NCMOMN,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)*RPATMB
IF (MOBDATA(NCMVCO,JDATA) .EQ. 2) THEN
ZLEV = ROBDATA8(NCMPPP,JDATA)*RPATMB
CLUNITS = 'MB'
ENDIF
IF (MOBDATA(NCMVCO,JDATA) .EQ. 1) THEN
*
*___________________VERTICAL COORDINATE IS HEIGHT
*
ZLEV = ROBDATA8(NCMPPP,JDATA)
CLUNITS = ' M'
ENDIF
IF (MOBDATA(NCMVCO,JDATA) .EQ. -1) THEN
*
*___________________TOVS CHANNEL NUMBER
*
ZLEV = ROBDATA8(NCMPPP,JDATA)
CLUNITS = ' '
ENDIF
ZVAR = ROBDATA8(NCMVAR,JDATA)
ZOER = ROBDATA8(NCMOER,JDATA)
ZFCST = ROBDATA8(NCMOMF,JDATA)*ZOER + ZVAR
ZANA = ROBDATA8(NCMOMA,JDATA)*ZOER + ZVAR
*
*_______________TREAT WINDS AS SPECIAL CASE
* NVNUMB( 1) = 011003 (U COMPONENT) (m/s)
* NVNUMB( 2) = 011004 (V COMPONENT) (m/s)
* NEUS = 011215 (U COMPONENT AT 10 M) (m/s)
* NEVS = 011216 (V COMPONENT AT 10 M) (m/s)
*
IF (((ITYP.EQ.NVNUMB(1) .OR. ITYP .EQ. NEUS) .AND.
1 NMVOEXIST(NOUU).EQ.1).OR.
2 ((ITYP.EQ.NVNUMB(2) .OR. ITYP .EQ. NEVS) .AND.
3 NMVOEXIST(NOVV).EQ.1)) THEN
IOTHER = -1
IF (ITYP .EQ. NVNUMB(1) .OR. ITYP .EQ. NEUS) THEN
DO JJ=IDATA,JDATA
ISTYP = MOBDATA(NCMVNM,JJ)
IF (MOBDATA(NCMVCO,JJ) .EQ. 2) THEN
ZSLEV = ROBDATA8(NCMPPP,JJ)*RPATMB
ENDIF
IF (MOBDATA(NCMVCO,JJ) .EQ. 1) THEN
ZSLEV = ROBDATA8(NCMPPP,JJ)
ENDIF
IF ((ISTYP .EQ. NVNUMB(2) .OR. ISTYP .EQ. NEVS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = JJ
ENDIF
ENDDO
ELSE
DO JJ=IDATA,JDATA
ISTYP = MOBDATA(NCMVNM,JJ)
IF (MOBDATA(NCMVCO,JJ) .EQ. 2) THEN
ZSLEV = ROBDATA8(NCMPPP,JJ)*RPATMB
ENDIF
IF (MOBDATA(NCMVCO,JJ) .EQ. 1) THEN
ZSLEV = ROBDATA8(NCMPPP,JJ)
ENDIF
IF ((ISTYP .EQ. NVNUMB(1) .OR. ISTYP .EQ. NEUS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = JJ
ENDIF
ENDDO
ENDIF
IF (IOTHER .NE. -1) THEN
IF (ITYP .EQ. NVNUMB(1) .OR. ITYP .EQ. NEUS) THEN
ZUU = ZVAR
ZVV = ROBDATA8(NCMVAR,IOTHER)
ELSE
ZVV = ZVAR
ZUU = ROBDATA8(NCMVAR,IOTHER)
ENDIF
SPD = SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDO = NINT(SPD)
IF (ZUU.EQ.0. .AND. ZVV.EQ.0.)THEN
IDIRO = 999
ELSE
DEG = 270. - ATAN2(ZVV,ZUU)*ZTODEG
IF (DEG .GT. 360.)DEG = DEG - 360.
IF (DEG .LT. 0.) DEG = DEG + 360.
IDIRO = NINT(DEG)
ENDIF
IF (ITYP .EQ. NVNUMB(1) .OR. ITYP .EQ. NEUS) THEN
ZUU = ZFCST
ZVV = ROBDATA8(NCMOMF,IOTHER)*ZOER
1 + ROBDATA8(NCMVAR,IOTHER)
ELSE
ZVV = ZFCST
ZUU = ROBDATA8(NCMOMF,IOTHER)*ZOER
1 + ROBDATA8(NCMVAR,IOTHER)
ENDIF
SPD=SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDF = NINT(SPD)
IF (ZUU .EQ. 0. .AND. ZVV .EQ. 0.) THEN
IDIRF = 999
ELSE
DEG = 270. - ATAN2(ZVV,ZUU)*ZTODEG
IF (DEG .GT. 360.)DEG = DEG - 360.
IF (DEG .LT. 0.) DEG = DEG + 360.
IDIRF = NINT(DEG)
ENDIF
IF (ITYP .EQ. NVNUMB(1) .OR. ITYP .EQ. NEUS) THEN
ZUU = ZANA
ZVV = ROBDATA8(NCMOMA,IOTHER)*ZOER
1 + ROBDATA8(NCMVAR,IOTHER)
ELSE
ZVV = ZANA
ZUU = ROBDATA8(NCMOMA,IOTHER)*ZOER
1 + ROBDATA8(NCMVAR,IOTHER)
ENDIF
SPD=SQRT(ZUU*ZUU + ZVV*ZVV)
ISPDA = NINT(SPD)
IF (ZUU.EQ.0. .AND. ZVV.EQ.0.) THEN
IDIRA = 999
ELSE
DEG = 270. - ATAN2(ZVV,ZUU)*ZTODEG
IF (DEG .GT. 360.)DEG = DEG - 360.
IF (DEG .LT. 0.) DEG = DEG + 360.
IDIRA = NINT(DEG)
ENDIF
ILEV = NINT(ZLEV)
IF (ZPOST .GT. ZCUT) THEN
LLELREJ = .TRUE.
MOBDATA(NCMFLG,JDATA) =
1 IBSET(MOBDATA(NCMFLG,JDATA),9)
MOBDATA(NCMFLG,IOTHER) =
1 IBSET(MOBDATA(NCMFLG,IOTHER),9)
MOBDATA(NCMFLG,JDATA) =
1 IBSET(MOBDATA(NCMFLG,JDATA),17)
MOBDATA(NCMFLG,IOTHER) =
1 IBSET(MOBDATA(NCMFLG,IOTHER),17)
IF (ITYP .EQ. NVNUMB(1) .OR.
1 ITYP .EQ. NVNUMB(2)) THEN
ICOUNT(1,J) = ICOUNT(1,J) + 1
ENDIF
IF (ITYP .EQ. NEUS .OR. ITYP .EQ. NEVS) THEN
ICOUNT(10,J) = ICOUNT(10,J) + 1
ENDIF
WRITE(NULOUT,620)
1 CSTNID(JREP),IDBURP,CLOBTP(IDBURP),ZLAT,ZLON,
2 ILEV,CLUNITS,IDIRO,ISPDO,IDIRF,ISPDF,IDIRA,
3 ISPDA,ZPOST,MOBHDR(NCMONM,JREP)
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. NVNUMB(3)) THEN
CLDESC = CLITM(3)
ICOUNT(3,J) = ICOUNT(3,J) + 1
*
*___________________CONVERT FROM GEOPOTENTIAL TO GEOPOTENTIAL HEIGHT
*
ZVAR = ZVAR/RG
ZFCST = ZFCST/RG
ZANA = ZANA/RG
ENDIF
IF (ITYP .EQ. NVNUMB(8)) THEN
CLDESC = CLITM(4)
ICOUNT(4,J) = ICOUNT(4,J) + 1
*
*___________________CONVERT FROM KELVIN TO CELCIUS
*
ZVAR = ZVAR - TCDK
ZFCST = ZFCST - TCDK
ZANA = ZANA - TCDK
ENDIF
IF (ITYP .EQ. NVNUMB(9)) THEN
CLDESC = CLITM(5)
ICOUNT(5,J) = ICOUNT(5,J) + 1
ENDIF
IF (ITYP .EQ. NEPS) THEN
CLDESC = CLITM(6)
ICOUNT(6,J) = ICOUNT(6,J) + 1
*
*___________________CONVERT FROM PASCALS TO MILLIBARS
*
ZVAR = ZVAR*RPATMB
ZANA = ZANA*RPATMB
ZFCST = ZFCST*RPATMB
ENDIF
IF (ITYP .EQ. NEPN) THEN
CLDESC = CLITM(7)
ICOUNT(7,J) = ICOUNT(7,J) + 1
*
*___________________CONVERT FROM PASCALS TO MILLIBARS
*
ZVAR = ZVAR*RPATMB
ZANA = ZANA*RPATMB
ZFCST = ZFCST*RPATMB
ENDIF
IF (ITYP .EQ. NETS) THEN
CLDESC = CLITM(8)
ICOUNT(8,J) = ICOUNT(8,J) + 1
*
*___________________CONVERT FROM KELVIN TO CELCIUS
*
ZVAR = ZVAR - TCDK
ZFCST = ZFCST - TCDK
ZANA = ZANA - TCDK
ENDIF
IF (ITYP .EQ. NESS) THEN
CLDESC = CLITM(9)
ICOUNT(9,J) = ICOUNT(9,J) + 1
ENDIF
IF ( ITYP.EQ.NBT1 .OR. ITYP.EQ.NBT2 .OR.
1 ITYP.EQ.NBT3 ) THEN
CLDESC = CLITM(12)
ICOUNT(12,J) = ICOUNT(12,J) + 1
ENDIF
IF (ITYP .EQ. NEZD) THEN
CLDESC = CLITM(13)
ICOUNT(13,J) = ICOUNT(13,J) + 1
*
*___________________CONVERT ZTD FROM METRES TO MILLIMETRES
*
ZVAR = ZVAR * 1000.
ZFCST = ZFCST * 1000.
ZANA = ZANA * 1000.
ENDIF
*
MOBDATA(NCMFLG,JDATA) =
1 IBSET(MOBDATA(NCMFLG,JDATA),9)
MOBDATA(NCMFLG,JDATA) =
1 IBSET(MOBDATA(NCMFLG,JDATA),17)
WRITE(NULOUT,630) CSTNID(JREP),IDBURP,
1 CLOBTP(IDBURP),ZLAT,ZLON,ILEV,CLUNITS,CLDESC,
2 ZVAR,ZFCST,ZANA,ZPOST,MOBHDR(NCMONM,JREP)
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
*
*_________NOW SET THE GLOBAL FLAGS IN THE BURP RECORD HEADER
*
IF (LLELREJ) THEN
MOBHDR(NCMST1,JREP)= IBSET( MOBHDR(NCMST1,JREP) , 06)
ENDIF
10 CONTINUE
ENDIF
ENDIF
ENDDO
*
*
WRITE(NULOUT,640)
640 FORMAT(//)
WRITE(NULOUT,665)
665 FORMAT(' REJECTED DATA ACCORDING TO FAMILY OF REPORT.')
WRITE(NULOUT,670)(CFAMTYP(J),J=1,NKOUNT)
670 FORMAT(5X,11(7X,A2))
DO J=1,JPMXITM
IF ( .NOT. (J .EQ. 2 .OR. J .EQ. 11)) THEN
WRITE(NULOUT,680)CLITM(J),(ICOUNT(J,JJJ),JJJ=1,NKOUNT)
680 FORMAT(1X,A4,11(4X,I5))
ENDIF
ENDDO
WRITE(NULOUT,640)
*
RETURN
END