C=============================================================================C C International Comprehensive Ocean-Atmosphere Data Set (ICOADS) 26 May 2016 C C Filename:level: trimqc2.f:01D Fortran 77 library C C Purpose: Use QC flags from IMMA Author: S. Worley et al. C C=============================================================================C C Software Revision Information (previous version: 6 Jun 2005, level 01C): C Addition of a relative humidity flag for use with rwimma1. C-----------------------------------------------------------------------3456789 C Software documentation for the (invariant) user-interface routine {trimqc2}: C C Functionality: This routine is called from within {rwimma1} after the call C to {getrpt} (see additional comments below). It uses the trimming and other C QC flags to reject entire reports, or to reject individual data elements C within the reports. Six of the input arguments provide extensive options C for using, or ignoring, the QC flags. Subroutine {trimqc0.f} is required C and also contains documentation for the option settings. Note: longitudes C must conform to the ICOADS convention, or a STOP indicating: C TRIMQC0 ERROR. TRIMMING FLAGS MISSING C will occur in the event of any negative longitudes (NCDC convention). C C External library required: {trimqc0.f}. C Machine dependencies: None known. C For more information: See and (electronic documents). C=============================================================================C C WARNING: Code beyond this point should not require any modification. C C=============================================================================C C-----------------------------------------------------------------------3456789 SUBROUTINE TRIMQC2 (FTRUE,ITRUE,FMISS,IREJECT, * FSST,FAT,FD,FW,FSLP,FWBT,FDPT,FRH, * OPDN,OPPT,OPSE,OPCQ,OPTF,OP11) c-----Apply the trimming and other QC flags to an IMMA data record using C subroutine {trimqc0.f}. Report rejections are tuned using opdn C and oppt; element rejections are tuned using opse, opcq, optf, and C op11. Refer to comments within {trimqc0.f} for details about those C input arguments. Other input arguments: C ftrue and itrue: real and integer arrays from {rwimma1} containing C the IMMA data (elements are used from the core and ICOADS attm). C fmiss: missing value constant, e.g., -9999999. C After application of the QC, (integer) output argument ireject C indicates whether the report was rejected: C ireject: 0 = report accepted C 1 = report rejected (fsst,...,frh set to fmiss) C If ireject=0, the remaining (real) output arguments return any extant C data elements that passed the QC screening: C fsst: The IMMA SST value, i.e., ftrue(sst), if it passed the C QC screening; or fmiss if it failed (or it was missing). C fat: Similarly for AT. C fd: Similarly for D. C fw: Similarly for W. C fslp: Similarly for SLP. C fwbt: Similarly for WBT. C fdpt: Similarly for DPT. C frh: Similarly for RH. C C Additional notes on the operation of {trimqc2}: The call to {gettrf} within C {trimqc2} reformats the trimming and other quality control flags, plus other C required fields, into array TRFLG. This puts the information into a form C compatible with that stored in the trimming section (Attm2) of the LMRF C (LMR) format (the 23 elements of TRFLG are as documented in Table 1 of C ). Then TRFLG is used as input to {trimqc0}. C C Additional notes on the QC flags stored in IMMA: Currently, only the adaptive C QC flags SQZ and SQA (not available from LMRF/LMR) are available, and only C for 1784-1997; AQZ through DQA are always missing. Like in LMR (Attm1), the C NCDC-QC flags are available in a complete form (unlike in LMRF, where only a C subset of that flag information is available from the composite flags). The C six external flags (ZE-RE), and the five source exclusion flags (SZ-RZ), are C decoded by {gettrf} from the encoded variables QCE and QCZ, respectively, and C reformatted for TRFLG. Currently, however, only SZ-RZ are made available as C individual fields, in elements 19-23 of TRFLG; ZE-RE (from the IMMA C documentation, Table C1) are not made available as individual fields. IMPLICIT INTEGER(A-E,G-Z) C CORE PARAMETER(YR=1,MO=2,DY=3,HR=4,LAT=5,LON=6,IM=7,ATTC=8,TI=9,LI=10 +,DS=11,VS=12,NID=13,II=14,ID=15,C1=16,DI=17,D=18,WI=19,W=20,VI=21 +,VV=22,WW=23,W1=24,SLP=25,A=26,PPP=27,IT=28,AT=29,WBTI=30,WBT=31 +,DPTI=32,DPT=33,SI=34,SST=35,N=36,NH=37,CL=38,HI=39,H=40,CM=41 +,CH=42,WD=43,WP=44,WH=45,SD=46,SP=47,SH=48) C C ICOADS ATTACHMENT PARAMETER(ATTI1=49,ATTL1=50,BSI=51,B10=52,B1=53,DCK=54,SID=55 +,PT=56,DUPS=57,DUPC=58,TC=59,PB=60,WX=61,SX=62,C2=63,SQZ=64,SQA=65 +,AQZ=66,AQA=67,UQZ=68,UQA=69,VQZ=70,VQA=71,PQZ=72,PQA=73,DQZ=74 +,DQA=75,ND=76,SF=77,AF=78,UF=79,VF=80,PF=81,RF=82,ZNC=83,WNC=84 +,BNC=85,XNC=86,YNC=87,PNC=88,ANC=89,GNC=90,DNC=91,SNC=92,CNC=93 +,ENC=94,FNC=95,TNC=96,QCE=97,LZ=98,QCZ=99) C C IMMT-5/FM13 ATTACHMENT PARAMETER(RH=161) DIMENSION FTRUE(*),ITRUE(*) INTEGER IYR,IDCK,ISID,IPT,IDUPS,MISS,TRFLG(23),ZZQF,SZQF,AZQF,WZQF * ,PZQF,RZQF,OPDN,OPPT,OPSE,OPCQ,OPTF,OP11 IYR = NINT(FTRUE(YR)) IDCK = NINT(FTRUE(DCK)) ISID = NINT(FTRUE(SID)) IPT = NINT(FTRUE(PT)) IDUPS = NINT(FTRUE(DUPS)) MISS = NINT(FMISS) C GET TRIMMING AND OTHER QUALITY CONTROL FLAGS CALL GETTRF(ITRUE,ITRUE(ZNC),NINT(FMISS),NINT(FMISS) +,LAT,LON,D,W,B10,ND,SF,AF,UF,VF,PF,RF,QCE,LZ,QCZ,TRFLG) FSST = FMISS FAT = FMISS FD = FMISS FW = FMISS FSLP = FMISS FWBT = FMISS FDPT = FMISS FRH = FMISS CALL TRIMQC0(IYR,IDCK,ISID,IPT,IDUPS,MISS,TRFLG, * ZZQF,SZQF,AZQF,WZQF,PZQF,RZQF, * OPDN,OPPT,OPSE,OPCQ,OPTF,OP11) IREJECT=0 !RECORD REJECTION IF(ZZQF.EQ.1)THEN IREJECT = 1 RETURN ENDIF FSST = FTRUE(SST) ! SST FLAG AND QC APPLICATION IF(SZQF.EQ.1)FSST= FMISS FAT = FTRUE(AT) ! AT FLAG AND QC APPLICATION IF(AZQF.EQ.1)FAT = FMISS FD = FTRUE(D) ! WIND, D AND W FLAG AND QC APPLICATION FW = FTRUE(W) IF(WZQF.EQ.1)THEN FD = FMISS FW = FMISS ENDIF FSLP = FTRUE(SLP) ! SLP FLAG AND QC APPLICATION IF(PZQF.EQ.1)FSLP= FMISS FWBT = FTRUE(WBT) ! WBT, DPT AND RH FLAG AND QC APPLICATION FDPT = FTRUE(DPT) FRH = FTRUE(RH) IF(RZQF.EQ.1)THEN FWBT = FMISS FDPT = FMISS FRH = FMISS ENDIF RETURN END C-----------------------------------------------------------------------3456789 SUBROUTINE GETTRF(ITRUE,QCFLG,MISS,ERR +,LAT,LON,D,W,B10,ND,SF,AF,UF,VF,PF,RF,QCE,LZ,QCZ,TRFLG) C GET TRIMMING FLAGS IMPLICIT INTEGER(A-E,G-Z) PARAMETER(ZNC=1,WNC=2,BNC=3,XNC=4,YNC=5,PNC=6,ANC=7,GNC=8,DNC=9 +,SNC=10,CNC=11,ENC=12,FNC=13,TNC=14) DIMENSION ITRUE(*),QCFLG(14),TRFLG(23) LOGICAL B2QXY C DO 190 I=1,23 TRFLG(I)=0 190 CONTINUE IF (ITRUE(LAT).NE.MISS .AND. ITRUE(LAT).NE.ERR .AND. + ITRUE(LON).NE.MISS .AND. ITRUE(LON).NE.ERR .AND. + ITRUE(B10).NE.MISS .AND. ITRUE(B10).NE.ERR) THEN IF (B2QXY(QB10(ITRUE(B10)),ITRUE(LON),ITRUE(LAT),B2)) + TRFLG( 1)=B2 ENDIF IF (ITRUE(ND).NE.MISS) THEN TRFLG( 2)=ITRUE(ND) ENDIF IF (ITRUE(SF).NE.MISS) THEN TRFLG( 3)=ITRUE(SF) TRFLG( 4)=ITRUE(AF) TRFLG( 5)=ITRUE(UF) TRFLG( 6)=ITRUE(VF) TRFLG( 7)=ITRUE(PF) TRFLG( 8)=ITRUE(RF) ENDIF IF (QCFLG(ZNC).NE.MISS) THEN IF (QCFLG(ZNC).GE.7 .AND. QCFLG(ZNC).NE.10) TRFLG( 9)=1 IF (QCFLG(SNC).GE.8 .AND. QCFLG(SNC).NE.10) TRFLG(10)=1 IF (QCFLG(ANC).GE.8 .AND. QCFLG(ANC).NE.10) TRFLG(11)=1 IF (ITRUE(D).GE.1 .AND. ITRUE(D).LE.360 .AND. ITRUE(W).EQ.0 + .AND. QCFLG(WNC).EQ. 7) TRFLG(12)=1 IF (QCFLG(PNC).GE.8 .AND. QCFLG(PNC).NE.10) TRFLG(13)=1 IF (QCFLG(GNC).GE.8 .AND. QCFLG(GNC).NE.10) TRFLG(14)=1 IF (QCFLG(DNC).GE.8 .AND. QCFLG(DNC).NE.10) TRFLG(14)=1 IF (QCFLG(XNC).GE.2 .AND. QCFLG(XNC).NE.10) TRFLG(15)=1 IF (QCFLG(XNC).GE.4 .AND. QCFLG(XNC).NE.10) TRFLG(15)=2 IF (QCFLG(XNC).GE.7 .AND. QCFLG(XNC).NE.10) TRFLG(15)=3 IF (QCFLG(CNC).GE.2 .AND. QCFLG(CNC).NE.10) TRFLG(16)=1 IF (QCFLG(CNC).GE.4 .AND. QCFLG(CNC).NE.10) TRFLG(16)=2 IF (QCFLG(CNC).GE.7 .AND. QCFLG(CNC).NE.10) TRFLG(16)=3 IF (QCFLG(ENC).GE.2 .AND. QCFLG(ENC).NE.10) TRFLG(17)=1 IF (QCFLG(ENC).GE.4 .AND. QCFLG(ENC).NE.10) TRFLG(17)=2 IF (QCFLG(ENC).GE.7 .AND. QCFLG(ENC).NE.10) TRFLG(17)=3 ENDIF IF (ITRUE(QCE).NE.MISS) THEN TRFLG( 9)=TRFLG( 9)+2*MOD(ITRUE(QCE)/2/2/2/2/2,2) TRFLG(10)=TRFLG(10)+2*MOD(ITRUE(QCE)/2/2/2/2,2) TRFLG(11)=TRFLG(11)+2*MOD(ITRUE(QCE)/2/2/2,2) TRFLG(12)=TRFLG(12)+2*MOD(ITRUE(QCE)/2/2,2) TRFLG(13)=TRFLG(13)+2*MOD(ITRUE(QCE)/2,2) TRFLG(14)=TRFLG(14)+2*MOD(ITRUE(QCE),2) ENDIF IF (ITRUE(LZ).NE.MISS) THEN TRFLG(18)=ITRUE(LZ) ENDIF IF (ITRUE(QCZ).NE.MISS) THEN TRFLG(19)=MOD(ITRUE(QCZ)/2/2/2/2,2) TRFLG(20)=MOD(ITRUE(QCZ)/2/2/2,2) TRFLG(21)=MOD(ITRUE(QCZ)/2/2,2) TRFLG(22)=MOD(ITRUE(QCZ)/2,2) TRFLG(23)=MOD(ITRUE(QCZ),2) ENDIF END C$QB10------------------------------------------------------------------3456789 FUNCTION QB10(B10) IMPLICIT INTEGER(A-E,G-Z) QB10=-1 IF(B10.LT.1.OR.B10.GT.648)RETURN QB10=2+(B10-1)/324*2-MOD(B10-1+3,36)/18 END C$B2QXY-----------------------------------------------------------------3456789 LOGICAL FUNCTION B2QXY(Q,X,Y,B2) IMPLICIT INTEGER(A-E,G-Z) C B2QXY=.FALSE. IF(Q.LT.1.OR.Q.GT.4.OR.X.LT.0.OR.X.GT.35999.OR.ABS(Y).GT.9000) +RETURN C IF(ABS(Y).LT.9000)THEN IF(MOD(Q,2).EQ.0)THEN C=MIN(X/200,89) ELSE C=179-MIN(MOD(36000-X,36000)/200,89) ENDIF IF(Q/3.EQ.0)THEN R=89-(9000+Y)/200 ELSE R=(9000-Y)/200 ENDIF B2=2+R*180+C C ELSE IF(Y.EQ.9000)THEN B2=1 C ELSE B2=16202 ENDIF C B2QXY=.TRUE. END