C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C . . . . C MAIN PROGRAM: CQCHHTMP CQC OF RAWINSONDE HEIGHTS & TEMPERATURES C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 95-02-17 C C ABSTRACT: PERFORM COMPLEX QUALITY CONTROL OF RAWINSONDE HEIGHTS C AND TEMPERATURES. ERRORS ARE DETECTED AND MANY CORRECTED. C CHECKS USED: HYDROSTATIC, INCREMENT, HORIZONTAL STATISTICAL, C VERTICAL STATISTICAL, (TEMPORAL,) AND BASELINE. C C PROGRAM HISTORY LOG: C 95-02-17 W. COLLINS C 95-02-17 W. COLLINS THIS IS THE FIRST CRAY VERSION. IT'S C ALGORITHMS ARE THE SAME AS IN THE HDS C VERSION. C 95-05-08 W. COLLINS CHANGE ARRAY DIMENSIONS IN SIGNIFICANT LEVEL C CHECKING TO ALLOW FOR 895 LEVELS. C 04-05-01 W EBISUZAKI CHANGED /DATE/ TO /DATEC/ TO AVOID DUAL DEFINITIONS C F90? C COMMENTED OUT SUBROUTINE ADDATE AS DEFINED IN C BUFRLIBRARY C 12-11-10 W EBISUZAKI C UNCOMMENTED OUT SUBROUTINE ADDATE AS NOLONGER C CHANGED SOME A() = CONSTANT F90 SYNTAX C REMOVE OUT-OF-BOUNDS ERROR MESSAGES C C USAGE: C INPUT FILES: C NOTE! FILES FORT.12, FORT.13 AND FORT.15 ARE NOT USED C OPERATIONALLY. THEY READ AND WRITE TO THE SAME C UNITS, ACCUMULATING EVENTS FOR SUMMARY AFTER A C PERIOD OF TIME. ALSO, THE TEMPORAL CHECK IS NOT C RUN OPERATIONALLY, BUT IS USED FOR THE REANALYSIS. C C (FORT.12 - EVENTS FILE FOR MANDATORY LEVELS) C (FORT.13 - EVENTS FILE FOR SIGNIFICANT LEVELS) C FORT.14 - PREPDATA FILE (BUFR), DATA INPUT C (FORT.15 - BLOCK TOTALS FILE) C (FORT.17 - T-24, USED ONLY FOR TEMPORAL CHECK) C (FORT.18 - T-12, USED ONLY FOR TEMPORAL CHECK) C (FORT.19 - T+12, USED ONLY FOR TEMPORAL CHECK) C (FORT.20 - T+24, USED ONLY FOR TEMPORAL CHECK) C C OUTPUT FILES: C C (FORT.12 - EVENTS FILE FOR MANDATORY LEVELS) C (FORT.13 - EVENTS FILE FOR SIGNIFICANT LEVELS) C (FORT.15 - BLOCK TOTALS FILE) C FORT.51 - OUTPUT FILE OF DATA (BUFR) AFTER CORRECTION C FORT.60 - PRINT FILE FOR MANDATORY AND SIGNIFICANT LEVELS C FORT.61 - PRINT FILE: SPA OUTPUT C FORT.62 - PRINT FILE OF EVENTS FILE C FORT.64 - PRINT FILE OF DETAILS OF DECISIONS C C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) C LIBRARY: C W3LIB - W3FS13, W3FS21, W3FS03, W3FS15, W3FS21 C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C C ATTRIBUTES: C LANGUAGE: FORTRAN77, CRAY EXTENSIONS C MACHINE: CRAY C C$$$ PROGRAM CQCHT C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C INITIALIZE FOR THIS RUN C ----------------------- C-MK CALL W3LOG('$S','$M') CALL PARAM C READ THE DATA AND THE FIRST GUESS C --------------------------------- CALL INPUT C READ ANY DATA FOR THE TEMPORAL CHECK C ------------------------------------ CALL INPUTS C CQC SCANS FOR MANDATORY LEVELS C ------------------------------ DO 10 ISCAN=1,2 CALL HSC CALL BASLIN CALL INCR CALL HOI CALL HOIPS CALL VOI CALL TCHK CALL DMA CALL DETAIL CALL NEWVAL 10 CONTINUE C WRITE THE EVENTS FILE AND STATISTICS C ------------------------------------ CALL PEVENT CALL PRISO CALL STAT C SIG LEVEL CHECKS AND PERHAPS REWRITE THE INPUT FILE C --------------------------------------------------- IF(IGES.EQ.0) CALL DMA22 IF(IGES.EQ.1) CALL DMA20 C-MK CALL W3LOG('$E') STOP END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C COMMENTED OUT WNE 5-2004 .. IN BUFR LIBRARY C . . . . C SUBPROGRAM: ADDATE ADD DATES. C PRGMMR: J. WOOLLEN ORG: W/NMC20 DATE: 94-MM-DD C C ABSTRACT: ADD DATES. C C PROGRAM HISTORY LOG: C 94-MM-DD J. WOOLLEN C C USAGE: CALL ADDATE(IDATE,JH,JDATE) C INPUT ARGUMENT LIST: C IDATE - INPUT DATE C JH - INCREMENT IN HOURS C C OUTPUT ARGUMENT LIST: C JDATE - OUTPUT DATE C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: CRAY C C$$$ SUBROUTINE ADDATE(IDATE,JH,JDATE) C DIMENSION MON(12) C DATA MON/31,28,31,30,31,30,31,31,30,31,30,31/ C C----------------------------------------------------------------------- C----------------------------------------------------------------------- C IY = MOD(IDATE/1000000,100) IM = MOD(IDATE/10000 ,100) ID = MOD(IDATE/100 ,100) IH = MOD(IDATE ,100) C MON(2) = 28 IF(MOD(IY,4).EQ.0) MON(2) = 29 IF(MOD(IY,100).EQ.0) MON(2) = 28 IF(MOD(IY,400).EQ.0) MON(2) = 29 C IH = IH+JH C IF(IH.LT.0) THEN IH = IH+24 ID = ID-1 IF(ID.EQ.0) THEN IM = IM-1 IF(IM.EQ.0) THEN IM = 12 IY = IY-1 IF(IY.LT.0) IY = 99 ENDIF ID = MON(IM) ENDIF ELSEIF(IH.GE.24) THEN IH = IH-24 ID = ID+1 IF(ID.GT.MON(IM)) THEN ID = 1 IM = IM+1 IF(IM.GT.12) THEN IM = 1 IY = MOD(IY+1,100) ENDIF ENDIF ENDIF C JDATE = IY*1E6 + IM*1E4 + ID*1E2 + IH C RETURN END SUBROUTINE BASLIN C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: BASLIN PERFORM BASELINE CHECK C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM BASELINE CHECK. USE TWO LOWEST AVAILABLE HEIGHTS C AND THE DICTIONARY STATION ELEVATION. COMPUTE VALUES OF QUANTITIES C THAT WOULD LEAD TO NO BASELINE ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL BASLIN C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,1001), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,1001), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) DATA B /-.0065/, RBOG /.19026/ C C COMPUTE STATION HEIGHT FROM LOWEST HEIGHT AND TEMPERATURE C ABOVE THE GROUND. ASSUME A C CONSTANT LAPSE RATE OF -6.5 DEGREES/KILOMETER. C C CONSTANTS: C B - LAPSE RATE: -6.5 DEGREES/KILOMETER C RBOG = - GAS CONST * B / GRAVITY C = 287.04 * .0065 / 9.8062 C GORB = 1./RBOG DO 100 N=1,NOBS C C SET QUANTITIES INITIALLY TO MISSING. C BRES(N) = VMSG(1) PSCOR(N) = VMSG(1) Z1COR(N) = VMSG(1) Z2COR(N) = VMSG(1) PSL(N) = VMSG(1) REDUC(N) = 1.0 MAND = MAN(N) IF(ABS(PS(N)).GT.VMAX(2).OR.PS(N).EQ.0.) GO TO 100 C C FIND LOWEST LEVEL OF HEIGHT DATA. C LEV1(N) = 1 DO 10 L=1,MAND P1 = OBS(L,3,N) Z1 = OBS(L,1,N) LEV1(N) = L IF(ABS(Z1).GT.VMAX(1)) THEN GO TO 10 ELSE GO TO 12 ENDIF 10 CONTINUE C C NO LEVELS FOUND. C GO TO 100 12 CONTINUE C C FIND SECOND LEVEL OF HEIGHT DATA, C WITH NO MORE THAN ONE MISSING LEVEL. C LP = LEV1(N) + 1 DO 14 L=LP,MAND P2 = OBS(L,3,N) Z2 = OBS(L,1,N) LEV2(N) = L IF(ABS(Z2).GT.VMAX(1).OR.(LEV2(N)-LEV1(N)).GT.2) THEN GO TO 14 ELSE GO TO 16 ENDIF 14 CONTINUE C C NO SECOND LEVEL FOUND. C GO TO 100 16 CONTINUE C C CHECK TO MAKE SURE THAT EITHER: C 1) THE HT LEVELS STRADDLE THE GND HT, OR C 2) THE LEVEL 1 IS THE 1ST ABOVE GND LVL. C DO 20 L=1,MAND LL = L PLVL = OBS(L,3,N) IF(PLVL.LT.PS(N)) GO TO 22 20 CONTINUE 22 CONTINUE C C LL IS THE FIRST LEVEL ABOVE THE GROUND. C IF(LL-LEV1(N).LT.0.OR.LL-LEV1(N).GT.2 & .OR.Z1-SELV(N).GT.1000.) GOTO 100 C C MAKE SURE THAT Z1.NE.Z2. C IF(Z1.GE.Z2) GOTO 100 C C CALCULATE ALL QUANTITIES. C IF(PS(N).GT.0..AND.P1.GT.0..AND.P2.GT.0.) THEN ZLAY = 0.5*(Z1+Z2) ALAY = (P2/P1)**RBOG AL = (PS(N)/P1)**RBOG TLAY = -.5 * B * (Z2-Z1) * (1.+ALAY)/(1.-ALAY) ZSC = Z1 + ((AL-1.)/B)*(TLAY + B*(Z1-ZLAY)) BRES(N) = SELV(N) - ZSC ELSE BRES(N) = 0. ENDIF IF(Z1.LT.Z2) THEN PSC = P1*(1.+B*(SELV(N)-Z1)/(TLAY + B*(Z1-ZLAY)))**GORB ELSE PSC = P1 ENDIF PSCOR(N) = PSC - PS(N) IF(AL.NE.1.) THEN Z2C = Z1 + ((ALAY-1.)/(AL-1.))*(SELV(N)-Z1) ELSE Z2C = Z2 ENDIF Z2COR(N) = Z2C - Z2 GAMA = -0.5*B*(1.+ALAY)/(1.-ALAY) IF(ALAY .NE. AL) THEN Z1C = ((ALAY-1.)*SELV(N) - (AL-1.)*Z2)/(ALAY-AL) ELSE ZIC = VMSG(1) ENDIF IF(ABS(Z1).LT.VMAX(1).AND.Z1C.LT.VMAX(1)) THEN Z1COR(N) = Z1C - Z1 ELSE Z1COR(N) = VMSG(1) ENDIF C C CALCULATE SEA-LEVEL PRESSURE. C T0 = TLAY - B*ZLAY RED = 1.0 + B*SELV(N)/T0 IF(RED.GT.0.) REDUC(N) = RED**(-GORB) PSL(N) = PS(N) * REDUC(N) IF(PSL(N).EQ.0.) PSL(N) = VMSG(1) C C SET BASELINE FLAGS. C IF(ABS(BRES(N)).GT.VMAX(1)) THEN IBAS = 0 ELSE IBAS = 2.0 * ABS(BRES(N))/BASRES ENDIF IBAS = MIN(IBAS,2) DO 30 L=1,NLEV DO 29 IV=1,2 CALL UNPACK(NERR(L,IV,N,ISCAN),IHSC,IINC,IHOI, & IVOI,IB,IIPL,IHPL) CALL PACK(NERR(L,IV,N,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) 29 CONTINUE 30 CONTINUE 100 CONTINUE RETURN END C********************************************************* SUBROUTINE BASLN1(IS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: BASLIN1 PERFORM BASELINE CHECK FOR CHANGED DATA. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM BASELINE CHECK. USE TWO LOWEST AVAILABLE HEIGHTS C AND THE DICTIONARY STATION ELEVATION. COMPUTE VALUES OF QUANTITIES C THAT WOULD LEAD TO NO BASELINE ERROR. THIS VERSION IS FOR C CORRECTED DATA AND COMPUTES ONLY LIMITED QUANTITIES, INCLUDING THE C BASELINE RESIDUAL. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL BASLIN1(IS) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) DATA B /-.0065/, RBOG /.19026/ C C COMPUTE STATION HEIGHT FROM LOWEST HEIGHT AND TEMPERATURE C ABOVE THE GROUND. ASSUME A C CONSTANT LAPSE RATE OF -6.5 DEGREES/KILOMETER. C C CONSTANTS: C B - LAPSE RATE: -6.5 DEGREES/KILOMETER C RBOG = - GAS CONST * B / GRAVITY C = 287.04 * .0065 / 9.8062 C GORB = 1./RBOG CBRES = VMSG(1) CPSCOR = VMSG(1) CZ1COR = VMSG(1) CZ2COR = VMSG(1) IF(LZ3.EQ.99.OR.L2.EQ.99 & .OR.(LZ3-L2).GT.1.OR.L2.NE.LEV1(IS)) RETURN Z1 = OBS(L2,1,IS) P1 = OBS(L2,3,IS) Z2 = OBS(LZ3,1,IS) P2 = OBS(LZ3,3,IS) MAND = MAN(IS) C C CALCULATE ALL QUANTITIES. C IF(PS(IS).NE.0.) THEN ZLAY = 0.5*(Z1+Z2) ALAY = (P2/P1)**RBOG AL = (PS(IS)/P1)**RBOG TLAY = -.5 * B * (Z2-Z1) * (1.+ALAY)/(1.-ALAY) ZSC = Z1 + ((AL-1.)/B)*(TLAY + B*(Z1-ZLAY)) CBRES = ZSC - SELV(IS) ELSE CBRES = 0. ENDIF IF(Z1.LT.Z2) THEN CPSC = P1*(1.+B*(SELV(IS)-Z1)/(TLAY + B*(Z1-ZLAY)))**GORB ELSE CPSC = VMSG(1) ENDIF IF(AL.NE.1.) THEN CZ2C = Z1 + ((ALAY-1.)/(AL-1.))*(SELV(IS)-Z1) ELSE CZ2C = Z2 ENDIF GAMA = -0.5*B*(1.+ALAY)/(1.-ALAY) CZ1C = ((ALAY-1.) * SELV(IS) - (AL-1.) * Z2) / (ALAY-AL) RETURN END C----------------------------------------------------------------------- C BLOCK DATA C----------------------------------------------------------------------- BLOCK DATA COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /BOXES/ NWIDTH(7,36) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN COMMON /SLIMS/ RLIMM(21), RLIMS(21) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(100,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,1001), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /LEV926/ ISET,MANLIN(1001) DATA ISET/0/ DATA NLEV /21/, NPLVL /21/, NSLVL /75/ DATA NZ /5/, NZL /31/, NT /51/, AA /0.3/ DATA ALLZ /0.,-10.,10.,-20.,20./ DATA ALLZL /0.,-1.,1.,-2.,2.,-3.,3.,-4.,4.,-5.,5., & -6.,6.,-7.,7.,-8.,8.,-9.,9.,-10.,10.,-11., & 11.,-12.,12.,-13.,13.,-14.,14.,-15.,15./ DATA IR /0/ DATA DTALL /3.5/, E2 /0.5/, CCON /0.7/ DATA ECON1 /0.25/, ECON2 /0.20/ DATA NFIN /14/, NFOUT /51/, NFTMP /17,18,19,20/ DATA R /287.05/, G /9.80665/, T0 /273.15/ DATA RLIMM /65.,35.,50.,35.,40.,35.,40.,50.,85.,70.,70., & 80.,70.,100.,100.,100.,5*0./ DATA RLIMS /40.,30.,40.,35.,40.,35.,35.,40.,55.,60.,55., & 65.,65.,85.,85.,85.,5*0./ DATA SS /40.,35.,50.,35.,40.,35.,40.,50.,85.,70.,70., & 80.,70.,100.,100.,100.,100.,100.,100.,100./ DATA HSCRES /65.,65.,35.,50.,35.,40.,35.,40.,50.,85., & 70.,70.,80.,70.,100.,84*100./ DATA XINC /160.,120.,120.,130.,160.,180.,190., & 210.,210.,210.,210.,210.,210.,210.,210.,210., & 210.,210.,210.,210.,210.,17.,17.,13.,11., & 11.,12.,13.,15.,17.,17.,17.,17.,17.,17.,17.,17., & 17.,17.,17.,17.,17./ DATA HOIRES /120.,90.,90.,130.,150.,180.,190.,210.,210., & 210.,210.,210.,210.,210.,210.,210., & 210.,210.,210.,210.,210.,17.,15.,13.,10.,11.,12., & 12.,12.,11.,14.,15.,17.,17.,17.,17.,17., & 17.,17.,17.,17.,17./ DATA VOIRES /120.,70.,60.,70.,80.,90.,90.,90.,120., & 180.,210.,210.,210.,210.,210.,210.,210.,210.,210., & 210.,210.,17.,17.,14.,11.,11.,11.,12., & 15.,16.,17.,17.,17.,17.,17.,17.,17., & 17.,17.,17.,17.,17./ C CRAY USES SECOND DATA STATEMENT C DATA TMPSTD /60.,60.,65.,75.,100.,110.,120.,125.,130., C & 140.,155.,170.,190.,215.,240.,240.,240.,240.,240., C & 240.,240., C & 9.0,8.1,6.9,6.6,7.2,7.5,7.8,8.1,8.4,8.7,9.0, C & 9.3,9.6,9.8,10.2,10.2,10.2,10.2,10.2,10.2,10.2/ DATA TMPSTD /120.,120.,130.,150.,200.,220.,240.,250.,260., & 280.,310.,340.,380.,430.,480.,480.,480.,480., & 480.,480.,480., & 9.0,8.1,6.9,6.6,7.2,7.5,7.8,8.1,8.4,8.7,9.0, & 9.3,9.6,9.8,10.2,10.2,10.2,10.2,10.2,10.2,10.2/ DATA TFACT /2.0,2.0,2.0,1.8,1.6,1.6,1.6,1.6, & 1.5,1.3,1.0,0.9,0.8,0.8,0.8,0.8, & 0.8,0.8,0.8,0.8,0.8, & 1.0,1.0,1.4,1.5,1.5,1.5,1.4,1.3,1.3, & 1.2,1.2,1.1,1.0,0.9,0.9,0.9, & 0.9,0.9,0.9,0.9,0.9/ DATA ZCLIM1 /30./, ZCLIM2 /85./, TCLIM /10./ DATA ZCMIN /8.0/, TCMIN /5./ DATA BASRES /40./, PSRES /8./ DATA VMAX /90000.,9000./, VMSG /99999.,9999.9/ DATA IPLVL/1000,925,850,700,500,400,300,250,200, & 150,100,70,50,30,20,10,7,5,3,2,1/ DATA PMAND /1000.,925.,850.,700.,500.,400.,300.,250.,200., & 150.,100.,70.,50.,30.,20.,10.,7.,5.,3.,2.,1./ END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CHDIST C PRGMMR: WOOLLEN ORG: NMC22 DATE: 90-11-06 C C ABSTRACT: C COMPUTES CHORD LENGTH DISTANCE FROM A FIXED C POINT TO AN ARRAY OF POINTS USING THE FORMULA: C S**2/2 = 1 - COS(Y1-Y2) + COS(Y1)*COS(Y2)*(1-COS(X1-X2)). C ALSO THE DIRECTION OF EACH POINT IS COMPUTED WITH RESPECT TO C THE FIXED POINT AND RETURNED AS WELL. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN C C USAGE: C INPUT ARGUMENTS: C X1 - X-COORDINATE (LONGITUDE) OF FIXED POINT C Y1 - Y-COORDINATE (LATITUDE ) OF FIXED POINT C X2 - X-COORDINATES (LONGITUDE) FOR SET OF POINTS C Y2 - Y-COORDINATES (LATITUDE ) FOR SET OF POINTS C NP - NUMBER OF OUTPUTS REQUESTED C C OUTPUT ARGUMENTS: C DIST - CHORD LENGTH DISTANCES FROM FIXED POINT (KM) C DIRN - DIRECTION FROM FIXED POINT (DEG) C C SUBPROGRAMS CALLED: NONE C C EXIT STATES: NONE C C REMARKS: C C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE CHDIST(X1,Y1,X2,Y2,DIST,DIRN,NP) DIMENSION X2(NP),Y2(NP),DIST(NP),DIRN(NP) DATA PI180/.0174532 /,RADE/6371./ C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NP.EQ.0) RETURN C COMPUTE THE DISTANCE C -------------------- DO 10 I=1,NP COSY1 = COS(Y1*PI180) COSY2 = COS(Y2(I)*PI180) COSDX = COS((X1-X2(I))*PI180) COSDY = COS((Y1-Y2(I))*PI180) S = 1.0-COSDY+COSY1*COSY2*(1.0-COSDX) S = SQRT(2.*S) IF(S.LE..002) S = 0. DIST(I) = S*RADE 10 CONTINUE C COMPUTE DIRECTIONS C ------------------ DO 20 I=1,NP DX = (X2(I)-X1)*COS(Y1) DY = (Y2(I)-Y1) IF(DX.GT.0.) THEN DIRN(I) = 0. + ATAN(DY/DX)/PI180 ELSE IF(DX.LT.0.) THEN DIRN(I) = 180. + ATAN(DY/DX)/PI180 ELSE IF(DX.EQ.0.) THEN DIRN(I) = SIGN(90.,DY) ENDIF IF(DIRN(I).LT.0.) DIRN(I) = DIRN(I) + 360. 20 CONTINUE C DO 30 I=1,NP C30 PRINT*,DIST(I),DIRN(I) RETURN END C********************************************************* SUBROUTINE CHTCHK(A,B,C,R,ICK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CHTCHK CHECK TEMPORAL CHECK FOR BAD INFLUENCE C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 92-05-26 C C ABSTRACT: CHECK TEMPORAL CHECK FOR THE INFLUENCE OF BAD DATA. C C PROGRAM HISTORY LOG: C 92-05-26 W. COLLINS C C USAGE: CALL CHTCHK(A, B, C, R, ICK) C INPUT ARGUMENT LIST: C A - VALUE AT T-12 OR T-24 HOURS C B - VALUE AT T+00 HOURS C C - VALUE AT T+12 OR T+24 HOURS C R - TEMPORAL RESIDUAL C C OUTPUT ARGUMENT LIST: C ICK - INDICATOR OF INFLUENCE OF BAD DATA: C = 0 INFLUENCING STATIONS OK C = 1 INFLUENCING STATION QUENSTIONABLE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ R1 = ABS(A-B) R2 = ABS(B-C) IF((R1.LT.1.0*R).OR.(R2.LT.1.0*R)) THEN ICK = 1 ELSE ICK = 0 ENDIF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COORS C PRGMMR: WOOLLEN ORG: NMC22 DATE: 90-11-06 C C ABSTRACT: COMPUTES CHORD LENGTH DISTANCE FOR A MATRIX OF C LOCATIONS <(X,Y)I,(X,Y)J> USING THE NORMAL ANGLE FORMULA: C S**2/2 = 1 - COS(Y1-Y2) + COS(Y1)*COS(Y2)*(1-COS(X1-X2)) C DERIVATIVES OF DISTANCE WITH RESPECT TO LAT AND LON ARE ALSO C COMPUTED AND COMBINED WITH APPROPRIATE CORRELATION FUNCTIONS C AND DERIVATIVES WITH RESPECT TO DISTANCE TO FORM THE MULTI- C VARIATE CORRELATIONS FOR THE HEIGHT WIND ANALYSIS. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN C C USAGE: C INPUT ARGUMENTS: C NP - NUMBER OF OUTPUTS REQUESTED C CHTWV - VECTOR OF CONSTANTS FOR THE GAUSSIAN LENGTH SCALE C X1 - X-COORDINATES (LONGITUDE) FOR 1ST SET OF POINTS C Y1 - Y-COORDINATES (LATITUDE ) FOR 1ST SET OF POINTS C X2 - X-COORDINATES (LONGITUDE) FOR 2ND SET OF POINTS C Y2 - Y-COORDINATES (LATITUDE ) FOR 2ND SET OF POINTS C C OUTPUT ARGUMENTS: C D - DISTANCES BETWEEN ARRAYS OF POINTS IN RADIANS C ZZ - CORRELATION BETWEEN HEIGHT AND HEIGHT C ZU - CORRELATION BETWEEN HEIGHT AND UWIND C ZV - CORRELATION BETWEEN HEIGHT AND VWIND C UZ - CORRELATION BETWEEN UWIND AND HEIGHT C UU - CORRELATION BETWEEN UWIND AND UWIND C UV - CORRELATION BETWEEN UWIND AND VWIND C VZ - CORRELATION BETWEEN VWIND AND HEIGHT C VU - CORRELATION BETWEEN VWIND AND UWIND C VV - CORRELATION BETWEEN VWIND AND VWIND C C SUBPROGRAMS CALLED: NONE C C EXIT STATES: NONE C C REMARKS: THIS PROGRAM COMPUTES A GAUSSIAN CORRELATION WITH C LENGTH SCALE GIVEN BY THE CHTWV INPUT ARGUMENT. C C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE COORS(NP,CHTWV,X1,Y1,X2,Y2,D,ZZ) DIMENSION CHTWV(NP),X1(NP),Y1(NP),X2(NP),Y2(NP) DIMENSION D(NP),ZZ(NP) DATA PI180 /.0174532 / C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NP.EQ.0) RETURN C LOOP OVER SET OF INPUT POINTS C ----------------------------- DO 20 I=1,NP C COMPUTE THE MATRIX OF SINES AND COSINES C --------------------------------------- COSY1 = COS(Y1(I)*PI180) COSY2 = COS(Y2(I)*PI180) COSDX = COS((X1(I)-X2(I))*PI180) COSDY = COS((Y1(I)-Y2(I))*PI180) C COMPUTE THE NORMAL ANGLE C ------------------------ S = 1.0-COSDY+COSY1*COSY2*(1.0-COSDX) S = SQRT(2.*S) C COMPUTE THE VARIOUS CORRELATIONS C -------------------------------- ZZ(I) = EXP(-CHTWV(I)*S*S) D(I) = S 20 CONTINUE RETURN END C************************************************************* SUBROUTINE CORCT2(Z,T,ZCOR,TCOR,ZC,TC,MAND,IS,ICTYP,IER) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CORCT2 MAKE HYDROSTATIC CORRECTIONS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: SUBROUTINE CORECT HAS ALREADY DETERMINED HYDROSTATIC C CORRECTION TYPES. THIS SUBROUTINE USES THOSE TYPES TO MAKE THE C CORRECTIONS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-28 W. COLLINS USES NEW EVENTS FILE. C 92-05-07 W. COLLINS SUBSTANTIAL CHANGES FOR NEW FLAGS C 92-05-11 W. COLLINS ADD TEMPORAL CHECK. C C USAGE: CALL CORCT2(Z, T, ZCOR, TCOR, ZC, TC, MAND, IS, ICTYP) C INPUT ARGUMENT LIST: C Z - HEIGHT (METERS) C T - TEMPERATURE (CELCIUS) C MAND - NO. OF MANDATORY LEVELS C IS - STATION INDEX C ICTYP - HYDROSTATIC CORRECTION TYPE C C OUTPUT ARGUMENT LIST: C ZCOR - HEIGHT CORRECTIONS (METERS) C TCOR - TEMPERATURE CORRECTIONS (DEGREES) C ZC - CORRECTED HEIGHTS(METERS) C TC - CORRECTED TEMPERATURES (CELCIUS) C IER - NON-ZERO FOR TOO MANY CORRECTIONS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C HYDROSTATIC CORRECTIONS HAVE ALREADY BEEN SUGGESTED. C THIS SUBROUTINE CHECKS THOSE SUGGESTIONS AND MAKES C CORRECTIONS. THE BASELINE CORRECTIONS ARE ASSUMED TO BE C HANDLED SEPARATELY, PRIOR TO CALLING THIS ROUTINE. C C Z,T - ORIGINAL VALUES C ZC,TC - HYDROSTATICALLY CORRECTED VALUES C ZCOR,TCOR - HYDROSTATIC CORRECTIONS C INTEGER ICTYP(21), KK(3,3) REAL Z(99), ZCOR(21), ZC(21), T(99), TCOR(21), TC(21) CHARACTER*4 CDATE CHARACTER*8 NEVNTC CHARACTER*8 NV1C, NV2C C-CRA COMMON /DATEC/ CDATE(2), IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE(2) COMMON /DATEI/ IYR, IMO, IDY, IHR CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,1001), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON /CORCT/ SI(20,3), ICTYPI(21,3), C-CRA& ZI(21,3), TI(21,3), ZCORI(21,3), TCORI(21,3), C-CRA& LL1(21,3), LL2(21,3), LL3(21,3), LL4(21,3) COMMON /CORCT/ SI(20,3), & ZI(21,3), TI(21,3), ZCORI(21,3), TCORI(21,3) COMMON /CORCTI/ ICTYPI(21,3), & LL1(21,3), LL2(21,3), LL3(21,3), LL4(21,3) COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL C INTEGER*8 NEVNTI,NV1,NV2 EQUIVALENCE (NEVNTI, NEVNTC) EQUIVALENCE (NV1,NV1C), (NV2,NV2C) C C KK IS USED TO COMMUNICATE THE VARIABLE DECISIONS C KK(TEMPLATE LEVEL, VARIABLE) C TEMPLATE LEVEL (1-3) FOR L1, L2, L3 C VARIABLE (1-3) FOR Z, T, PS C VARIABLE DECISIONS: C 1 - CORRECTION C 2 - NO CORRECTION, ORIGINAL VALUE PROBABLY OK C 3 - NO CORRECTION, ORIGINAL VALUE LIKELY BAD C 4 - NO CORRECTION, ORIGINAL VALUE BAD C MANDM = MAND - 1 NPLVLM = NPLVL - 1 HOUR = DHR(IS) LBZ = 99 LBT = 99 LBB = 99 C C FIND LOWEST LEVELS WITH Z, T, BOTH. C DO 5 L=1,MAND IF(LBZ.EQ.99.AND.OBS(L,1,IS).LT.VMAX(1)) LBZ = L IF(LBT.EQ.99.AND.OBS(L,2,IS).LT.VMAX(2)) LBT = L IF(LBB.EQ.99.AND.OBS(L,1,IS).LT.VMAX(1) & .AND.OBS(L,2,IS).LT.VMAX(2)) LBB = L 5 CONTINUE C C GET IBAS. C CALL UNPACK(NERR(1,1,IS,ISCAN),IHSC,IINC,IHOI, & IVOI,IBAS,IIPL,IHPL) IBSL = IBAS C C CHECK DATA FROM BOTTOM OF PROFILE UPWARD. C DO 100 L=1,MAND L2 = L C C GET INDICES FOR TEMPLATE. C CALL FINDL(LZ1,L2,LZ3,LZ4,Z,1,MAND) CALL FINDH(LH1,L2,LH3,LH4,Z,T,MAND) LH0 = LH1 - 1 IF(LH0.LE.0) LH0 = 1 IF(LH1.EQ.99) LH0 = 99 LZ1 = LH1 LZ3 = LH3 LZ4 = LH4 IF(LZ1.NE.99.AND.ABS(Z(LZ1)).LT.VMAX(1)) THEN OINCZ(1) = OINC(LZ1,1,IS) HRESZ(1) = HINC(LZ1,1,IS) VRESZ(1) = VINC(LZ1,1,IS) TRESZ(1) = TRES(LZ1,1,IS) ELSE OINCZ(1) = VMSG(1) HRESZ(1) = VMSG(1) VRESZ(1) = VMSG(1) TRESZ(1) = VMSG(1) ENDIF IF(L2.NE.99.AND.ABS(Z(L2)).LT.VMAX(1)) THEN OINCZ(2) = OINC(L2,1,IS) HRESZ(2) = HINC(L2,1,IS) VRESZ(2) = VINC(L2,1,IS) TRESZ(2) = TRES(L2,1,IS) ELSE OINCZ(2) = VMSG(1) HRESZ(2) = VMSG(1) VRESZ(2) = VMSG(1) TRESZ(2) = VMSG(1) ENDIF IF(LZ3.NE.99.AND.ABS(Z(LZ3)).LT.VMAX(1)) THEN OINCZ(3) = OINC(LZ3,1,IS) HRESZ(3) = HINC(LZ3,1,IS) VRESZ(3) = VINC(LZ3,1,IS) TRESZ(3) = TRES(LZ3,1,IS) ELSE OINCZ(3) = VMSG(1) HRESZ(3) = VMSG(1) VRESZ(3) = VMSG(1) TRESZ(3) = VMSG(1) ENDIF IF(LZ4.NE.99.AND.ABS(Z(LZ4)).LT.VMAX(1)) THEN OINCZ(4) = OINC(LZ4,1,IS) HRESZ(4) = HINC(LZ4,1,IS) VRESZ(4) = VINC(LZ4,1,IS) TRESZ(4) = TRES(LZ4,1,IS) ELSE OINCZ(4) = VMSG(1) HRESZ(4) = VMSG(1) VRESZ(4) = VMSG(1) TRESZ(4) = VMSG(1) ENDIF CALL FINDL(LT1,L2,LT3,LT4,T,2,MAND) LT1 = LH1 LT3 = LH3 LT4 = LH4 IF(LT1.NE.99.AND.ABS(T(LT1)).LT.VMAX(1)) THEN OINCT(1) = OINC(LT1,2,IS) HREST(1) = HINC(LT1,2,IS) VREST(1) = VINC(LT1,2,IS) TREST(1) = TRES(LT1,2,IS) ELSE OINCT(1) = VMSG(1) HREST(1) = VMSG(1) VREST(1) = VMSG(1) TREST(1) = VMSG(1) ENDIF IF(L2.NE.99.AND.ABS(T(L2)).LT.VMAX(1)) THEN OINCT(2) = OINC(L2,2,IS) HREST(2) = HINC(L2,2,IS) VREST(2) = VINC(L2,2,IS) TREST(2) = TRES(L2,2,IS) ELSE OINCT(2) = VMSG(1) HREST(2) = VMSG(1) VREST(2) = VMSG(1) TREST(2) = VMSG(1) ENDIF IF(LT3.NE.99.AND.ABS(T(LT3)).LT.VMAX(1)) THEN OINCT(3) = OINC(LT3,2,IS) HREST(3) = HINC(LT3,2,IS) VREST(3) = VINC(LT3,2,IS) TREST(3) = TRES(LT3,2,IS) ELSE OINCT(3) = VMSG(1) HREST(3) = VMSG(1) VREST(3) = VMSG(1) TREST(3) = VMSG(1) ENDIF IF(LT4.NE.99.AND.ABS(T(LT4)).LT.VMAX(1)) THEN OINCT(4) = OINC(LT4,2,IS) HREST(4) = HINC(LT4,2,IS) VREST(4) = VINC(LT4,2,IS) TREST(4) = TRES(LT4,2,IS) ELSE OINCT(4) = VMSG(1) HREST(4) = VMSG(1) VREST(4) = VMSG(1) TREST(4) = VMSG(1) ENDIF C C GET VERTICAL DIFFERENCES OF OINCZ, HRESZ, TRESZ AND TREST. C CALL VDIF(DOZ2,OINCZ(1),OINCZ(2),OINCZ(3), & LZ1,L2,LZ3,VMAX(1),VMSG(1)) CALL VDIF(DOZ3,OINCZ(2),OINCZ(3),OINCZ(4), & L2,LZ3,LZ4,VMAX(1),VMSG(1)) CALL VDIF(DHZ2,HRESZ(1),HRESZ(2),HRESZ(3), & LZ1,L2,LZ3,VMAX(1),VMSG(1)) CALL VDIF(DHZ3,HRESZ(2),HRESZ(3),HRESZ(4), & L2,LZ3,LZ4,VMAX(1),VMSG(1)) CALL VDIF(DOT2,OINCT(1),OINCT(2),OINCT(3), & LT1,L2,LT3,VMAX(2),VMSG(2)) CALL VDIF(DOT3,OINCT(2),OINCT(3),OINCT(4), & L2,LT3,LT4,VMAX(2),VMSG(2)) CALL VDIF(DHT2,HREST(1),HREST(2),HREST(3), & LT1,L2,LT3,VMAX(2),VMSG(2)) CALL VDIF(DHT3,HREST(2),HREST(3),HREST(4), & L2,LT3,LT4,VMAX(2),VMSG(2)) CALL VDIF(DTZ2,TRESZ(1),TRESZ(2),TRESZ(3), & LZ1,L2,LZ3,VMAX(1),VMSG(1)) CALL VDIF(DTZ3,TRESZ(2),TRESZ(3),TRESZ(4), & L2,LZ3,LZ4,VMAX(2),VMSG(2)) CALL VDIF(DTT2,TREST(1),TREST(2),TREST(3), & LT1,L2,LT3,VMAX(1),VMSG(1)) CALL VDIF(DTT3,TREST(2),TREST(3),TREST(4), & L2,LT3,LT4,VMAX(2),VMSG(2)) C C GET LEVELS FOR HYDROSTATIC CHECK. C C CALL FINDH(LH1,L2,LH3,LH4,Z,T,MAND) C C PUT VARIABLES INTO LOCAL ARRAYS. C IF(LH1.EQ.99) GO TO 701 IF(ABS(Z(LH1)).LT.VMAX(1) & .AND.ABS(T(LH1)).LT.VMAX(2)) THEN ZH(1) = OBS(LH1,1,IS) TH(1) = OBS(LH1,2,IS) ICH1 = ICTYP(LH1) HYS0 = HYRES(LH1,IS) ELSE ZH(1) = VMSG(1) TH(1) = VMSG(2) ICH1 = 99 HYS0 = VMSG(1) ENDIF 701 CONTINUE IF(L2.EQ.99) GO TO 702 IF(ABS(Z(L2)).LT.VMAX(1) & .AND.ABS(T(L2)).LT.VMAX(2)) THEN ZH(2) = OBS(L2,1,IS) TH(2) = OBS(L2,2,IS) ICH2 = ICTYP(L2) HYS(1) = HYRES(L2,IS) ELSE ZH(2) = VMSG(1) TH(2) = VMSG(2) ICH2 = 99 HYS(1) = VMSG(1) ENDIF 702 CONTINUE IF(LH3.EQ.99) GO TO 703 IF(ABS(Z(LH3)).LT.VMAX(1) & .AND.ABS(T(LH3)).LT.VMAX(2)) THEN ZH(3) = OBS(LH3,1,IS) TH(3) = OBS(LH3,2,IS) ICH3 = ICTYP(LH3) HYS(2) = HYRES(LH3,IS) ELSE ZH(3) = VMSG(1) TH(3) = VMSG(2) ICH3 = 99 HYS(2) = VMSG(1) ENDIF 703 CONTINUE IF(LH4.EQ.99) GO TO 704 IF(ABS(Z(LH4)).LT.VMAX(1) & .AND.ABS(T(LH4)).LT.VMAX(2)) THEN ZH(4) = OBS(LH4,1,IS) TH(4) = OBS(LH4,2,IS) ICH4 = ICTYP(LH4) HYS(3) = HYRES(LH4,IS) ELSE ZH(4) = VMSG(1) TH(4) = VMSG(2) ICH4 = 99 HYS(3) = VMSG(1) ENDIF 704 CONTINUE BB(1) = VMSG(1) BB(2) = VMSG(1) BB(3) = VMSG(1) DO 10 K=1,NPLVLM I = ISU(K,IS) IF(I.EQ.L2) THEN BB(1) = BSUM(K,IS) ELSEIF(I.EQ.LH3) THEN BB(2) = BSUM(K,IS) ELSEIF(I.EQ.LH4) THEN BB(3) = BSUM(K,IS) ENDIF 10 CONTINUE C C SURFACE PRESSURE. C PSCC = PS(IS) PSCORR = 0. C C COMPLETE FILLING OF LOCAL ARRAYS. C IF(LZ1.NE.99) THEN ZZ(1) = Z(LZ1) ZZCOR(1) = ZCOR(LZ1) ZZC(1) = ZC(LZ1) ICZ1 = ICTYP(LZ1) ELSE ZZ(1) = VMSG(1) ZZCOR(1) = VMSG(1) ZZC(1) = VMSG(1) ICZ1 = 99 ENDIF IF(L2.NE.99) THEN ZZ(2) = Z(L2) ZZCOR(2) = ZCOR(L2) ZZC(2) = ZC(L2) IC2 = ICTYP(L2) ELSE ZZ(2) = VMSG(1) ZZCOR(2) = VMSG(1) ZZC(2) = VMSG(1) IC2 = 99 ENDIF IF(LZ3.NE.99) THEN ZZ(3) = Z(LZ3) ZZCOR(3) = ZCOR(LZ3) ZZC(3) = ZC(LZ3) ICZ3 = ICTYP(LZ3) ELSE ZZ(3) = VMSG(1) ZZCOR(3) = VMSG(1) ZZC(3) = VMSG(1) ICZ3 = 99 ENDIF IF(LZ4.NE.99) THEN ZZ(4) = Z(LZ4) ZZCOR(4) = ZCOR(LZ4) ZZC(4) = ZC(LZ4) ICZ4 = ICTYP(LZ4) ELSE ZZ(4) = VMSG(1) ZZCOR(4) = VMSG(1) ZZC(4) = VMSG(1) ICZ4 = 99 ENDIF IF(LT1.NE.99) THEN TT(1) = T(LT1) TTCOR(1) = TCOR(LT1) TTC(1) = TC(LT1) ICT1 = ICTYP(LT1) ELSE TT(1) = VMSG(2) TTCOR(1) = VMSG(2) TTC(1) = VMSG(2) ICT1 = 99 ENDIF IF(L2.NE.99) THEN TT(2) = T(L2) TTCOR(2) = TCOR(L2) TTC(2) = TC(L2) ELSE TT(2) = VMSG(2) TTCOR(2) = VMSG(2) TTC(2) = VMSG(2) ENDIF IF(LT3.NE.99) THEN TT(3) = T(LT3) TTCOR(3) = TCOR(LT3) TTC(3) = TC(LT3) ICT3 = ICTYP(LT3) ELSE TT(3) = VMSG(2) TTCOR(3) = VMSG(2) TTC(3) = VMSG(2) ICT3 = 99 ENDIF IF(LT4.NE.99) THEN TT(4) = T(LT4) TTCOR(4) = TCOR(LT4) TTC(4) = TC(LT4) ICT4 = ICTYP(LT4) ELSE TT(4) = VMSG(2) TTCOR(4) = VMSG(2) TTC(4) = VMSG(2) ICT4 = 99 ENDIF C C SET TO MISSING ARRAYS OF /TCOR/. C CALL MTCOR C C SEE IF THERE ARE ANY HYDROSTATIC CORRECTIONS, I.E. C TYPES 1,2,7-10. C C SET IV2, IV3 TO ZERO. THEY WILL BE SET IN TYPE SUBROUTINES C TO 1 FOR Z C 2 FOR T C 3 FOR Z AND T C 4 FOR PS C 5 FOR ZS C IV2 = 0 IV3 = 0 C C SET KK TO ZERO. THEY WILL BE SET IN TYPE SUBROUTINES C TO 1 FOR CORRECTION, C 2 FOR NO CORRECTION, ORIGINAL VALUE PROBABLY GOOD, C 3 FOR NO CORRECTION, ORIGINAL VALUE LIKELY BAD, C 4 FOR NO CORRECTION, ORIGINAL VALUE BAD. C DO J=1,3 DO I=1,3 KK(I,J) = 0 ENDDO ENDDO C C CHECK FOR BASELINE ERRORS AT LOWEST LEVELS. C BASELINE DIAGNOSIS: C 100 - CORRECT PS C 101 - CORRECT Z1 C 102 - NO CORR C 106 - CORRECT PS, ALL Z-S C 116 - CORRECT ALL Z-S C IF(L2.EQ.LBZ) THEN CALL TYPEB(IS,KK,IV2,IV3,IHSC) C C CORRECT PS FOR TYPES 100 AND 106. C IF(PSCORR.LT.VMAX(1).AND.PSCORR.NE.0.) THEN PSCC = PSCC + PSCORR ENDIF C C CORRECT ALL Z-S FOR TYPES 106 AND 116. C IF(IHSC.EQ.106.OR.IHSC.EQ.116) THEN DO 40 I=L2,MAND IF(ZC(I).GT.VMAX(1)) GO TO 40 ZC(I) = ZC(I) + ZZCOR(2) ZCOR(I) = ZCOR(I) + ZZCOR(2) C C WRITE EVENT FILE ENTRIES FOR ALL LEVELS CHANGED. C IR = IR + 1 IF(IR.GT.899) GO TO 110 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,1 777 FORMAT(' CORCT2--STN ID:',3(A8,2X),' IS:I',3I5) NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) NEVNT(6,IR) = ((1*100+I)*100+ISCAN)*100+1 IF(I.NE.L2) THEN NEVNT(8,IR) = Z(I) NEVNT(9,IR) = T(I)*10. NEVNT(10,IR) = ZC(I) NEVNT(11,IR) = OINC(I,1,IS) NEVNT(16,IR) = HINC(I,1,IS) NEVNT(17,IR) = VINC(I,1,IS) NEVNT(12,IR) = HYRES(I,IS) NEVNT(14,IR) = VMSG(1) IF(I.LT.NPLVL) THEN NEVNT(13,IR) = HYRES(I+1,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(15,IR) = VMSG(1) ELSE NEVNT(8,IR) = SELV(IS) NEVNT(9,IR) = Z(I) NEVNT(10,IR) = ZC(I) NEVNT(11,IR) = BRES(IS) NEVNT(12,IR) = CBRES NEVNT(13,IR) = PSL(IS)*10. NEVNT(14,IR) = OINCPS(IS)*10. NEVNT(15,IR) = HINCPS(IS)*10. NEVNT(7,IR) = NERR(I,1,IS,ISCAN) LB1 = LEV1(IS) LB2 = LEV2(IS) NEVNT(16,IR) = OINC(LB1,1,IS) NEVNT(17,IR) = OINC(LB2,1,IS) ENDIF NEVNT(18,IR) = NERT(I,1,IS,ISCAN) NEVNT(19,IR) = TRES(I,1,IS) NEVNT(20,IR) = TRES(I,1,IS) + ZZCOR(2) 40 CONTINUE ZZCOR(2) = 0. IF(IHSC.EQ.106) GO TO 50 GO TO 100 C C CORRECT Z(L2) FOR TYPE 101. C ELSEIF(IHSC.EQ.101.AND.ZC(L2).LT.VMAX(1)) THEN ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) GO TO 50 ELSEIF(IHSC.EQ.100.OR.IHSC.EQ.102) THEN GO TO 50 ENDIF ENDIF C C CHECK FOR TYPE 1 ERROR. C IF(IC2.EQ.1.OR.(IC2.EQ.11.AND.L2.LT.NLEV)) THEN CALL TYPE1(IS,KK(2,1)) IV2 = 1 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. C C CHECK FOR TYPE 2 ERROR. C ELSEIF(IC2.EQ.2.OR.(IC2.EQ.22.AND.L2.LT.NLEV)) THEN CALL TYPE2(IS,KK(2,2)) IV2 = 2 TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. C C CHECK FOR TYPE 7 ERROR. C ELSEIF(IC2.EQ.7.AND.ICZ1.NE.7) THEN ZZC(2) = ZZ(2) + ZZCOR(2) ZZC(3) = ZZ(3) + ZZCOR(3) CALL TYPE7(IS,KK(2,1),KK(3,1)) IV2 = 1 IV3 = 1 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. IF(LZ3.NE.99) THEN ZC(LZ3) = ZC(LZ3) + ZZCOR(3) ZCOR(LZ3) = ZCOR(LZ3) + ZZCOR(3) ZZCOR(3) = 0. ELSE ZZCOR(2) = 0. ENDIF C C CHECK FOR TYPE 8 ERROR. C ELSEIF(IC2.EQ.8.AND.ICT1.NE.8) THEN TTC(2) = TT(2) + TTCOR(2) TTC(3) = TT(3) + TTCOR(3) CALL TYPE8(IS,KK(2,2),KK(3,2)) IV2 = 2 IV3 = 2 TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. IF(LT3.NE.99) THEN TC(LT3) = TC(LT3) + TTCOR(3) TCOR(LT3) = TCOR(LT3) + TTCOR(3) TTCOR(3) = 0. ELSE TTCOR(3) = 0. ENDIF C C CHECK FOR TYPE 9 ERROR. C ELSEIF((IC2.EQ.9..OR.IC2.EQ.19.OR.IC2.EQ.29) & .AND..NOT.(ICZ1.EQ.9.OR.ICZ1.EQ.19.OR.ICZ1.EQ.29)) THEN ZZC(2) = ZZ(2) + ZZCOR(2) TTC(3) = TT(3) + TTCOR(3) CALL TYPE9(IS,KK(2,1),KK(3,2)) IV2 = 1 IV3 = 2 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. IF(LT3.NE.99) THEN TC(LT3) = TC(LT3) + TTCOR(3) TCOR(LT3) = TCOR(LT3) + TTCOR(3) TTCOR(3) = 0. ELSE TTCOR(3) = 0. ENDIF C C CHECK FOR TYPE 10 ERROR. C ELSEIF((IC2.EQ.10.OR.IC2.EQ.20) & .AND..NOT.(ICT1.EQ.10.OR.ICT1.EQ.20)) THEN TTC(2) = TT(2) + TTCOR(2) ZZC(3) = ZZ(3) + ZZCOR(3) CALL TYPE10(IS,KK(2,2),KK(3,1)) IV2 = 2 IV3 = 1 TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. IF(LZ3.NE.99) THEN ZC(LZ3) = ZC(LZ3) + ZZCOR(3) ZCOR(LZ3) = ZCOR(LZ3) + ZZCOR(3) ZZCOR(3) = 0. ELSE ZZCOR(2) = 0. ENDIF C C CHECK FOR TYPE 78 ERRORS. C ELSEIF(IC2.EQ.78.AND.ICZ1.NE.78.AND.ICT1.NE.78) THEN ZZC(2) = ZZ(2) + ZZCOR(2) ZZC(3) = ZZ(3) + ZZCOR(3) TTC(2) = TT(2) + TTCOR(2) TTC(3) = TT(3) + TTCOR(3) CALL TYPE7(IS,KK(2,1),KK(3,1)) CALL TYPE8(IS,KK(2,2),KK(3,2)) IF(KK(2,1).EQ.1.AND.KK(3,1).EQ.1) THEN IV2 = 1 IV3 = 1 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. IF(LZ3.NE.99) THEN ZC(LZ3) = ZC(LZ3) + ZZCOR(3) ZCOR(LZ3) = ZCOR(LZ3) + ZZCOR(3) ZZCOR(3) = 0. ELSE ZZCOR(2) = 0. ENDIF ELSEIF(KK(2,2).EQ.1.AND.KK(3,2).EQ.1) THEN IV2 = 2 IV3 = 2 TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. IF(LT3.NE.99) THEN TC(LT3) = TC(LT3) + TTCOR(3) TCOR(LT3) = TCOR(LT3) + TTCOR(3) TTCOR(3) = 0. ELSE TTCOR(3) = 0. ENDIF ELSE IV2 = 1 IV3 = 1 KK(2,1) = 5 KK(2,2) = 5 KK(3,1) = 5 KK(3,2) = 5 ZZCOR(2) = 0. ZZCOR(3) = 0. TTCOR(2) = 0. TTCOR(3) = 0. ENDIF C C CHECK FOR TYPE 90 ERRORS. C ELSEIF(IC2.EQ.90.AND.ICZ1.NE.90.AND.ICT1.NE.90) THEN ZZC(2) = ZZ(2) + ZZCOR(2) ZZC(3) = ZZ(3) + ZZCOR(3) TTC(2) = TT(2) + TTCOR(2) TTC(3) = TT(3) + TTCOR(3) CALL TYPE9(IS,KK(2,1),KK(3,2)) CALL TYPE10(IS,KK(2,2),KK(3,1)) IF(KK(2,1).EQ.1.AND.KK(3,2).EQ.1) THEN IV2 = 1 IV3 = 2 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. IF(LT3.NE.99) THEN TC(LT3) = TC(LT3) + TTCOR(3) TCOR(LT3) = TCOR(LT3) + TTCOR(3) TTCOR(3) = 0. ELSE TTCOR(3) = 0. ENDIF ELSEIF(KK(2,2).EQ.1.AND.KK(3,1).EQ.1) THEN IV2 = 2 IV3 = 1 TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. IF(LZ3.NE.99) THEN ZC(LZ3) = ZC(LZ3) + ZZCOR(3) ZCOR(LZ3) = ZCOR(LZ3) + ZZCOR(3) ZZCOR(3) = 0. ELSE ZZCOR(2) = 0. ENDIF ELSE IV2 = 1 IV3 = 1 KK(2,1) = 5 KK(2,2) = 5 KK(3,1) = 5 KK(3,2) = 5 ZZCOR(2) = 0. ZZCOR(3) = 0. TTCOR(2) = 0. TTCOR(3) = 0. ENDIF C C DO NOT PERFORM OTHER CORRECTIONS ABOVE NLEV. C C IF(L2.GT.NLEV) GO TO 35 C C CHECK FOR POSSIBLE HYDSTC CORRECTIONS AT TOP. C ELSEIF(IC2.EQ.5) THEN CALL TYPE5(IS,KK,IV2) ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. C C CHECK FOR POSSIBLE HYDSTC CORRECTIONS AT BOTTOM. C ELSEIF(IC2.EQ.4 & .OR.(ICH1.EQ.4.AND.ZZ(1).EQ.ZC(1) & .AND.TT(1).EQ.TC(1))) THEN IF(IC2.EQ.4) THEN CALL TYPE4(IS,KK,IV2,IV3) ELSE CALL TYPE6(IS,KK(2,1),KK(3,1),IV2,IV3) ENDIF IF(KK(2,1).EQ.1.AND.KK(3,1).EQ.1 & .AND.IV2.EQ.1.AND.IV3.EQ.1 & .AND.LZ3.NE.99) THEN DO 20 I=L2,MAND IF(ZC(I).GT.VMAX(1)) GO TO 20 ZC(I) = ZC(I) + ZZCOR(2) ZCOR(I) = ZCOR(I) + ZZCOR(2) C C WRITE EVENT FILE ENTRIES FOR ALL LEVELS CHANGED. C IR = IR + 1 IF(IR.GT.899) GO TO 110 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,2 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) NEVNT(6,IR) = ((1*100+I)*100+ISCAN)*100+1 NEVNT(8,IR) = Z(I) NEVNT(9,IR) = T(I)*10. NEVNT(10,IR) = ZC(I) NEVNT(11,IR) = OINC(I,1,IS) NEVNT(16,IR) = HINC(I,1,IS) NEVNT(17,IR) = VINC(I,1,IS) NEVNT(12,IR) = HYRES(I,IS) NEVNT(14,IR) = VMSG(1) IF(I.LT.NPLVL) THEN NEVNT(13,IR) = HYRES(I+1,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(20,IR) = VMSG(1) NEVNT(7,IR) = NERR(I,1,IS,ISCAN) NEVNT(18,IR) = NERT(I,1,IS,ISCAN) NEVNT(19,IR) = TRES(I,1,IS) NEVNT(20,IR) = TRES(I,1,IS) + ZZCOR(2) 20 CONTINUE ZZCOR(2) = 0. GO TO 100 ELSE ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. ENDIF C C CHECK FOR POSSIBLE TYPE 3 HYDSTC CORRECTIONS. C IF THE TEMPERATURE INCREMENT AND/OR HORIZONTAL RESIDUAL ARE C NOT LARGE ENOUGH, REVERT TO TRYING A TYPE 1 CORRECTION. C ELSEIF (IC2.EQ.3.OR.IC2.EQ.31.OR.IC2.EQ.32) THEN IF((OINCT(2).LT.VMAX(2).AND.ABS(OINCT(2)).GT.XINC(L2,2)) .OR. & (HREST(2).LT.VMAX(2).AND.ABS(HREST(2)).GT.HOIRES(L2,2))) & THEN CALL TYPE3(IS,KK(2,1),KK(2,2),IV2) ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. IF(LH1.EQ.99) GO TO 705 ELSE CALL TYPE1(IS,KK(2,1)) IV2 = 1 ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. ENDIF C C CHECK FOR ERRORS AT HOLE BOUNDARIES. C UPPER BOUNDARY OF HOLE... C (EXCLUDE TYPE 6 CHECK, TYPES 7-10 AT LOWER BNDRY) C ELSEIF((IC2.EQ.13.OR.IC2.EQ.14) & .AND.ICZ1.NE.7 & .AND.ICZ1.NE.78 & .AND.ICZ1.NE.9 & .AND.ICZ1.NE.90 & .AND.ICT1.NE.8 & .AND.ICT1.NE.78 & .AND.ICT1.NE.10 & .AND.ICT1.NE.90 & .AND.ABS(HYS(1)).GT.HSCRES(LH1) & .AND.L2.LE.NPLVL) THEN CALL TYPE4(IS,KK,IV2,IV3) IF(KK(2,1).EQ.1.AND.KK(3,1).EQ.1 & .AND.IV2.EQ.1.AND.IV3.EQ.1) THEN DO 25 I=L2,MAND IF(ZC(I).GT.VMAX(1)) GO TO 25 ZC(I) = ZC(I) + ZZCOR(2) ZCOR(I) = ZCOR(I) + ZZCOR(2) C C WRITE EVENT FILE ENTRIES FOR ALL LEVELS CHANGED. C IR = IR + 1 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,3 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) NEVNT(6,IR) = ((1*100+I)*100+ISCAN)*100+1 NEVNT(8,IR) = Z(I) NEVNT(9,IR) = T(I)*10. NEVNT(10,IR) = ZC(I) NEVNT(11,IR) = OINC(I,1,IS) NEVNT(16,IR) = HINC(I,1,IS) NEVNT(17,IR) = VINC(I,1,IS) NEVNT(12,IR) = HYRES(I,IS) NEVNT(14,IR) = VMSG(1) IF(I.LT.NPLVL) THEN NEVNT(13,IR) = HYRES(I+1,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(20,IR) = VMSG(1) NEVNT(7,IR) = NERR(I,1,IS,ISCAN) NEVNT(18,IR) = NERT(I,1,IS,ISCAN) NEVNT(19,IR) = TRES(I,1,IS) NEVNT(20,IR) = TRES(I,1,IS) + ZZCOR(2) 25 CONTINUE ZZCOR(2) = 0. GO TO 100 ELSE ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. ENDIF C C LOWER BOUNDARY OF HOLE... C C 705 CONTINUE ELSEIF((ICZ3.EQ.13.OR.ICZ3.EQ.14).AND.ICZ3.EQ.ICT3 & .AND.ABS(HYS(1)).GT.HSCRES(LZ1).AND.HYS(1).LT.VMAX(2) & .AND.ZZ(2).LT.VMAX(1).AND.TT(2).LT.VMAX(2)) THEN CALL TYPE5(IS,KK,IV2) ZC(L2) = ZC(L2) + ZZCOR(2) ZCOR(L2) = ZCOR(L2) + ZZCOR(2) ZZCOR(2) = 0. TC(L2) = TC(L2) + TTCOR(2) TCOR(L2) = TCOR(L2) + TTCOR(2) TTCOR(2) = 0. C C CHECK FOR HYDROSTATICALLY DETECTED THICKNESS ERRORS. C NOTE! IT IS IMPORTANT THAT THIS TEST BE AFTER TESTS C FOR TYPES 1,2,3,7-10. IT CHECKS TO MAKE SURE THAT C NONE OF THEM MADE ANY CHANGES. C IF(LH1.EQ.99) GO TO 706 ELSEIF((IC2.EQ.6 & .OR.(ICZ1.EQ.4.AND.ZZCOR(1).EQ.0..AND.TTCOR(1).EQ.0.) & .OR.(ICZ1.EQ.13.AND.ABS(HYS(1)).GT.HSCRES(LH1) & .AND.HYS(1).LT.VMAX(1) & .AND.ZZCOR(1).EQ.0..AND.TTCOR(1).EQ.0.) & .OR.(ICZ1.EQ.14.AND.ABS(HYS(1)).GT.HSCRES(LH1) & .AND.HYS(1).LT.VMAX(1) & .AND.ZZCOR(1).EQ.0..AND.TTCOR(1).EQ.0.) & .OR.(IC2.EQ.5.AND.ZZCOR(2).EQ.0..AND.TTCOR(2).EQ.0.) & )) THEN CALL TYPE6(IS,KK(2,1),KK(3,1),IV2,IV3) IF(KK(2,1).EQ.1.AND.KK(3,1).EQ.1) THEN DO 30 I=L2,MAND IF(ZC(I).GT.VMAX(1)) GO TO 30 ZC(I) = ZC(I) + ZZCOR(2) ZCOR(I) = ZCOR(I) + ZZCOR(2) C C WRITE EVENT FILE ENTRIES FOR ALL LEVELS CHANGED. C IR = IR + 1 IF(IR.GT.899) GO TO 110 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,4 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) NEVNT(6,IR) = ((1*100+I)*100+ISCAN)*100+1 NEVNT(8,IR) = Z(I) NEVNT(9,IR) = T(I)*10. NEVNT(10,IR) = ZC(I) NEVNT(11,IR) = OINC(I,1,IS) NEVNT(16,IR) = HINC(I,1,IS) NEVNT(17,IR) = VINC(I,1,IS) NEVNT(12,IR) = HYRES(I,IS) NEVNT(14,IR) = VMSG(1) IF(I.LT.NPLVL) THEN NEVNT(13,IR) = HYRES(I+1,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(20,IR) = VMSG(1) NEVNT(7,IR) = NERR(I,1,IS,ISCAN) NEVNT(18,IR) = NERT(I,1,IS,ISCAN) NEVNT(19,IR) = TRES(I,1,IS) NEVNT(20,IR) = TRES(I,1,IS) + ZZCOR(2) 30 CONTINUE ZZCOR(2) = 0. GO TO 100 ENDIF ENDIF 705 CONTINUE 706 CONTINUE 35 CONTINUE IF(ISCAN.EQ.2) THEN C C MARK NON-CORRECTABLE REMAINING ERRORS. C CALL TYPE0(IS,KK,IV2) COINC(2,1) = VMSG(1) COINC(2,2) = VMSG(1) ENDIF C C RECORD ACTIONS IN EVENTS FILE. C IF(IV2.EQ.1.OR.IV2.EQ.3) THEN L3 = LZ3 ELSEIF(IV2.EQ.2) THEN L3 = LT3 ELSEIF(IV2.EQ.4) THEN L3 = LH3 ENDIF C C EVENTS FILE FOR SINGLE VARIABLE AT L2 C 50 IF((KK(2,1).NE.0.OR.KK(2,2).NE.0.OR.KK(2,3).NE.0) & .AND.IV2.GT.0.AND.IV2.NE.3) THEN IR = IR + 1 IF(IR.GT.899) GO TO 110 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,5 NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) IF(IV2.LT.3) THEN NEVNT(7,IR) = NERR(L2,IV2,IS,ISCAN) ELSE NEVNT(7,IR) = NERR(L2,1,IS,ISCAN) ENDIF IF(L2.EQ.LBZ.AND.IHSC.GE.100) THEN IF(IV2.EQ.1) THEN NEVNT(6,IR) = ((IV2*100+L2)*100+ISCAN)*100+KK(2,IV2) NEVNT(9,IR) = Z(L2) NEVNT(10,IR) = ZC(L2) NEVNT(18,IR) = NERT(L2,1,IS,ISCAN) NEVNT(19,IR) = TRES(L2,1,IS) NEVNT(20,IR) = TRES(L2,1,IS) + ZC(L2) - Z(L2) ELSEIF(IV2.EQ.2) THEN C DON'T USE DECISION=4 FOR LOWEST LEVEL TEMPERATURE. IDECSN = KK(2,IV2) IF(L2.EQ.LBT.AND.KK(2,IV2).EQ.4) IDECSN = 3 NEVNT(6,IR) = ((IV2*100+L2)*100+ISCAN)*100+IDECSN NEVNT(9,IR) = 10.*T(L2) NEVNT(10,IR) = 10.*TC(L2) NEVNT(18,IR) = NERT(L2,1,IS,ISCAN) NEVNT(19,IR) = TRES(L2,1,IS) NEVNT(20,IR) = TRES(L2,1,IS) + TC(L2) - T(L2) ELSE NEVNT(6,IR) = ((4*100+LEV1(IS))*100+ISCAN)*100+KK(2,3) NEVNT(9,IR) = 10. * PS(IS) NEVNT(10,IR) = 10. * PSCC ENDIF NEVNT(8,IR) = SELV(IS) NEVNT(11,IR) = BRES(IS) NEVNT(12,IR) = CBRES NEVNT(13,IR) = PSL(IS)*10. NEVNT(14,IR) = OINCPS(IS)*10. NEVNT(20,IR) = HINCPS(IS)*10. LB1 = LEV1(IS) LB2 = LEV2(IS) NEVNT(16,IR) = OINC(LB1,1,IS) NEVNT(17,IR) = OINC(LB2,1,IS) ELSE IF(IV2.EQ.1) THEN NEVNT(6,IR) = ((IV2*100+L2)*100+ISCAN)*100+KK(2,IV2) NEVNT(8,IR) = Z(L2) NEVNT(9,IR) = T(L2)*10. NEVNT(10,IR) = ZC(L2) NEVNT(11,IR) = OINCZ(2) NEVNT(16,IR) = HRESZ(2) NEVNT(17,IR) = VRESZ(2) NEVNT(18,IR) = NERT(L2,1,IS,ISCAN) NEVNT(19,IR) = TRES(L2,1,IS) NEVNT(20,IR) = TRES(L2,1,IS) + ZC(L2) - Z(L2) ELSEIF(IV2.EQ.2) THEN NEVNT(6,IR) = ((IV2*100+L2)*100+ISCAN)*100+KK(2,IV2) NEVNT(8,IR) = Z(L2) NEVNT(9,IR) = 10. * T(L2) NEVNT(10,IR) = 10. * TC(L2) NEVNT(11,IR) = 10. * OINCT(2) NEVNT(16,IR) = 10. * HREST(2) NEVNT(17,IR) = 10. * VREST(2) NEVNT(18,IR) = NERT(L2,1,IS,ISCAN) NEVNT(19,IR) = TRES(L2,1,IS) NEVNT(20,IR) = TRES(L2,1,IS) + TC(L2) - T(L2) ENDIF NEVNT(12,IR) = HYRES(L2,IS) NEVNT(14,IR) = CHYRES(1) IF(LH3.NE.99) THEN NEVNT(13,IR) = HYRES(LH3,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(20,IR) = CHYRES(2) ENDIF ENDIF IF(IV2.EQ.3 & .AND.((KK(2,1).NE.0 .AND. KK(2,2).NE.0) & .OR. (ICZ3.EQ.ICT3 & .AND.(ICZ3.EQ.13 .OR. ICT3.EQ.14)))) THEN C C EVENTS FILE FOR BOTH Z AND T AT L2. C C SET ITST = 1 FOR TYPES FOR WHICH TSTCOR IS CALLED. C ITST = 0 IF(IC2.EQ.3 ) ITST = 1 IF(IC2.EQ.4 ) ITST = 1 IF(IC2.EQ.5 ) ITST = 1 IF(IC2.EQ.6 ) ITST = 1 IF(IC2.EQ.7 ) ITST = 1 IF(IC2.EQ.8 ) ITST = 1 IF(IC2.EQ.9 ) ITST = 1 IF(IC2.EQ.10) ITST = 1 IF(IC2.EQ.13) ITST = 1 IF(IC2.EQ.14) ITST = 1 C IR = IR + 2 IF(IR.GT.899) GO TO 110 IRM = IR - 1 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,6 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IRM) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IRM) = NEVNTI NV1 = NEVNT(2,IRM) NV2 = NEVNT(3,IRM) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,7 NEVNT(21,IRM) = ID(IS) NEVNT(22,IRM) = IS NEVNT(1,IRM) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IRM) = HOUR NEVNT(4,IRM) = 100. * SLON(IS) NEVNT(5,IRM) = 100. * SLAT(IS) NEVNT(8,IR) = Z(L2) NEVNT(9,IR) = T(L2)*10. NEVNT(10,IR) = ZC(L2) NEVNT(11,IR) = OINCZ(2) NEVNT(16,IR) = HRESZ(2) NEVNT(17,IR) = VRESZ(2) NEVNT(8,IRM) = Z(L2) NEVNT(9,IRM) = T(L2)*10. NEVNT(10,IRM) = 10. * TC(L2) NEVNT(11,IRM) = 10. * OINCT(2) NEVNT(16,IRM) = 10. * HREST(2) NEVNT(17,IRM) = 10. * VREST(2) NEVNT(6,IR) = ((1*100+L2)*100+ISCAN)*100+KK(2,1) NEVNT(6,IRM) = ((2*100+L2)*100+ISCAN)*100+KK(2,2) NEVNT(12,IR) = HYRES(L2,IS) NEVNT(18,IR) = NERT(L2,1,IS,ISCAN) NEVNT(19,IR) = TRES(L2,1,IS) NEVNT(20,IR) = TRES(L2,1,IS) + ZC(L2) - Z(L2) NEVNT(18,IRM) = NERT(L2,1,IS,ISCAN) NEVNT(19,IRM) = TRES(L2,1,IS) NEVNT(20,IRM) = TRES(L2,1,IS) + TC(L2) - T(L2) IF(ITST.EQ.1) THEN NEVNT(14,IR) = CHYRES(1) NEVNT(20,IR) = CHYRES(2) ELSE NEVNT(14,IR) = VMSG(1) NEVNT(20,IR) = VMSG(1) ENDIF IF(LH3.NE.99) THEN NEVNT(13,IR) = HYRES(LH3,IS) NEVNT(13,IRM) = HYRES(LH3,IS) ELSE NEVNT(13,IR) = VMSG(1) NEVNT(13,IRM) = VMSG(1) ENDIF NEVNT(12,IRM) = HYRES(L2,IS) NEVNT(14,IRM) = CHYRES(1) NEVNT(20,IRM) = CHYRES(2) NEVNT(7,IR) = NERR(L2,1,IS,ISCAN) NEVNT(7,IRM) = NERR(L2,2,IS,ISCAN) ENDIF 36 CONTINUE IF((KK(3,1).NE.0 .OR. KK(3,2).NE.0) & .AND. IV3.GT.0 .AND. IV2.NE.3) THEN C C EVENTS FILE FOR L3. C IR = IR + 1 IF(IR.GT.899) GO TO 110 NEVNTI=0 NEVNTC(1:4) = CID(IS)(1:4) NEVNT(2,IR) = NEVNTI NEVNTI=0 NEVNTC(1:2) = CID(IS)(5:6) NEVNT(3,IR) = NEVNTI NV1 = NEVNT(2,IR) NV2 = NEVNT(3,IR) C WRITE(6,777) CID(IS),NV1C,NV2C,IS,I,8 NEVNT(21,IR) = ID(IS) NEVNT(22,IR) = IS NEVNT(1,IR) = ((IYR*100+IMO)*100+IDY)*100+IHR DHOUR(IR) = HOUR NEVNT(4,IR) = 100. * SLON(IS) NEVNT(5,IR) = 100. * SLAT(IS) IF(IV3.EQ.1) THEN IF(L3.NE.99) THEN NEVNT(8,IR) = Z(L3) NEVNT(9,IR) = T(L3)*10. NEVNT(10,IR) = ZC(L3) ELSE NEVNT(8,IR) = VMSG(1) NEVNT(9,IR) = VMSG(1) NEVNT(10,IR) = VMSG(1) ENDIF NEVNT(11,IR) = OINCZ(3) NEVNT(16,IR) = HRESZ(3) NEVNT(17,IR) = VRESZ(3) NEVNT(18,IR) = NERT(L3,1,IS,ISCAN) NEVNT(19,IR) = TRES(L3,1,IS) NEVNT(20,IR) = TRES(L3,1,IS) + ZC(L3) - Z(L3) ELSE IF(L3.NE.99) THEN NEVNT(8,IR) = Z(L3) NEVNT(9,IR) = T(L3)*10. NEVNT(10,IR) = 10. * TC(L3) ELSE NEVNT(8,IR) = VMSG(2) NEVNT(9,IR) = VMSG(2) NEVNT(10,IR) = VMSG(2) ENDIF NEVNT(11,IR) = 10. * OINCT(3) NEVNT(16,IR) = 10. * HREST(3) NEVNT(17,IR) = 10. * VREST(3) NEVNT(18,IR) = NERT(L3,1,IS,ISCAN) NEVNT(19,IR) = TRES(L3,1,IS) NEVNT(20,IR) = TRES(L3,1,IS) + TC(L3) - T(L3) ENDIF NEVNT(6,IR) = ((IV3*100+L3)*100+ISCAN)*100+KK(3,IV3) IF(LH3.NE.99) THEN NEVNT(12,IR) = HYRES(LH3,IS) ELSE NEVNT(12,IR) = VMSG(1) ENDIF IF(ITST.EQ.1) THEN NEVNT(14,IR) = CHYRES(2) NEVNT(20,IR) = CHYRES(3) ELSE NEVNT(14,IR) = VMSG(1) NEVNT(20,IR) = VMSG(1) ENDIF IF(LH4.NE.99) THEN NEVNT(13,IR) = HYRES(LH4,IS) ELSE NEVNT(13,IR) = VMSG(1) ENDIF NEVNT(7,IR) = NERR(L3,IV3,IS,ISCAN) ENDIF 100 CONTINUE RETURN 110 CONTINUE C C TOO MANY CORRECTIONS C IR = 899 RETURN END C************************************************************ SUBROUTINE CORECT(Z,T,ZCOR,TCOR,ZC,TC,S,LEV,NOB,ICTYP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CORECT HYDROSTATIC CORRECTION TO DATA C PRGMMR: W.COLLINS ORG: W/NMC22 DATE: 88-09-14 C C ABSTRACT: MAKES ERROR DETECTIONS TO HEIGHTS AND C TEMPERATURES IN A RADIOSONDE REPORT BASED UPON C A HYDROSTATIC CHECK. THIS VERSION WILL MAKE DETECTIONS C FOR THREE LARGE RESIDUALS IN A ROW. C C PROGRAM HISTORY LOG: C 88-09-14 ORIGINAL W. COLLINS C 89-02-02 W. COLLINS RESTRUCTURED CODE C 89-02-24 W. COLLINS CORRECTION RANKING ADDED C 89-03-20 W. COLLINS REVISION OF TYPE CRITERIA C 89-03-28 W. COLLINS CORRECTION MAGNITUDE CRITERIA C UNIFIED C 89-05-19 W. COLLINS FURTHER UNIFICATION C 91-07-23 W. COLLINS USED WITHIN CQC; NO CORRECTIONS C ARE NOW PERFORMED IN THIS SUB. C C USAGE: CALL CORECT(Z, T, ZCOR, TCOR, ZC, TC, S, C LEV, ICTYP) C INPUT ARGUMENT LIST: C Z - HEIGHT PROFILE (METERS) C T - TEMPERATURE PROFILE (CELSIUS) C LEV - NUMBER OF LEVELS TO CONSIDER C C OUTPUT ARGUMENT LIST: C ZCOR - HEIGHT CORRECTION (METERS) C TCOR - TEMPERATURE CORRECTION (KELVIN/CELSIUS) C ZC - CORRECTED HEIGHT PROFILE (METERS) C TC - CORRECTED TEMPERATURE PROFILE (CELSIUS) C S - NEW HYDROSTATIC RESIDUAL FOR LAYER (M) C ICTYP - CORRECTION TYPE CODE (NOTE! CORRECTIONS C ARE NO LONGER ACTUALLY PERFORMED IN C THIS SUBROUTINE.) C 0 = NO CORRECTION C 1 = CONFIDENT HEIGHT CORRECTION C 2 = CONFIDENT TEMPERATURE CORRECTION C NOTE! ONLY TYPES 1 AND 2 GIVE CONFIDENT C CORRECTIONS THAT ARE ACTUALLY APPLIED C TO THE DATA. C 3 = Z, T CORRECTIONS TO MAKE RESIDS = 0. C 4 = BOTTOM LAYER CORRECTION CHOICE C 5 = TOP LAYER CORRECTION CHOICE C 6 = ISOLATED LARGE RESIDUAL C 7 = TWO CONFIDENT HEIGHT CORRECTIONS IN A ROW C 8 = TWO CONFIDENT TEMPERATURE CORRECTIONS IN A ROW C 9 = TWO CONFIDENT CORRECTIONS IN A ROW C LOWER HEIGHT, UPPER TEMPERATURE C 10 = TWO CONFIDENT CORRECTIONS IN A ROW C LOWER TEMPERATURE, UPPER HEIGHT C 11 = HEIGHT CORRECTION .LT. ZCLIM M C 12 = TEMPERATURE CORRECTION, GIVING INSTABILITY C 13 = MORE THAN ONE MISSING LEVEL, ENDING AT 70MB C 14 = MORE THAN ONE MISSING LEVEL, NOT ENDING AT 70MB C 22 = TEMPERATURE CORRECTION LESS THAN TCLIM DEGREES C 99 = TYPE 9 OR 10 WITH RESULTING INSTABILITY C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C MAKE HYDROSTATIC CORRECTIONS. C C (Z,T) - INPUT (HEIGHT,TEMPERATURE) C (ZC,TC) - OUTPUT(HEIGHT,TEMPERATURE) C (ZI,TI) - INTERMEDIATE VALUES OF (HT.,TEMP.) C (ZCOR,TCOR) - OUTPUT HT., TEMP. CORRECTIONS C (ZCORI,TCORI) - INTERMEDIATE HT., TEMP. CORRECTIONS C LL'S - VALUES OF L'S FOR EACH SCAN. C C MORE DETAIL OF CHANGES MADE 89-03-20: C 1. NEW TYPE 13 - HOLES C 2. TYPES 7,9,10 - INTRODUCE SMALL HT CORRS. ONLY WHEN C ACCOMPANIED BY SIZABEL HT. OR TEMP. CORR. C 3. ACCEPT TEMP. CORR. IF THE LAPSE IS IMPROVED AND C "PRODUCT" IS IMPROVED EVEN IF LAPSE IS NOT STABLE C AND "PRODUCT" NOT GREATER THAN FIXED VALUE. C 4. IF RESIDUALS ARE AS LARGE AS 5*ALLOWABLE, THEN C RELAX CONDITIONS FOR TYPES 4 AND 5. C INTEGER ICTYP(21) REAL Z(99), T(99), ZC(21), TC(21), & ZCOR(21), TCOR(21), S(20), & ZMIN(21), TMIN(21) LOGICAL LTYPE32, LTYPE33 COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /CORCT/ SI(20,3), ICTYPI(21,3), C-CRA& ZI(21,3), TI(21,3), ZCORI(21,3), TCORI(21,3), C-CRA& LL1(21,3), LL2(21,3), LL3(21,3), LL4(21,3) COMMON /CORCT/ SI(20,3), & ZI(21,3), TI(21,3), ZCORI(21,3), TCORI(21,3) COMMON /CORCTI/ ICTYPI(21,3), & LL1(21,3), LL2(21,3), LL3(21,3), LL4(21,3) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /MSGS/ VMAX(2),VMSG(2) DATA CON1 /.75/, CON2 /1./, XM /0./, EX /1./, & TIGHT /.75/, L100 /11/ DATA IFIRST /0/ LEVM = LEV - 1 NPLVLM = NPLVL - 1 IF(IFIRST.EQ.0) THEN DO 1 I=1,NPLVL TMIN(I) = 2. * DTALL 1 CONTINUE DO 2 I=2,NPLVLM ZMIN(I) = 2.*DTALL*SQRT(B(I-1)**2 + B(I)**2) IF(ZMIN(I).LT.35.) ZMIN(I) = 35. 2 CONTINUE ZMIN(1) = ZMIN(2) ZMIN(NPLVL) = ZMIN(NPLVLM) WRITE(6,602) (ZMIN(I),I=1,NPLVL) WRITE(6,603) (TMIN(I),I=1,NPLVL) WRITE(6,604) CON1, CON2, DTALL, XM, EX WRITE(6,606) ZCLIM1, ZCLIM2 WRITE(6,608) TCLIM WRITE(6,610) TIGHT WRITE(64,602) (ZMIN(I),I=1,NPLVL) WRITE(64,603) (TMIN(I),I=1,NPLVL) WRITE(64,604) CON1, CON2, DTALL, XM, EX WRITE(64,606) ZCLIM1, ZCLIM2 WRITE(64,608) TCLIM WRITE(64,610) TIGHT IFIRST = 1 ENDIF 602 FORMAT(' CORECT:',/,' ZMIN:',5F10.0,/,(7X,5F10.0)) 603 FORMAT(' TMIN:',5F10.0,/,(7X,5F10.0)) 604 FORMAT(' CON1:',F10.3,' CON2:',F10.3,/, & ' DTALL:',F10.1,/, & ' XM:',F10.3,' EX:',F10.3) 606 FORMAT(' LOWER, UPPER HT. CORR. LIMITS:',2F10.0) 608 FORMAT(' TEMPERATURE CORR. LIMIT:',F10.0) 610 FORMAT(' CRITERION TIGHTENING AT TOP/BOTTOM:',F10.3) DO 8 K=1,NPLVL DO 7 I=1,3 ZI(K,I) = VMSG(1) TI(K,I) = VMSG(2) LL1(K,I) = -9 LL2(K,I) = -9 LL3(K,I) = -9 LL4(K,I) = -9 7 CONTINUE 8 CONTINUE DO 10 K=1,LEV DO 9 J=1,3 ZI(K,J) = Z(K) TI(K,J) = T(K) 9 CONTINUE 10 CONTINUE DO 20 K=1,NPLVL ICTYP(K) = 0 DO 15 I=1,3 ICTYPI(K,I) = 0 15 CONTINUE 20 CONTINUE DO 30 K=1,NPLVL ZCOR(K) = 0. TCOR(K) = 0. DO 25 II=1,3 ZCORI(K,II) = 0. TCORI(K,II) = 0. 25 CONTINUE 30 CONTINUE DO 31 K=1,NPLVLM S(K) = 0. 31 CONTINUE C C FIND INDEX OF LAST COMPLETE LEVEL. C DO 32 K=1,NPLVL KK = NPLVL - K + 1 IF(ZI(KK,1).LT.VMAX(1).AND.TI(KK,1).LT.VMAX(2)) GO TO 35 32 CONTINUE 35 LTOP = KK C C BEGIN CALCULATIONS. GET FOUR LEVELS OF DATA. C JSCAN = 1 CON = CON1 40 CONTINUE JSCAN = JSCAN + 1 C C RESET COUNTER FOR RESIDUAL LAYER. C IS = 0 C C SET BEGINNING VALUES FOR THIS SCAN TO BE THE C SAME AS THEY ENDED LAST SCAN. C IF(JSCAN.GT.3) GO TO 300 DO 42 K=1,LEV ZI(K,JSCAN) = ZI(K,JSCAN-1) TI(K,JSCAN) = TI(K,JSCAN-1) 42 CONTINUE IF(JSCAN.EQ.3) CON = CON2 ISTRT = 0 LAST = 0 CALL FIRST(LAST,ZI(1,JSCAN),TI(1,JSCAN), & ZL1,ZL2,ZL3,ZL4,TL1,TL2,TL3,TL4, & L1,L2,L3,L4,LTOP,IER) LL = L1 IF(LL.GT.15.) LL = 1 LL1(LL,JSCAN) = L1 LL2(LL,JSCAN) = L2 LL3(LL,JSCAN) = L3 LL4(LL,JSCAN) = L4 IF(IER.EQ.1) GO TO 300 50 CONTINUE IF(ISTRT.EQ.0) THEN LB = LAST ISTRT = 1 LAST = 0 GO TO 55 ENDIF CALL FNLEV(LAST,ZI(1,JSCAN),TI(1,JSCAN), & ZL1,ZL2,ZL3,ZL4,TL1,TL2,TL3,TL4, & L1,L2,L3,L4,LTOP,IER) LL = L1 IF(LL.GT.15.) LL = 1 LL1(LL,JSCAN) = L1 LL2(LL,JSCAN) = L2 LL3(LL,JSCAN) = L3 LL4(LL,JSCAN) = L4 55 CONTINUE C C CALCULATE THE RESIDUALS. C IF(L1.EQ.99) THEN S1 = 0. X1 = 0. BSUM1 = 0. SBIG1 = 0. ELSE CALL RES(ZL1,ZL2,TL1,TL2,L1,L2,A,B,SS,S1,BSUM1,SBIG1) X1 = S1/BSUM1 ENDIF CALL RES(ZL2,ZL3,TL2,TL3,L2,L3,A,B,SS,S2,BSUM2,SBIG2) C C TEST FOR ERRORS AT THE TOP. C BYPASS USUAL SELECTION PROCEDURE. C IF(IER.EQ.1.OR.L3.GE.LTOP) THEN C C TEST FOR HOLE AT THE TOP. (TYPE 13) C IF(L3.GE.L100+1.AND.L3-L2.GT.L3-L100) THEN ICRAT = 23 RAT = 0. GO TO 59 ENDIF C C TEST FOR HOLE OR MISSING LEVELS AT TOP. (TYPE 14) C IF(L3-L2.GT.2) THEN ICRAT = 24 RAT = 0. GO TO 59 ENDIF C C TEST FOR TYPE 3 ERROR AT THE TOP. C IF(((ABS(S1).GT.SBIG1.AND.ABS(S2).GT.0.7*SBIG2) & .OR.(ABS(S2).GT.SBIG2.AND.ABS(S1).GT.0.7*SBIG1)) & .AND.(ICTYPI(L2,JSCAN).EQ.0.)) THEN RAT = 0. ICRAT = 33 GO TO 59 ENDIF C C TEST FOR TYPE 5 ERROR. C IF((ABS(S2).GT.SBIG2) & .AND.((ABS(S1).LT..75*SBIG1) & .OR.(ABS(S1/S2).LT..33))) THEN RAT = 0. ICRAT = 5 GO TO 59 ENDIF GO TO 40 ENDIF C C FOR LOWEST LAYER, FILL TWO VALUES OF SI. FIRST HERE... C IF(L1.EQ.99) THEN IS = IS + 1 SI(IS,JSCAN-1) = S2 ENDIF CALL RES(ZL3,ZL4,TL3,TL4,L3,L4,A,B,SS,S3,BSUM3,SBIG3) C FSHAT2 = FSHAT(S2,S3,SBIG2,SBIG3,XM,EX) C C FILL SECOND VALUE OF SI. C IS = IS + 1 SI(IS,JSCAN-1) = S3 C C CALCULATE RATIOS WHICH DETERMINE MOST PROBABLE ERROR. C DT = DTALL IF(L1.EQ.99.OR.L4.EQ.LTOP) THEN DT = TIGHT * DTALL ENDIF X1 = 0. X2 = S2/BSUM2 X3 = S3/BSUM3 D1 = 0. D2 = 1./BSUM2 D3 = 1./BSUM3 D1S = 0. D2S = D2**2 D3S = D3**2 DZ2 = -0.5 * (S2-S3) DT2 = 0.5 * (X2 + X3) SHGT = ABS(S2+S3) + 1.E-6 SSHGT = 2.*SQRT(BSUM2**2+BSUM3**2) * DT RZ2 = SSHGT / SHGT RZ2M = ABS(DZ2)/ZMIN(L3) STMP = ABS(S2/BSUM2 - S3/BSUM3) + 1.E-6 SSTMP = 2. * DT RT2 = SSTMP / STMP RT2M = ABS(DT2)/TMIN(L3) IF(L1.GE.1.AND.L1.NE.99.AND.L4.LE.LTOP) THEN X1 = S1/BSUM1 D1 = 1./BSUM1 D1S = D1**2 ZZ = ABS(S1 + S2 + S3) + 1.E-6 ZZR = 2. * CON * DT * SQRT(BSUM1**2 + & BSUM2**2 + BSUM3**2) RZZ = ZZR / ZZ TT = ABS(S1/BSUM1 - S2/BSUM2 + S3/BSUM3) + 1.E-6 TTR = 2.* SQRT(3.) * CON * DT RTT = TTR / TT ZT = ABS(S1 + S2 - (BSUM2/BSUM3)*S3) + 1.E-6 ZTR = 2.*CON*DT*SQRT(BSUM1**2 + 2.*BSUM2**2) RZT = ZTR / ZT TZ = ABS(S2 + S3 - (BSUM2/BSUM1)*S1) + 1.E-6 TZR = 2.*CON*DT*SQRT(BSUM3**2 + 2.*BSUM2**2) RTZ = TZR / TZ RZZ1M = ABS(S1)/ZMIN(L2) RZZ2M = ABS(S3)/ZMIN(L3) RTT1M = (ABS(S1)/BSUM1)/TMIN(L2) RTT2M = (ABS(S3)/BSUM3)/TMIN(L3) RZT1M = ABS(S1)/ZMIN(L2) RZT2M = (ABS(S3)/BSUM3)/TMIN(L3) RTZ1M = (ABS(S1)/BSUM1)/TMIN(L2) RTZ2M = ABS(S3)/ZMIN(L3) ELSE RZZ = 0. RTT = 0. RZT = 0. RTZ = 0. RZZ1M = 0. RZZ2M = 0. RTT1M = 0. RTT2M = 0. RZT1M = 0. RZT2M = 0. RTZ1M = 0. RTZ2M = 0. ENDIF C C DETERMINE WHICH CORRECTION TO MAKE BY EXAMINING THE C RATIOS, SIZE OF THE RESIDUALS, AND OTHER CRITERIA. C RAT = 1.0 ICRAT = 0 C C TEST FOR CONFIDENT HEIGHT CORRECTION. C IF(RZ2M.GT.1.0 & .AND.(L4-L3.LT.3) & .AND.(L3-L2.LT.3) & .AND.(RZ2.GT.RAT)) THEN RAT = RZ2 ICRAT = 1 ENDIF C C TEST FOR CONFIDENT TEMPERATURE CORRECTION. C IF(RT2M.GT.1.0 & .AND.(L4-L3.LT.3) & .AND.(L3-L2.LT.3) & .AND.(RT2.GT.RAT)) THEN RAT = RT2 ICRAT = 2 ENDIF C C TEST FOR TYPES 7 TO 10. C IF(L1.GE.1.AND.L1.NE.99.AND.L4.LE.LTOP) THEN IF(ICTYPI(L1,JSCAN).EQ.0) THEN IF((L2-L1.LT.3) & .AND.(L3-L2.LT.3) & .AND.(L4-L3.LT.3)) THEN IF((RZZ.GT.RAT) & .AND.(RZZ1M.GT.1.0) & .AND.(RZZ2M.GT.1.0)) THEN RAT = RZZ ICRAT = 7 ENDIF IF((RTT.GT.RAT) & .AND.(RTT1M.GT.1.0) & .AND.(RTT2M.GT.1.0) & .AND.(ICRAT.NE.7)) THEN RAT = RTT ICRAT = 8 ELSEIF((RTT.GT.RAT) & .AND.(RTT1M.GT.1.0) & .AND.(RTT2M.GT.1.0) & .AND.(ICRAT.EQ.7)) THEN ICRAT = 78 ENDIF IF((RZT.GT.RAT) & .AND.(RZT1M.GT.1.0) & .AND.(RZT2M.GT.1.0)) THEN RAT = RZT ICRAT = 9 ENDIF IF((RTZ.GT.RAT) & .AND.(RTZ1M.GT.1.0) & .AND.(RTZ2M.GT.1.0) & .AND.(ICRAT.NE.9)) THEN RAT = RTZ ICRAT = 10 ELSEIF((RTZ.GT.RAT) & .AND.(RTZ1M.GT.1.0) & .AND.(RTZ2M.GT.1.0) & .AND.(ICRAT.EQ.9)) THEN ICRAT = 90 ENDIF ENDIF ENDIF ENDIF C C TEST FOR HOLE. C IF(L3.GE.L100+1.AND.L3-L2.GT.L3-L100) THEN ICRAT = 13 RAT = 0. GO TO 59 ENDIF C C TEST FOR HOLE OF MISSING LEVELS ANYWHERE. C IF(L3-L2.GT.2) THEN ICRAT = 14 RAT = 0. GO TO 59 ENDIF C C TEST FOR ERROR AT THE BOTTOM. C IF((L2.EQ.LB) & .AND.((ABS(S2).GT.SBIG2.AND.ABS(S3).LT.0.5*SBIG3) & .OR.(ABS(S2).GT.SBIG2.AND.ABS(S3/S2).LT..33)) & .AND.(ICRAT.EQ.0)) THEN RAT = 0. ICRAT = 4 GO TO 59 ENDIF C C TEST FOR TYPE 3 CONDITIONS AT LEVELS 2 AND 3. C SET LOGICAL VARIABLES FOR USE LATER (TYPES 8,9,10). C IF((ABS(S2).GT.SBIG2.AND.ABS(S3).GT.0.7*SBIG3) & .OR.(ABS(S3).GT.SBIG3.AND.ABS(S2).GT.0.7*SBIG2)) THEN LTYPE33 = .TRUE. ELSE LTYPE33 = .FALSE. ENDIF IF((ABS(S1).GT.SBIG1.AND.ABS(S2).GT.0.7*SBIG2) & .OR.(ABS(S2).GT.SBIG2.AND.ABS(S1).GT.0.7*SBIG1)) THEN LTYPE32 = .TRUE. ELSE LTYPE32 = .FALSE. ENDIF C C TEST FOR TYPE 3 ERROR. C IF(((ABS(S2).GT.SBIG2.AND.ABS(S3).GT.0.7*SBIG3) & .OR.(ABS(S3).GT.SBIG3.AND.ABS(S2).GT.0.7*SBIG2)) & .AND.(ICRAT.EQ.0)) THEN RAT = 0. ICRAT = 3 GO TO 59 ENDIF C C TEST FOR ISOLATED ERROR. C IF(ABS(S2).GT.1.5*SBIG2 & .AND.L2.NE.LB & .AND.L3.LT.LTOP & .AND.ICRAT.EQ.0) THEN R12 = ABS(S1/S2) R32 = ABS(S3/S2) IF((R12.LE..33.AND.ABS(S1).LT.SBIG1) & .AND.(R32.LE..33.AND.ABS(S3).LT.SBIG3) & .AND.ICRAT.EQ.0) THEN RAT = 0. ICRAT = 6 GO TO 59 ENDIF ENDIF C C GO TO PROPER PLACE IN CODE FOR CORRECTION. C 59 CONTINUE IF(ICRAT.EQ.0) GO TO 50 IF(ICRAT.EQ.1) GO TO 60 IF(ICRAT.EQ.2) GO TO 70 IF(ICRAT.EQ.3) GO TO 160 IF(ICRAT.EQ.13) GO TO 190 IF(ICRAT.EQ.14) GO TO 195 IF(ICRAT.EQ.23) GO TO 230 IF(ICRAT.EQ.24) GO TO 240 IF(ICRAT.EQ.33) GO TO 210 IF(ICRAT.EQ.4) GO TO 170 IF(ICRAT.EQ.5) GO TO 220 IF(ICRAT.EQ.6) GO TO 180 IF(ICRAT.EQ.7) GO TO 80 IF(ICRAT.EQ.8) GO TO 90 IF(ICRAT.EQ.9) GO TO 100 IF(ICRAT.EQ.10) GO TO 110 IF(ICRAT.EQ.78) GO TO 120 IF(ICRAT.EQ.90) GO TO 130 GO TO 50 C C CONFIDENT HEIGHT CORRECTION. C 60 CONTINUE ZOLD = ZL3 ZCORI(L3,JSCAN) = (D3S*S3-D2S*S2)/(D2S+D3S) ITYP = 1 CALL ZCORR(ZL3,ZCORI(L3,JSCAN),L3,ALLZL,NZL, & ALLZ,NZ,ICTYPI(L3,JSCAN),ITYP) C C MAKE NO CORRECTION IF IT IS TOO SMALL. C IF(L3.LE.4) THEN ZLIM3 = ZCLIM1 ELSE ZLIM3 = ZCLIM2 ENDIF IF(ABS(ZCORI(L3,JSCAN)).LT.ZLIM3) THEN ICTYPI(L3,JSCAN) = 11 ZL3 = ZOLD ENDIF ZL3 = ZOLD ZI(L3,JSCAN) = ZL3 GO TO 50 C C CONFIDENT TEMPERATURE CORRECTION. C 70 CONTINUE TOLD = TL3 TCORI(L3,JSCAN) = 0.5 * (S2/BSUM2 + S3/BSUM3) ITYP = 2 CALL TCORR(TL2,TL3,TL4,TCORI(L3,JSCAN),ZL2,ZL3,ZL4, & ALLT,NT,ICTYPI(L3,JSCAN),0,ITYP) C C MAKE NO CORRECTION IF IT IS TOO SMALL. C IF(ABS(TCORI(L3,JSCAN)).LT.TCLIM) THEN ICTYPI(L3,JSCAN) = 22 TL3 = TOLD ENDIF TL3 = TOLD TI(L3,JSCAN) = TL3 GO TO 50 C C TWO ERRORS GIVING LARGE RESIDUALS. C PERFORM THE TESTS ONLY FOR SUFFICIENTLY LARGE RESIDUALS. C C TWO HEIGHT ERRORS. C 80 CONTINUE XD = (D1S+D3S)*D2S + D1S*D3S ZCORI(L2,JSCAN) = (-D1*(D2S+D3S)*X1 + D2*D3S*X2 & +D2S*D3*X3) / XD ZCORI(L3,JSCAN) = (-D1*D2S*X1 - D2*D1S*X2 & + (D1S+D2S)*D3*X3) / XD ZOLD2 = ZL2 ZOLD3 = ZL3 ITYP = 7 CALL ZCORR(ZL2,ZCORI(L2,JSCAN),L2,ALLZL,NZL,ALLZ,NZ, & ICTYPI(L2,JSCAN),ITYP) CALL ZCORR(ZL3,ZCORI(L3,JSCAN),L3,ALLZL,NZL,ALLZ,NZ, & ICTYPI(L3,JSCAN),ITYP) C C MAKE NO CORRECTION IF BOTH ARE SMALL. C IF(L2.LE.4) THEN ZLIM2 = ZCLIM1 ELSE ZLIM2 = ZCLIM2 ENDIF IF(L3.LE.4) THEN ZLIM3 = ZCLIM1 ELSE ZLIM3 = ZCLIM2 ENDIF IF(ABS(ZCORI(L2,JSCAN)).LT.ZLIM2 & .AND.ABS(ZCORI(L3,JSCAN)).LT.ZLIM3) THEN ICTYPI(L2,JSCAN) = 0 ICTYPI(L3,JSCAN) = 0 ZL2 = ZOLD2 ZL3 = ZOLD3 ENDIF ZL2 = ZOLD2 ZL3 = ZOLD3 ZI(L2,JSCAN) = ZL2 ZI(L3,JSCAN) = ZL3 GO TO 50 C C TWO TEMPERATURE ERRORS. C 90 CONTINUE TCORI(L2,JSCAN) = (2.*X1 + X2 - X3)/3. TCORI(L3,JSCAN) = (2.*X3 + X2 - X1)/3. TOLD2 = TL2 TOLD3 = TL3 ITYP = 8 CALL TCORR(TL1,TL2,TL3,TCORI(L2,JSCAN),ZL1,ZL2,ZL3, & ALLT,NT,ICTYPI(L2,JSCAN),-1,ITYP) IF(ICTYPI(L2,JSCAN).EQ.12) THEN TL2 = TOLD2 TL3 = TOLD3 IF( LTYPE32 ) THEN ICTYPI(L2,JSCAN) = 3 ELSE ICTYPI(L2,JSCAN) = 0 ENDIF IF( LTYPE33 ) THEN ICTYPI(L3,JSCAN) = 3 ELSE ICTYPI(L3,JSCAN) = 0 ENDIF GO TO 91 ENDIF ITYP = 8 CALL TCORR(TL2,TL3,TL4,TCORI(L3,JSCAN),ZL2,ZL3,ZL4, & ALLT,NT,ICTYPI(L3,JSCAN),0,ITYP) IF(ICTYPI(L3,JSCAN).EQ.12) THEN TL2 = TOLD2 TL3 = TOLD3 IF( LTYPE32 ) THEN ICTYPI(L2,JSCAN) = 3 ELSE ICTYPI(L2,JSCAN) = 0 ENDIF IF( LTYPE33 ) THEN ICTYPI(L3,JSCAN) = 3 ELSE ICTYPI(L3,JSCAN) = 0 ENDIF ENDIF 91 CONTINUE C C MAKE NO CORRECTIONS IF BOTH ARE SMALL. C IF(ABS(TCORI(L2,JSCAN)).LT.TCLIM & .AND.ABS(TCORI(L3,JSCAN)).LT.TCLIM) THEN ICTYPI(L2,JSCAN) = 0 ICTYPI(L3,JSCAN) = 0 TL2 = TOLD2 TL3 = TOLD3 ENDIF TL2 = TOLD2 TL3 = TOLD3 TI(L2,JSCAN) = TL2 TI(L3,JSCAN) = TL3 GO TO 50 C C ERROR TO LOWER HEIGHT, UPPER TEMPERATURE. C 100 CONTINUE XD = 2.*D1S + D2S ZCORI(L2,JSCAN) = (D2*X2 - 2.*D1*X1 - D2*X3) / XD TCORI(L3,JSCAN) = (D1S*X2 + D1*D2*X1 + (D1S+D2S)*X3) / XD ZOLD = ZL2 TOLD = TL3 ITYP = 9 CALL ZCORR(ZL2,ZCORI(L2,JSCAN),L2,ALLZL,NZL, & ALLZ,NZ,ICTYPI(L2,JSCAN),ITYP) ITYP = 9 CALL TCORR(TL2,TL3,TL4,TCORI(L3,JSCAN),ZL2,ZL3,ZL4, & ALLT,NT,ICTYPI(L3,JSCAN),0,ITYP) C C IF THE CORRECTED TEMPERATURE MAKES A BAD LAPSE RATE C THEN MAKE NEITHER CORRECTION. C IF(ICTYPI(L3,JSCAN).EQ.12) THEN IF( LTYPE32 ) THEN ICTYPI(L2,JSCAN) = 3 ELSE ICTYPI(L2,JSCAN) = 0 ENDIF IF( LTYPE33 ) THEN ICTYPI(L3,JSCAN) = 3 ELSE ICTYPI(L3,JSCAN) = 0 ENDIF ZL2 = ZOLD TL3 = TOLD ENDIF C C MAKE NO CORRECTION IF BOTH ARE SMALL. C IF(L2.LE.4) THEN ZLIM2 = ZCLIM1 ELSE ZLIM2 = ZCLIM2 ENDIF IF(ABS(ZCORI(L2,JSCAN)).LT.ZLIM2 & .AND.ABS(TCORI(L3,JSCAN)).LT.TCLIM) THEN ICTYPI(L2,JSCAN) = 0 ICTYPI(L3,JSCAN) = 0 ZL2 = ZOLD TL3 = TOLD ENDIF ZL2 = ZOLD TL3 = TOLD ZI(L2,JSCAN) = ZL2 TI(L3,JSCAN) = TL3 GO TO 50 C C ERROR TO LOWER TEMPERATURE, UPPER HEIGHT. C 110 CONTINUE XD = D2S + 2.*D3S TCORI(L2,JSCAN) = ((D2S+D3S)*X1 + D3S*X2 + D2*D3*X3) / XD ZCORI(L3,JSCAN) = (D2*X1 + 2.*D3*X3 - D2*X2) / XD ZOLD = ZL3 TOLD = TL2 ITYP = 10 CALL ZCORR(ZL3,ZCORI(L3,JSCAN),L3,ALLZL,NZL,ALLZ,NZ, & ICTYPI(L3,JSCAN),ITYP) ITYP = 10 CALL TCORR(TL1,TL2,TL3,TCORI(L2,JSCAN),ZL1,ZL2,ZL3, & ALLT,NT,ICTYPI(L2,JSCAN),0,ITYP) C C IF THE CORRECTED TEMPERATURE MAKES A BAD LAPSE RATE C THEN MAKE NEITHER CORRECTION. C IF(ICTYPI(L2,JSCAN).EQ.12) THEN IF( LTYPE32 ) THEN ICTYPI(L2,JSCAN) = 3 ELSE ICTYPI(L2,JSCAN) = 0 ENDIF IF( LTYPE33 ) THEN ICTYPI(L3,JSCAN) = 3 ELSE ICTYPI(L3,JSCAN) = 0 ENDIF ZL3 = ZOLD TL2 = TOLD ENDIF C C MAKE NO CORRECTION IF BOTH ARE SMALL. C IF(L3.LE.4) THEN ZLIM3 = ZCLIM1 ELSE ZLIM3 = ZCLIM2 ENDIF IF(ABS(TCORI(L2,JSCAN)).LT.TCLIM & .AND.ABS(ZCORI(L3,JSCAN)).LT.ZLIM3) THEN ICTYPI(L2,JSCAN) = 0 ICTYPI(L3,JSCAN) = 0 ZL3 = ZOLD TL2 = TOLD ENDIF ZL3 = ZOLD TL2 = TOLD ZI(L3,JSCAN) = ZL3 TI(L2,JSCAN) = TL2 GO TO 50 C C ERRORS OF UNDETERMINED TYPE FOR ADJACENT LAYERS. C 120 CONTINUE ICTYPI(L2,JSCAN) = 78 ICTYPI(L3,JSCAN) = 78 GO TO 50 130 CONTINUE ICTYPI(L2,JSCAN) = 90 ICTYPI(L3,JSCAN) = 90 GO TO 50 C C TYPE 3 ERRORS. C 160 CONTINUE ZCOLD = ZCORI(L3,JSCAN) TCOLD = TCORI(L3,JSCAN) ZCORI(L3,JSCAN) = (BSUM2*S3 - BSUM3*S2)/(BSUM2+BSUM3) IF(L3.LE.4) ZCORI(L3,JSCAN) = ANINT(ZCORI(L3,JSCAN)) IF(L3.GT.4) ZCORI(L3,JSCAN) = 10.*ANINT(ZCORI(L3,JSCAN)/10.) TCORI(L3,JSCAN) = (S2+S3)/(BSUM2+BSUM3) TCORI(L3,JSCAN) = 0.1 * ANINT(10.*TCORI(L3,JSCAN)) Z3 = 2. * DTALL * SQRT(BSUM2**2 + BSUM3**2) T3 = 2. * DTALL AZC = ABS(ZCORI(L3,JSCAN)) ATC = ABS(TCORI(L3,JSCAN)) IF(AZC.GT.Z3 .AND. ATC.GT.T3) ICTYPI(L3,JSCAN) = 3 IF(AZC.GT.Z3 .AND. ATC.LE.T3) ICTYPI(L3,JSCAN) = 1 IF(AZC.LE.Z3 .AND. ATC.GT.T3) ICTYPI(L3,JSCAN) = 2 C OTHERWISE THE TYPE REMAINS = 0 GO TO 50 C C ERROR(S) AT THE BOTTOM. C 170 CONTINUE ZCORI(L2,JSCAN) = S2 IF(L2.LE.4) ZCORI(L2,JSCAN) = ANINT(ZCORI(L2,JSCAN)) IF(L2.GT.4) ZCORI(L2,JSCAN) = 10. * ANINT(ZCORI(L2,JSCAN)/10.) TCORI(L2,JSCAN) = S2/BSUM2 TCORI(L2,JSCAN) = 0.1 * ANINT(10.*TCORI(L2,JSCAN)) ICTYPI(L2,JSCAN) = 4 GO TO 50 C C CHECK FOR ISOLATED LARGE RESIDUAL. C 180 CONTINUE ICTYPI(L3,JSCAN) = 6 GO TO 50 C C CHECK FOR HOLE. C 190 CONTINUE ICTYPI(L3,JSCAN) = 13 GO TO 50 C C CHECK FOR HOLE OF MISSING LEVELS ANYWHERE. C 195 CONTINUE ICTYPI(L3,JSCAN) = 14 GO TO 50 C C CHECK FOR ERROR(S) AT THE TOP. THEN RETURN C FOR SECOND PASS (TO STATEMENT 40). C C CHECK FOR TYPE 3 ERRORS IN THE TOP LAYER. C 210 CONTINUE ZCOLD = ZCORI(L2,JSCAN) TCOLD = TCORI(L2,JSCAN) ZCORI(L2,JSCAN) = (BSUM1*S2 - BSUM2*S1)/(BSUM1+BSUM2) IF(L2.LE.4) ZCORI(L2,JSCAN) = ANINT(ZCORI(L2,JSCAN)) IF(L2.GT.4) ZCORI(L2,JSCAN) = 10.*ANINT(ZCORI(L2,JSCAN)/10.) TCORI(L2,JSCAN) = (S1+S2)/(BSUM1+BSUM2) TCORI(L2,JSCAN) = 0.1 * ANINT(10.*TCORI(L2,JSCAN)) Z2 = 2. * DTALL * SQRT(BSUM1**2 + BSUM2**2) T2 = 2. * DTALL AZC = ABS(ZCORI(L2,JSCAN)) ATC = ABS(TCORI(L2,JSCAN)) IF(AZC.GT.Z2 .AND. ATC.GT.T2) ICTYPI(L2,JSCAN) = 3 IF(AZC.GT.Z2 .AND. ATC.LE.T2) ICTYPI(L2,JSCAN) = 1 IF(AZC.LE.Z2 .AND. ATC.GT.T2) ICTYPI(L2,JSCAN) = 2 C OTHERWISE THE TYPE REMAINS = 0 GO TO 40 C C CHECK FOR ERROR AT THE TOP LEVEL. C 220 CONTINUE ZCORI(L3,JSCAN) = -S2 IF(L3.LE.4) ZCORI(L3,JSCAN) = ANINT(ZCORI(L3,JSCAN)) IF(L3.GT.4) ZCORI(L3,JSCAN) = 10. * ANINT(ZCORI(L3,JSCAN)/10.) TCORI(L3,JSCAN) = S2/BSUM2 TCORI(L3,JSCAN) = 0.1 * ANINT(10.*TCORI(L3,JSCAN)) ICTYPI(L3,JSCAN) = 5 GO TO 40 C C CHECK FOR HOLE AT TOP. (TYPE 13) C 230 CONTINUE ICTYPI(L3,JSCAN) = 13 GO TO 40 C C CHECK FOR HOLE AT TOP. (TYPE 14) C 240 CONTINUE ICTYPI(L3,JSCAN) = 14 GO TO 40 C C COME HERE TO FILL IN OUTPUT FIELDS. C 300 CONTINUE IF(L2.EQ.11.AND.L2-L1.GT.1) ICTYPI(L2,JSCAN-1) = 13 DO 320 K=1,LEV ZC(K) = ZI(K,3) TC(K) = TI(K,3) ICTYP(K) = 0 ZCOR(K) = 0. TCOR(K) = 0. DO 310 II=1,3 C C CAPTURE SUCCESSIVE TYPE 1 AND 2 CHANGES. C ALSO, REPORT TYPE 3-S ONLY FROM SECOND SCAN. C OTHERWISE, CAPTURE ALL NON-ZERO ICTYPI-S. C IF(ICTYPI(K,II).NE.0 & .AND.(.NOT.(II.EQ.2.AND.ICTYPI(K,II).EQ.3))) THEN ZCOR(K) = ZCORI(K,II) TCOR(K) = TCORI(K,II) ICTYP(K) = ICTYPI(K,II) ENDIF 310 CONTINUE IF(ICTYPI(K,2).EQ.1.AND.(ICTYPI(K,3).EQ.2 & .OR.ICTYPI(K,3).EQ.12)) THEN ZCOR(K) = ZCORI(K,2) TCOR(K) = TCORI(K,3) ICTYP(K) = 3 ELSEIF(ICTYPI(K,2).EQ.2.AND.ICTYPI(K,3).EQ.1) THEN TCOR(K) = TCORI(K,2) ZCOR(K) = ZCORI(K,3) ICTYP(K) = 3 ENDIF CALL UNPACK(NERR(K,1,NOB,ISCAN),IHSC1,IINC1,IHOI1, & IVOI1,IBAS1,IIPL1,IHPL1) CALL UNPACK(NERR(K,2,NOB,ISCAN),IHSC2,IINC2,IHOI2, & IVOI2,IBAS2,IIPL2,IHPL2) IHSC = ICTYP(K) CALL PACK(NERR(K,1,NOB,ISCAN),IINC1,IHSC,IHOI1, & IVOI1,IBAS1,IIPL1,IHPL1) CALL PACK(NERR(K,2,NOB,ISCAN),IINC2,IHSC,IHOI2, & IVOI2,IBAS2,IIPL2,IHPL2) 320 CONTINUE DO 340 K=1,LEVM S(K) = SI(K,2) 340 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DETAIL PRINT DETAILS FOR STATIONS OF INTEREST. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PRINT DETAILS FOR STATIONS WHERE ERRORS ARE DETECTED. C PRINT DIFFERENT FORMS TO DIFFERENT FILES: FULL OUTPUT TO FT06; C COMPACT FORM TO FT60; SDM OUTPUT TO FT61. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-28 W. COLLINS USES NEW EVENTS FILE. C 92-??-?? J. WOOLLEN MADE MORE EFFICIENT C C USAGE: CALL PGM-NAME(INARG1, INARG2, WRKARG, OUTARG1, ... ) C OUTPUT FILES: C FT06F001 - FULL DETAILED OUTPUT C FT60F001 - COMPACT FORM OF OUTPUT FOR STATIONS WITH ERRORS C FT61F001 - SELECTED OUTPUT FOR SDM C FT64F001 - DIAGNOSTIC FILE SHOWING DETAILS OF DECISIONS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE DETAIL CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) C-CRA COMMON /DATEC/ CDATE(2), IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE(2) COMMON /DATEI/ IYR, IMO, IDY, IHR C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) CHARACTER*4 CDATE, VALS(4), CER(21,8,2) CHARACTER*2 VAR(4) DIMENSION IDSORT(899), NER(21,8,2) DIMENSION OINCT(4), OIDIF(21,2), X(21) DIMENSION JEV(100,5),VAL(100),COR(100),IHS(100), OLD(100) LOGICAL CHNG,HYD,BSLN,OTHER,P61,P65,P06 DATA VAR / ' Z', ' T', 'ZT', 'PS'/ DATA VALS /' 0 ', ' 1 ', ' 2 ',' - '/ DATA ISTART / 0/ NLEVM = NLEV - 1 NPLVLM = NPLVL - 1 WRITE(6,500) NLEV, NOBS, NPLVL, & ALATN, ALATX, ALONN, ALONX, E2 WRITE(60,500) NLEV, NOBS, NPLVL, & ALATN, ALATX, ALONN, ALONX, E2 WRITE(64,500) NLEV, NOBS, NPLVL, & ALATN, ALATX, ALONN, ALONX, E2 WRITE(6,501) (CDATE(I),I=1,2) IF(ISCAN.EQ.1) WRITE(16,501) (CDATE(I),I=1,2) WRITE(60,501) (CDATE(I),I=1,2) WRITE(64,501) (CDATE(I),I=1,2) WRITE(61,501) (CDATE(I),I=1,2) WRITE(6,622) (CID(I)(1:6),DHR(I),I=1,NOBS) IF(ISCAN.EQ.1) WRITE(16,621) (CID(I),I=1,NOBS) C C READ LONS, LATS FOR DETAILED OUTPUT. C IF(ISTART.EQ.0) THEN RLONN = -0.01 RLONX = 360.01 RLATN = -90.01 RLATX = 90.01 WRITE(6,503) RLONN, RLONX, RLATN, RLATX WRITE(60,503) RLONN, RLONX, RLATN, RLATX WRITE(64,503) RLONN, RLONX, RLATN, RLATX C WRITE(65,503) RLONN, RLONX, RLATN, RLATX ISTART = 1 ENDIF C MAKE A SORTED LIST OF STATION ID'S (RETAIN ORIGINAL) C ---------------------------------------------------- CALL SORTID(ID,IDSORT) C DO I=1,NOBS C IDSORT(I) = ID(I) C ENDDO C CALL SHELL(IDSORT,IWKSP,NOBS,0) C GO THROUGH THE (SORTED) LIST OF STATIONS AND PRINT DETAILS C ---------------------------------------------------------- ICNT = 0 DO 100 IDS=1,NOBS IF(IDSORT(IDS).LE.0) GO TO 100 IS = IDSORT(IDS) IBLOCK = ID(IS)/1000 CHNG = .FALSE. HYD = .FALSE. BSLN = .FALSE. OTHER = .FALSE. P06 = .FALSE. P61 = .FALSE. P65 = .FALSE. C MAKE A LIST OF ALL EVENTS FOR EACH SCAN FOR THIS OB C --------------------------------------------------- NEV = 0 DO 5 IEV=1,IR IF(NEVNT(21,IEV).EQ.ID(IS) & .AND. DHOUR(IEV).EQ.DHR(IS)) THEN CALL UNPCK2(NEVNT(6,IEV),IVV,LEV,ISC,IDC) NEV = NEV+1 IF(NEV.GT.100) GOTO 6 JEV(NEV,1) = IVV JEV(NEV,2) = LEV JEV(NEV,3) = ISC JEV(NEV,4) = IDC JEV(NEV,5) = IEV ENDIF 5 CONTINUE 6 CONTINUE C IF SCAN 2 SEE IF ANY DECISIONS CHANGED C -------------------------------------- IF(ISCAN.EQ.2) THEN DO 20 N=1,NEV IF(JEV(N,3).NE.2) GOTO 20 ICK = NEVNT(6,JEV(N,5)) DO 10 M=1,NEV JCK = NEVNT(6,JEV(M,5)) IF(ABS(ICK-JCK).EQ.100) GOTO 15 10 CONTINUE M = NEV CHNG = .TRUE. 15 CHNG = NEVNT(10,JEV(N,5)).NE.NEVNT(10,JEV(M,5)) .OR. CHNG IF(CHNG) GOTO 25 20 CONTINUE ENDIF C DECIDE WHAT TO PRINT C -------------------- 25 DO 35 IV=1,2 DO 35 L=1,NPLVL ITMP = NERR(L,IV,IS,ISCAN) CALL UNPACK(ITMP,IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) ITMP = NERT(L,IV,IS,ISCAN) IF(ISCAN.EQ.1) THEN HYD = HYD .OR.(IHSC.NE.0 .AND. IHSC.NE.99) BSLN = BSLN .OR. IBAS.EQ.2 .OR. IIPL.EQ.2 .OR. IHPL.EQ.2 OTHER = OTHER .OR. IINC.EQ.2 .OR. IHOI.EQ.2 .OR. IVOI.EQ.2 ENDIF CER(L,1,IV) = VALS(IINC+1) CER(L,2,IV) = VALS(IVOI+1) CER(L,3,IV) = VALS(IHOI+1) NER(L,4,IV) = IHSC CER(L,5,IV) = VALS(IBAS+1) CER(L,6,IV) = VALS(IIPL+1) CER(L,7,IV) = VALS(IHPL+1) CER(L,8,IV) = VALS(ITMP+1) IF(OBS(L,IV,IS).GT.VMAX(IV)) THEN CER(L,1,IV) = VALS(4) CER(L,2,IV) = VALS(4) CER(L,3,IV) = VALS(4) CER(L,8,IV) = VALS(4) ENDIF IF(BRES(IS).GT.VMAX(2)) THEN CER(L,5,IV) = VALS(4) ENDIF IF(PSL(IS).GT.VMAX(2)) THEN CER(L,6,IV) = VALS(4) CER(L,7,IV) = VALS(4) ENDIF C COUNT NUMBER OF REPORTED HEIGHTS C -------------------------------- NHTS = 0 MAND = MAN(IS) DO 40 LVL=1,MAND IF(OBS(LVL,1,IS).LT.VMAX(1)) NHTS = NHTS + 1 40 CONTINUE C PRINT CRITERIA FOR UNITS 06 AND 60. P06 = NHTS.NE.0 & .AND. SLAT(IS).GE.RLATN.AND.SLAT(IS).LE.RLATX & .AND. SLON(IS).GT.RLONN.AND.SLON(IS).LE.RLONX & .AND. (HYD .OR. BSLN .OR. OTHER .OR. CHNG) C DETERMINE WHETHER STATION IS INDIAN STATION C ------------------------------------------- P65 = IBLOCK.EQ.70 .OR. IBLOCK.EQ.71 & .OR. IBLOCK.EQ.72 .OR. IBLOCK.EQ.74 & .OR. IBLOCK.EQ.76 C SPECIFY CRITERIA FOR SDM FILE PRINT C ----------------------------------- DO 30 N=1,NEV ISC = JEV(N,3) IDC = JEV(N,4) IEV = JEV(N,5) CALL UNPACK(NEVNT(7,IEV),IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) P61 = (IHSC.NE.0 .AND. IDC.GE.3) .OR. & (ISC .EQ.2 .AND. IDC.GE.3) .OR. & IDC.EQ.5 .OR. & P65 .OR. & P61 30 CONTINUE 35 CONTINUE C STORE INFORMATION FOR THE PRINTOUT(S) C ------------------------------------- IF(LEV1(IS).GE.1 .AND. LEV1(IS).LE.NPLVL) THEN P1 = IPLVL(LEV1(IS)) Z1 = OBS(LEV1(IS),1,IS) ELSE P1 = VMSG(1) Z1 = VMSG(1) ENDIF IF(LEV2(IS).GE.1 .AND. LEV2(IS).LE.NPLVL) THEN P2 = IPLVL(LEV2(IS)) Z2 = OBS(LEV2(IS),1,IS) ELSE P2 = VMSG(1) Z2 = VMSG(1) ENDIF IF(ABS(PSCOR(IS)).LT.VMAX(1).AND.ABS(PS(IS)).LT.VMAX(1)) THEN PSN = PS(IS) + PSCOR(IS) ELSE PSN = VMSG(1) ENDIF IF(ABS(Z1COR(IS)).LT.VMAX(1).AND.ABS(Z1).LT.VMAX(1)) THEN Z1N = Z1 + Z1COR(IS) ELSE Z1N = VMSG(1) ENDIF IF(ABS(Z2COR(IS)).LT.VMAX(1).AND.ABS(Z2).LT.VMAX(1)) THEN Z2N = Z2 + Z2COR(IS) ELSE Z2N = VMSG(1) ENDIF IF(BRES(IS).LT.VMAX(1)) THEN ZSC = SELV(IS) - BRES(IS) ZSCOR = -BRES(IS) ELSE ZSC = VMSG(1) ZSCOR = VMSG(1) ENDIF MANL = MAN(IS) C CALCULATE HYDROSTATIC RESIDUALS IN TERMS OF TEMPERATURE C ------------------------------------------------------- DO 45 K=1,NPLVL X(K) = VMSG(2) 45 CONTINUE DO 50 K=1,NPLVLM I = ISU(K,IS) IF( I.GT.0 .AND. I.LE.NPLVL) THEN IF( BSUM(K,IS) .NE. 0. . .AND. ABS(BSUM(K,IS)) .LT. VMAX(1) . .AND. ABS(HYRES(I,IS)) .LT. VMAX(1)) THEN X(I) = HYRES(I,IS) / BSUM(K,IS) ENDIF ENDIF 50 CONTINUE C CALCULATE RESIDUAL DIFFERENCES C ------------------------------ DO 55 IV=1,2 DO 55 L=1,MANL L2 = L V1 = VMSG(IV) V2 = VMSG(IV) V3 = VMSG(IV) CALL FINDL(L1,L2,L3,L4,HINC(1,IV,IS),IV,MANL) IF(L1.NE.99) V1 = HINC(L1,IV,IS) IF(L2.NE.99) V2 = HINC(L2,IV,IS) IF(L3.NE.99) V3 = HINC(L3,IV,IS) CALL VDIF(OIDIF(L,IV),V1,V2,V3,L1,L2,L3,VMAX(IV),VMSG(IV)) 55 CONTINUE C STORE DMA DIAGNOSIS INFORMATION C ------------------------------- DO 60 N=1,NEV I = JEV(N,5) CALL UNPACK(NEVNT(7,I),IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) IHS(N) = IHSC IV = JEV(N,1) IF(IV.EQ.1.AND.IHSC.LT.100) THEN COR(N) = NEVNT(10,I) - NEVNT(8,I) VAL(N) = NEVNT(10,I) OLD(N) = NEVNT(8,I) ELSEIF(IV.EQ.1.AND.IHSC.GE.100) THEN COR(N) = NEVNT(10,I) - NEVNT(9,I) VAL(N) = NEVNT(10,I) OLD(N) = NEVNT(9,I) ELSEIF(IV.EQ.2.OR.IV.EQ.4) THEN COR(N) = 0.1 * (NEVNT(10,I) - NEVNT(9,I)) VAL(N) = 0.1 * NEVNT(10,I) OLD(N) = 0.1 * NEVNT(9,I) ELSE COR(N) = 0. VAL(N) = 0. OLD(N) = 0. ENDIF 60 CONTINUE C MAKE A PRINTOUT TO SELECTED UNITS C --------------------------------- WLON = 360. - SLON(IS) IF(P06) THEN ICNT = ICNT + 1 IF(MOD(ICNT,2).EQ.1) THEN IF(WLON.LE.180.) THEN WRITE(6,504) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) ELSE WRITE(6,604) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) ENDIF IF(WLON.LE.180.) THEN WRITE(60,504) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) ELSE WRITE(60,604) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) ENDIF ELSE IF(WLON.LE.180.) THEN WRITE(6,633) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) ELSE WRITE(6,634) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) ENDIF IF(WLON.LE.180.) THEN WRITE(60,633) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) ELSE WRITE(60,634) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) ENDIF ENDIF WRITE(6,533) (CDATE(I),I=1,2), DHR(IS), ISCAN WRITE(60,533) (CDATE(I),I=1,2), DHR(IS), ISCAN WRITE(6,522) PSL(IS),GESPS(IS),OINCPS(IS),HINCPS(IS),BRES(IS) WRITE(60,522) PSL(IS),GESPS(IS),OINCPS(IS),HINCPS(IS),BRES(IS) WRITE(6,596) WRITE(60,596) WRITE(6,597) PS(IS), PS(IS), PSN, PSCOR(IS) WRITE(60,597) PS(IS), PS(IS), PSN, PSCOR(IS) WRITE(6,619) PS(IS), SELV(IS),ZSC,ZSCOR WRITE(60,619) PS(IS), SELV(IS),ZSC,ZSCOR WRITE(6,598) P1, Z1, Z1N, Z1COR(IS) WRITE(60,598) P1, Z1, Z1N, Z1COR(IS) WRITE(6,599) P2, Z2, Z2N, Z2COR(IS) WRITE(60,599) P2, Z2, Z2N, Z2COR(IS) ENDIF IF(P61) THEN IF(WLON.LE.180.) THEN WRITE(61,504) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) ELSE WRITE(61,604) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) ENDIF WRITE(61,533) (CDATE(I),I=1,2), DHR(IS), ISCAN WRITE(61,522) PSL(IS),GESPS(IS),OINCPS(IS),HINCPS(IS),BRES(IS) WRITE(61,596) WRITE(61,597) PS(IS), PS(IS), PSN, PSCOR(IS) WRITE(61,619) PS(IS), SELV(IS),ZSC,ZSCOR WRITE(61,598) P1, Z1, Z1N, Z1COR(IS) WRITE(61,599) P2, Z2, Z2N, Z2COR(IS) ENDIF C IF(P65) THEN C IF(WLON.LE.180.) THEN C WRITE(65,504) CID(IS)(1:6), SLAT(IS), WLON, SELV(IS) C ELSE C WRITE(65,604) CID(IS)(1:6), SLAT(IS), SLON(IS), SELV(IS) C ENDIF C WRITE(65,533) (CDATE(I),I=1,2), DHR(IS), ISCAN C WRITE(65,522) PSL(IS),GESPS(IS),OINCPS(IS),HINCPS(IS),BRES(IS) C WRITE(65,596) C WRITE(65,597) PS(IS), PS(IS), PSN, PSCOR(IS) C WRITE(65,619) PS(IS), SELV(IS),ZSC,ZSCOR C WRITE(65,598) P1, Z1, Z1N, Z1COR(IS) C WRITE(65,599) P2, Z2, Z2N, Z2COR(IS) C ENDIF IF(P06) THEN WRITE(6,515) WRITE(60,515) WRITE(6,516) IPLVL(1),((CER(1,I,IV),IV=1,2),I=1,3), . (CER(1,8,IV),IV=1,2),NER(1,4,1), . (CER(1,I,1),I=5,7) WRITE(60,516) IPLVL(1),((CER(1,I,IV),IV=1,2),I=1,3), . (CER(1,8,IV),IV=1,2),NER(1,4,1), . (CER(1,I,1),I=5,7) WRITE(6,517) (IPLVL(L),((CER(L,I,IV),IV=1,2),I=1,3), . (CER(L,8,IV),IV=1,2), . NER(L,4,1),L=2,MANL) WRITE(60,517) (IPLVL(L),((CER(L,I,IV),IV=1,2),I=1,3), . (CER(L,8,IV),IV=1,2), . NER(L,4,1),L=2,MANL) ENDIF IF(P06) THEN WRITE(6,505) WRITE(60,530) ENDIF IF(P61) WRITE(61,1530) C IF(P65) WRITE(65,1530) DO 65 K=1,MANL IF(P06) THEN WRITE(6,506) IPLVL(K), (OBS(K,I,IS),I=1,2), . (GES(K,I,IS),I=1,2), (OINC(K,I,IS),I=1,2), . (OIDIF(K,I),I=1,2), . HYRES(K,IS), X(K), (VINC(K,J,IS), . (WTV(I,K,J,IS),I=1,2),J=1,2) WRITE(60,531) IPLVL(K), (OBS(K,I,IS),I=1,2), . (OINC(K,I,IS),I=1,2), . HYRES(K,IS),X(K),(VINC(K,J,IS),J=1,2), . (HINC(K,I,IS),I=1,2),(HSTD(K,I,IS),I=1,2), . (GES(K,I,IS),I=1,2),(TRES(K,I,IS),I=1,2) ENDIF IF(P61) WRITE(61,1531) IPLVL(K), (OBS(K,I,IS),I=1,2), . (OINC(K,I,IS),I=1,2), . HYRES(K,IS),X(K),(VINC(K,J,IS),J=1,2), . (HINC(K,I,IS),I=1,2),(HSTD(K,I,IS),I=1,2), . (GES(K,I,IS),I=1,2),(TRES(K,I,IS),I=1,2), . IPLVL(K),((CER(K,I,IV)(2:3),IV=1,2),I=1,3), . (CER(K,8,IV)(2:3),IV=1,2), . NER(K,4,1) C IF(P65) WRITE(65,1531) IPLVL(K), (OBS(K,I,IS),I=1,2), C . (OINC(K,I,IS),I=1,2), C . HYRES(K,IS),X(K),(VINC(K,J,IS),J=1,2), C . (HINC(K,I,IS),I=1,2),(HSTD(K,I,IS),I=1,2), C . (GES(K,I,IS),I=1,2),(TRES(K,I,IS),I=1,2), C . IPLVL(K),((CER(K,I,IV)(2:3),IV=1,2),I=1,3), C . (CER(K,8,IV)(2:3),IV=1,2), C . NER(K,4,1) 65 CONTINUE IF(P06) THEN WRITE(6,507) WRITE(6,508) DO 330 K=1,MANL NC = 0 DO 325 I=1,4 OINCT(I) = 0. IF(IDH(I,K,1,IS).GT.0) NC = NC + 1 325 CONTINUE DO 31 I=1,NC ITMP = IDH(I,K,1,IS) OINCT(I) = OINC(K,1,ITMP) 31 CONTINUE WRITE(6,509) IPLVL(K), HINC(K,1,IS), OIDIF(K,1), & HSTD(K,1,IS), & (IDH(I,K,1,IS),I=1,4), (OINCT(I),I=1,4), & (WTH(I,K,1,IS),I=1,4) 330 CONTINUE C C FIND NUMBER OF COLLECTED POINTS FOR TEMPERATURE. C WRITE(6,510) WRITE(6,508) DO 340 K=1,MANL NC = 0 DO 335 I=1,4 OINCT(I) = 0. IF(IDH(I,K,2,IS).GT.0) NC = NC + 1 335 CONTINUE DO 41 I=1,NC ITMP = IDH(I,K,2,IS) OINCT(I) = OINC(K,2,ITMP) 41 CONTINUE WRITE(6,509) IPLVL(K), HINC(K,2,IS), & OIDIF(K,2), HSTD(K,2,IS), & (IDH(I,K,2,IS),I=1,4), (OINCT(I),I=1,4), & (WTH(I,K,2,IS),I=1,4) 340 CONTINUE ENDIF DO 70 N=1,NEV IF(N.EQ.1 .AND. P06) WRITE(6,520) IF(N.EQ.1 .AND. P06) WRITE(60,520) IF(N.EQ.1. AND. P61) WRITE(61,520) C IF(N.EQ.1. AND. P65) WRITE(65,520) IVV = JEV(N,1) LEV = JEV(N,2) ISC = JEV(N,3) IDC = JEV(N,4) IEV = JEV(N,5) IF(P06) THEN WRITE(6,521) ISC, IPLVL(LEV), VAR(IVV), IHS(N), IDC, & OLD(N), COR(N), VAL(N) WRITE(60,521) ISC, IPLVL(LEV), VAR(IVV), IHS(N), IDC, & OLD(N), COR(N), VAL(N) ENDIF IF(P61) & WRITE(61,521) ISC, IPLVL(LEV), VAR(IVV), IHS(N), IDC, & OLD(N), COR(N), VAL(N) C IF(P65) C & WRITE(65,521) ISC, IPLVL(LEV), VAR(IVV), IHS(N), IDC, C & OLD(N), COR(N), VAL(N) 70 CONTINUE 100 CONTINUE RETURN C FORMAT STATEMENTS C ----------------- 500 FORMAT(/,' NLEV:',I5,' NOBS:',I5, & ' NPLVL:',I5,/,' LAT-MIN:',F7.2,' LAT-MAX:',F8.2, & ' LON-MIN:',F8.2,' LON-MAX:',F8.2,' E2:',F5.2) 501 FORMAT('0DATE: ',2A4) 502 FORMAT(4F10.2) 503 FORMAT('0DETAILED OUTPUT REGION: LONGITUDES - ',2F8.2, & ' LATITUDES - ',2F8.2,//) 504 FORMAT(///' STN ID: ',A6,' LAT:',F8.2, & ' LON:',F8.2,' WEST ELEVATION:',F8.2) 604 FORMAT(///' STN ID: ',A6,' LAT:',F8.2, & ' LON:',F8.2,' EAST ELEVATION:',F8.2) 505 FORMAT(1H0,10X,'OBSERVATION',5X,'-GUESS-',5X, & '-INCREMENT- -INCR-DIFF- HYRES HYRES', & 3X,'--------------VERTICAL', & '--------------', & /,' PRESSURE HEIGHT TEMP HEIGHT TEMP', & ' HEIGHT TEMP HEIGHT', & ' TEMP HEIGHT TEMP HEIGHT HT', & '-WEIGHTS TEMP TEMP-WEIGHTS') 506 FORMAT(1X,I8,4(F7.0,F7.1),2F8.1,F7.0,2F7.3,F7.1,2F7.3) 507 FORMAT(' -- HEIGHT INFORMATION --') 508 FORMAT(' PRESSURE RESIDUAL RES-DIFF COMP-ERR', & 3X,'--STN IDS--', & 10X,'--INCREMENTS--',13X,'--HOR CHECK WTS--') 509 FORMAT(1X,I8,F9.1,F9.1,F9.4,4I4,4F7.1,4F7.3) 510 FORMAT(' -- TEMPERATURE INFORMATION --') 515 FORMAT(1H0,8X,'IINC IVOI IHOI ITMP',/, & 3X,'PRES Z T Z T Z T Z T IHSC IBAS IIPL IHPL') 516 FORMAT(1X,I6,8A3,I6,3A6) 517 FORMAT(1X,I6,8A3,I6) 520 FORMAT('0DMA RESULTS',/, & ' SCAN PRESSURE VARIABLE IHSC DECISION OLD VALUE', & ' CORRECTION NEW VALUE') 521 FORMAT(1X,I4,3X,I5,7X,A2,5X,I3,5X,I2,5X,F9.1,3X,F9.1,2X,F9.1) 522 FORMAT(' P-MSL:',F7.1,' GES P-MSL:',F7.1,' OINCPS:', & F7.1,' HINCPS:',F7.1,' BASELINE RESID:',F7.1) 530 FORMAT(1H0,6X,'OBSERVATION INCREMENT HYRES HYRES', & ' VERTICAL -----HORIZONTAL------ --GUESS--', & /,' PRESS HEIGHT TEMP HEIGHT TEMP HEIGHT TEMP', & ' HEIGHT TEMP HEIGHT TEMP ZCMP TCMP HEIGHT TEMP') 531 FORMAT(1X,I5,5(F7.0,F6.1),2F5.1,F7.0,F6.1,F7.0,F6.1) 533 FORMAT(' DATE/TIME: ',2A4,' HOUR:',F6.0,' SCAN:',I2) 596 FORMAT(9X,'PRESSURE VALUE NEW-VALUE CORRECTION') 597 FORMAT(' PS',4F11.1) 598 FORMAT(' Z1',4F11.1) 599 FORMAT(' Z2',4F11.1) 619 FORMAT(' ZS',4F11.1) 621 FORMAT(10(A6,2X)) 622 FORMAT(' CID,DHR:'/(1X,8(A6,F6.0,2X))) 633 FORMAT(///' STN ID: ',A6,' LAT:',F8.2, & ' LON:',F8.2,' WEST ELEVATION:',F8.2) 634 FORMAT(///' STN ID: ',A6,' LAT:',F8.2, & ' LON:',F8.2,' EAST ELEVATION:',F8.2) 1530 FORMAT(1H0,6X,' HYDROSTATIC ', & ' VERTICAL HORIZONTAL ', & ' TEMPORAL', & /,7X,'OBSERVATION INCREMENT -RESIDUAL- ', & '--RESIDUAL-- ------RESIDUAL-------- --GUESS--', & ' --RESIDUAL-- INC VOI HOI TMP', & /,' PRESS HEIGHT TEMP HEIGHT TEMP HEIGHT TEMP', & ' HEIGHT TEMP HEIGHT TEMP ZCMP TCMP HEIGHT TEMP', & ' HEIGHT TEMP PRES Z T Z T Z T Z T HSC') 1531 FORMAT(1X,I5,5(F7.0,F6.1),2F5.1,F7.0,F6.1,F7.0,F6.1, & 1X,I4,8A2,I4) END C********************************************************** SUBROUTINE DISTR(X,MSK,XLIM,XMSG,NX,N,NDIV,DDIV, & NZERO,DZERO,NS,X1,SD,SK,XK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DISTR CALCULATE MOMENTS OF DISTRIBUTION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: FOR GIVEN DATA, CALCULATE THE 0TH THROUGH 4TH MOMENTS. C ALSO PRODUCE BINNED DISTRIBUTION. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL DISTR(X, MSK, XLIM, XMSG, NX, N, NDIV, DDIV, NZERO, C DZERO, NS, X1, SD, SK, XK) C INPUT ARGUMENT LIST: C X - DATA C MSK - MASK: VALUE = 0 -- USE IN COMPUTATIONS C VALUE.NE.0 -- DONT USE C XLIM - (1) MINIMUM VALUE TO USE C (2) MAXIMUM VALUE TO USE C XMSG - MISSING VALUE FOR VARIABLE C NX - DIMENSION OF X C NDIV - NUMBER OF DIVISIONS C NZERO - = 0, USE DZERO AS CENTER C = 1, USE MEAN AS CENTER C DZERO - CENTRAL DIVISION LOCATION C C OUTPUT ARGUMENT LIST: C N - OUTPUT DISTRIBUTION, COUNT IN EACH DIVISION C NS - COUNT OF VALUES USED C X1 - FIRST MOMENT (MEAN) C X2 - SECOND MOMENT C X3 - THIRD MOMENT C X4 - FOURTH MOMENT C SD - STANDARD DEVIATION (POPULATION) C = SQRT(X2 - X1**2) C SK - SKEWNESS = X3/(X2)**(3/2) C XK - KURTOSIS = X4/(SD**4) - 3 C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ INTEGER N(23), MSK(899) REAL X(899), XLIM(2) C C COMPUTE VARIOUS POWERS OF X. C NS = 0 SUM1 = 0. SUM2 = 0. SUM3 = 0. SUM4 = 0. DO 10 I=1,NX IF(MSK(I).EQ.0.AND.ABS(X(I)).LT.XMSG & .AND.X(I).GE.XLIM(1).AND.X(I).LE.XLIM(2)) THEN NS = NS + 1 SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I)**2 SUM3 = SUM3 + X(I)**3 SUM4 = SUM4 + X(I)**4 ENDIF 10 CONTINUE IF(NS.LT.1) THEN DZERO = 0. X1 = 0. SD = 0. SK = 0. XK = 0. GO TO 15 ENDIF SUM1 = SUM1/NS SUM2 = SUM2/NS SUM3 = SUM3/NS SUM4 = SUM4/NS C C CALCULATE VARIOUS OUTPUT STATISTICS. C X1 = SUM1 ARG = SUM2 - SUM1**2 IF(ARG.GT.0.) THEN SD = SQRT(ARG) ELSE SD = 0. ENDIF X3 = SUM3 - 3.*SUM2*SUM1 + 2.*SUM1**3 IF(SUM2.GT.0.) THEN SK = X3/(SUM2)**1.5 ELSE SK = 0. ENDIF X4 = SUM4 - 4.*SUM3*SUM1 + 6.*SUM2*SUM1**2 - 3.*SUM1**4 IF(SD.GT.0.) THEN XK = (X4/SD**4) - 3.0 ELSE XK = 0. ENDIF C C COUNT THE NUMBER OF OBSERVATIONS IN EACH DIVISION. C 15 CONTINUE IF(DDIV.EQ.0.) DDIV = 1. IF(NZERO.EQ.1) DZERO = SUM1 DO 18 I=1,NDIV N(I) = 0 18 CONTINUE CON = 0.5*NDIV + 1.0 - DZERO/DDIV DO 20 I=1,NX IF(MSK(I).EQ.0.AND.ABS(X(I)).LT.XMSG & .AND.X(I).GE.XLIM(1).AND.X(I).LE.XLIM(2)) THEN INDEX = X(I)/DDIV + CON IF(INDEX.LT.1) INDEX = 1 IF(INDEX.GT.NDIV) INDEX = NDIV N(INDEX) = N(INDEX) + 1 ENDIF 20 CONTINUE RETURN END C******************************************************** SUBROUTINE DMA C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DMA DECISION-MAKING ALGORITHM C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: DECISION-MAKING ALGORITHM. CALLS ROUTINES TO DETERMINE C ERRORS AND MAKE CORRECTIONS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL DMA C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C DECISION-MAKING ALGORITHM C REAL ZCOR(21), TCOR(21), ZC(21), TC(21), SN(20) INTEGER ICTYP(21) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) DO 100 IS=1,NOBS MAND = MAN(IS) MANM = MAND - 1 C C INITIALIZE CORRECTIONS TO ZERO, CORRECTED VALUES TO MISSING. C DO 10 L=1,NPLVL ZCOR(L) = 0. TCOR(L) = 0. ZC(L) = VMSG(1) TC(L) = VMSG(2) 10 CONTINUE C C SET CORRECTED VALUES TO PRESENT VALUES IN OBS. C DO 20 L=1,MAND ZC(L) = OBS(L,1,IS) TC(L) = OBS(L,2,IS) 20 CONTINUE DO 30 L=1,MANM SN(L) = HYRES(L+1,IS) 30 CONTINUE C C LOOK FOR HYDROSTATIC CORRECTIONS. C CALL CORECT(OBS(1,1,IS),OBS(1,2,IS),ZCOR,TCOR, & ZC,TC,SN,MAND,IS,ICTYP) C C CORROBORATE HYDROSTATIC CORRECTIONS AND LOOK FOR OTHERS. C ALSO CONSIDER POSSIBLE BASELINE PROBLEMS. C CALL CORCT2(OBS(1,1,IS),OBS(1,2,IS),ZCOR,TCOR, & ZC,TC,MAND,IS,ICTYP,IER) IF(IER.NE.0) RETURN 100 CONTINUE RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DMA20 DMA FOR SIG LVLS, NO GUESS. C PRGMMR: J. WOOLLEN ORG: W/NMC20 DATE: 94-MM-DD C C ABSTRACT: DECISION-MAKING ALGORITHM FOR SIGNIFICANT LEVEL C TEMPERATURES WHEN NO GUESS IS AVAILABLE. C C PROGRAM HISTORY LOG: C 94-MM-DD J. WOOLLEN C C USAGE: CALL DMA20 C INPUT ARGUMENT LIST: C NONE C C OUTPUT ARGUMENT LIST: C NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE DMA20 C-CRA COMMON /DATEC/ CDATE, IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE COMMON /DATEI/ IYR, IMO, IDY, IHR C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) CHARACTER*40 HSTR,OSTR,QSTR CHARACTER*8 SUBSET,CDATE REAL HDR(10),OBS(10,895),QMS(10,895) CHARACTER*8 CDR(10) LOGICAL FIRST,DUPMAN EQUIVALENCE (HDR,CDR) DATA HSTR /'SID XOB YOB DHR ELV ITP TYP '/ DATA OSTR /'POB TOB ZOB CAT '/ DATA QSTR /'PQM TQM ZQM '/ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- FIRST = .TRUE. PRINT*,'DMA20 READING UNIT ',NFIN C REOPEN THE INPUT FILE AND RESTORE THE DATE C ------------------------------------------ CALL OPENBF(NFIN,'IN',NFIN) CALL READMG(NFIN,SUBSET,IDATE,IRET) IF(IRET.NE.0) GOTO 900 WRITE(CDATE,'(I8 )') IDATE READ (CDATE,'(4I2)') IYR,IMO,IDY,IHR PRINT*,'DATA VALID AT ',CDATE C READ A MESSAGE EVERY TIME EXCEPT THE FIRST C ------------------------------------------- IOBS = 1 10 IF(FIRST) THEN FIRST = .FALSE. ELSE CALL READMG(NFIN,SUBSET,IDATE,IRET) IF(IRET.NE.0) GOTO 100 ENDIF C PROCESS ONLY ADPUPA MESSAGES - JUST COPY OTHERS AS IS AND CONTINUE C ------------------------------------------------------------------- IF(SUBSET.NE.'ADPUPA') GOTO 10 20 CALL READSB(NFIN,IRET) IF(IRET.NE.0) GOTO 10 C READ AND STORE HEADER ELEMENTS C ------------------------------ CALL UFBINT(NFIN,HDR,10,1,IRET,HSTR) SID = HDR(1) XOB = HDR(2) YOB = HDR(3) DHR = HDR(4) ELV = HDR(5) ITP = HDR(6) TYP = HDR(7) WRITE(6,500) CDR(1),(HDR(I),I=2,5),(HDR(I),I=6,7) 500 FORMAT(' DMA20--SID,IDENT,XOB,YOB,DHR,ELV,ITP,TYP: ', & (10X,A8,2X,2F10.2,2X,F8.2,2X,F8.2,2F8.0)) C ONLY PROCESS PREPDA TYP=1XX (MASS) REPORTS C ------------------------------------------ IF(TYP.LT.BMISS .AND. NINT(TYP)/100.NE.1) GOTO 20 C READ AND STORE MASS OBS C ----------------------- IOBS = IOBS + 1 IF(IOBS.GT.899) GOTO 901 CALL UFBINT(NFIN,OBS,10,895,NLVD,OSTR) CALL UFBINT(NFIN,QMS,10,895,NLVQ,QSTR) IF(NLVD.NE.NLVQ) CALL SABORT('DMA20 - NLEV <> NLEQ !!') NLV = NLVD ISF = 0 DO L=1,NLV IF(CAT(L).EQ.0) ISF = L POB(L) = OBS(1,L) TOB(L) = OBS(2,L) ZOB(L) = OBS(3,L) CAT(L) = OBS(4,L) PQM(L) = QMS(1,L) TQM(L) = QMS(2,L) IF(TQM(L).GE.BMISS) TQM(L) = 2. ZQM(L) = QMS(3,L) IND(L) = L ENDDO DO L=1,NLV WRITE(6,501) L,(OBS(I,L),I=1,3), & CAT(L),PQM(L),TQM(L),ZQM(L) ENDDO 501 FORMAT(' DMA20--L,POB,TOB,ZOB,CAT,PQM,TQM,ZQM: ', & (10X,I5,2F8.1,F8.0,4F8.2)) C CREATE EVENTS FOR EVENTS SUMMARY ONLY C ------------------------------------- CALL MANEVN CALL STCEVN(IOBS,IDENT,DHR,XOB,YOB,ELV) GOTO 20 C EXITS C ----- 100 RETURN 900 CALL SABORT('NO DATA IN FILE') RETURN 901 WRITE(6,502) 502 FORMAT(' NO. OBSERVATIONS GREATER THAN 899') END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DMASIG DMA FOR SIGNIFICANT LEVELS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: DECISION MAKING ALGORITHM FOR SIGNIFICANT TEMPERATURES. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C 94-11-28 W. COLLINS USR BUFR QUALITY MARKS C C USAGE: CALL DMASIG(P,XP,Z,T,I1,INDX,ITYP,IDEC,IHYD, C TI,HM,HA,VM,VA,TSTAR, C PQD,ZQD,TQD,NUM,TNEW,TTRY,IERR) C INPUT ARGUMENT LIST: C NOTE! ALL INPUT VARIABLES GO FROM ONE 'COMPLETE' C MANDATORY LEVEL TO THE NEXT. C P - PRESSURE (HPA) C XP - NATURAL LOGARITHM OF PRESSURE C Z - HEIGHT (M) C T - TEMPERATURE (C) C INDX - INDEX INTO ORIGINAL ARRAY (FULL ARRAY) C ITYP - TYPE OF LEVEL C TI - TEMPERATURE INCREMENT (C) C HM - HYDROSTATIC RESIDUAL USING MAND LVLS ONLY (M) C HA - HYDROSTATIC RESIDUAL USING ALL LVLS (M) C VM - VERTICAL RESIDUAL USING MAND LVLS ONLY (C) C VA - VERTICAL RESIDUAL USING ALL LVLS (C) C TSTAR - TEMP INCR GIVING ZERO HYD RESIDUAL W MND LVLS (C) C PQD - PRESSURE QUALITY MARK (TABLE VALUE) C ZQD - HEIGHT QUALITY MARK (TABLE VALUE) C PQD - PRESSURE QUALITY MARK (TABLE VALUE) C TTRY - TRIAL TEMPERATURE (C) C C OUTPUT ARGUMENT LIST: C TNEW - NEW TEMPERATUE, CORRECTED OR OTHERWISE (C) C IERR - ERROR TYPE AT SIG LVL C IDEC - DECISION TYPE AT SIG LVL C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE DMASIG(P,XP,Z,T,I1,INDX,ITYP,IDEC,IHYD, & TI,HM,HA,VM,VA,TSTAR, & PQD,ZQD,TQD,NUM,TNEW,TTRY,IERR) REAL P(*), XP(*), Z(*), T(*), TI(*), HM(*), HA(*), & VM(*), VA(*), TSTAR(*), TNEW(*), TTRY(*), & PQD(*), ZQD(*), TQD(*) REAL TIN(895), HMN(895), HAN(895), VMN(895), VAN(895) REAL TIS(21), HMS(21), HAS(21), VMS(21), VAS(21) INTEGER INDX(*), ITYP(*), IDEC(*), IHYD(*), IERR(*) LOGICAL LL, LU COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C NORMALIZATION CONSTANTS: DATA TIS /8.,8.,7.,6.,6.,5.,15*5./ DATA HMS /8*7.,8.,9.,10.,10.,11.,11.,12.,6*13./ DATA HAS /4*4.,8*5.,3*6.,6*7./ DATA VMS /21*2./ DATA VAS /21*2./ DATA STDLIMIT /3.0/, HYDLIMIT /15./ DATA CP /1004.5/ C SET TNEW TO PRESENT TEMPERATUE VALUES. C INITIALIZE IERR TO NO ERROR. DO I=1,NUM TNEW(I) = TTRY(I) IERR(I) = 0 ENDDO C NORMALIZE VALUES. IF( NUM.LT.2 ) RETURN II = INDX(I1) DO I=2,NUM-1 TIN(I) = ABS(TI(I)/TIS(II)) HMN(I) = ABS(HM(I)/HMS(II)) HAN(I) = ABS(HA(I)/HAS(II)) VMN(I) = ABS(VM(I)/VMS(II)) VAN(I) = ABS(VA(I)/VAS(II)) ENDDO C LOOP THROUGH LEVELS BETWEEN PAIR OF COMPLETE MANDATORY C LEVELS, FINDING PROVISIONAL CORRECTIONS WHERE NEEDED AND C IF POSSIBLE. LEV1 = 2 IF(P(1).EQ.P(2)) LEV1 = 3 LEV2 = NUM-1 IF(P(NUM).EQ.P(NUM-1)) LEV2 = NUM-2 DO LEVEL=LEV1,LEV2 I = I1 + LEVEL - 1 IF(ITYP(LEVEL).NE.0 & .OR. (ITYP(LEVEL).EQ.0 & .AND. TI(LEVEL).GT.VMAX(2) & .AND. VM(LEVEL).GT.VMAX(2))) THEN C RETAIN ORIGINAL FLAG. ELSEIF(ITYP(LEVEL).EQ.0 & .AND. (TIN(LEVEL).LT.STDLIMIT & .OR. TI(LEVEL).GT.VMAX(2)) & .AND. (VMN(LEVEL).LT.STDLIMIT & .OR. VM(LEVEL).GT.VMAX(2))) THEN C NO ERROR OR TI AND VM MISSING. TQD(LEVEL) = 1. ELSE IF( HAN(LEVEL).GT.STDLIMIT & .AND. HAN(LEVEL).LT.VMAX(1)) THEN C ATTEMPT A CORRECTION. C TYPE 502, 503 OR 505 ASSIGNED. CALL SIGTCH(TI(LEVEL),VM(LEVEL),TSTAR(LEVEL), & VA(LEVEL),T(LEVEL),TNEW(LEVEL), & IDEC(LEVEL),IERR(LEVEL),TQD(LEVEL), & TTRY(LEVEL)) C CHECK LAPSE RATES BELOW AND ABOVE FOR TNEW. C GET PREVIOUS LEVEL WITH TEMPERATURE AND TEST. INIT = LEVEL - 1 IF(INIT.GE.1) THEN CALL PRVTEMP(INIT,LEVEL,ITYP,IDEC,P,1,LLOW) ELSE LLOW = 0 ENDIF IF(LLOW.GE.1) & CALL SUPER(T(LLOW),TNEW(LEVEL),P(LLOW),P(LEVEL), & 1,OVER,LL,IER) C GET NEXT LEVEL WITH TEMPERATURE AND TEST. INIT = LEVEL + 1 IF(INIT.LE.NUM) THEN CALL NEXTEMP(INIT,LEVEL,ITYP,IDEC,P,NUM,LUP) ELSE LUP = NUM + 1 ENDIF IF(LUP.LE.NUM) & CALL SUPER(TNEW(LEVEL),T(LUP),P(LEVEL),P(LUP), & 1,OVER,LU,IER) IF( LL .OR. LU ) THEN C SUPERADIABATIC LAPSE FOUND FOR CORRECTION. C RESTORE ORIGINAL TEMPERATURE AND FLAG BAD. IERR(LEVEL) = 506 TTRY(LEVEL) = TNEW(LEVEL) TNEW(LEVEL) = T(LEVEL) IDEC(LEVEL) = 4 TQD(LEVEL) = 13. ENDIF ELSE C CHECK LAPSE RATES BELOW AND ABOVE. C ALLOW 'OVER' TIMES ADIABATIC LAPSE RATE. OVER = 1.1 C GET PREVIOUS LEVEL WITH TEMPERATURE AND TEST. INIT = LEVEL - 1 IF(INIT.GE.1) THEN CALL PRVTEMP(INIT,LEVEL,ITYP,IDEC,P,1,LLOW) ELSE LLOW = 0 ENDIF IF(LLOW.GE.1) & CALL SUPER(T(LLOW),T(LEVEL),P(LLOW),P(LEVEL), & 1,OVER,LL,IER) C GET NEXT LEVEL WITH TEMPERATURE AND TEST. INIT = LEVEL + 1 IF(INIT.LE.NUM) THEN CALL NEXTEMP(INIT,LEVEL,ITYP,IDEC,P,NUM,LUP) ELSE LUP = NUM + 1 ENDIF C WRITE(6,500) LEVEL,LLOW,LUP 500 FORMAT(' DMASIG--LEVEL,LLOW,LUP:',3I6) IF(LUP.LE.NUM) & CALL SUPER(T(LEVEL),T(LUP),P(LEVEL),P(LUP), & 1,OVER,LU,IER) IF(LL .OR. LU) THEN C RESIDUAL(S) ARE LARGE AND LAPSE RATE IS C SUPERADIABATIC--- C FLAG DATA AS BAD, TYPE 501. IERR(LEVEL) = 501 IDEC(LEVEL) = 4 TQD(LEVEL) = 13. ELSE C LAPSE RATES ARE OK. RETAIN DATA WITH 'GOOD' FLAG. IERR(LEVEL) = 500 IDEC(LEVEL) = 0 TQD(LEVEL) = 1. ENDIF ENDIF ENDIF ENDDO C CHECK CHANGES FOR CONSISTENCY. C WERE THERE ANY CHANGES? NUMCHANGES = 0 DO LEVEL=2,NUM-1 IF( IERR(LEVEL).EQ.502 ) THEN NUMCHANGES = NUMCHANGES + 1 ENDIF ENDDO IF(NUMCHANGES.NE.0) THEN C RECOMPUTE THE HYDROSTATIC RESIDUAL, USING ALL LEVELS C AND NEW TEMPERATURES. ROG = R/G SA = Z(NUM) - Z(1) XP1 = XP(1) DO I=1,NUM-1 IF(T(I+1).LT.VMAX(2)) THEN XP2 = XP(I+1) SA = SA + ROG*(T0 + .5*(TNEW(I)+TNEW(I+1))) * (XP2-XP1) XP1 = XP2 ENDIF ENDDO C TEST TO SEE IF THE NEW HYDROSTATIC RESIDUAL IS SMALL. IF(ABS(SA).LT.HYDLIMIT .OR. & ABS(SA).LE.ABS(HM(LEVEL)) .OR. & HM(LEVEL).GT.VMAX(1)) THEN C ACCEPT CHANGES, RESET HA TO NEW VALUE. DO I=2,NUM-2 HA(I) = SA ENDDO ELSE C RESTORE ORIGINAL VALUES. DO LEVEL=2,NUM-1 TNEW(LEVEL) = T(LEVEL) IF( IERR(LEVEL).EQ.502 ) THEN IERR(LEVEL) = 504 IF((ABS(TI(LEVEL)).GT.2.0*DTALL & .AND. TI(LEVEL).LT.VMAX(2)) .OR. & (ABS(VM(LEVEL)).GT.2.0*DTALL & .AND. VM(LEVEL).LT.VMAX(2))) THEN IDEC(LEVEL) = 4 TQD(LEVEL) = 13. ELSE IDEC(LEVEL) = 3 TQD(LEVEL) = 3. ENDIF ENDIF ENDDO ENDIF ENDIF RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DRCTSL C PRGMMR: WOOLLEN ORG: NMC22 DATE: 90-11-06 C C ABSTRACT: DRIVER FOR CHOLESKY TYPE LINEAR EQUATION SOLVER. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN C C USAGE: C INPUT ARGUMENTS: C FAALL - ARRAY OF SYMMETRIC MATRIXES C RAALL - ARRAY OF MATRIX RIGHT HAND SIDES C NDIM - ARRAY OF MATRIX RANKS C MAXDIM - MAXIMUM RANK MATRIX IN MATRIX ARRAY C NXXYY - NUMBER OF MATRIXES IN MATRIX ARRAY C NFT - NUMBER OF RIGHT HAND SIDE VECTORS PER MATRIX C OUTPUT ARGUMENTS: C RAALL - ARRAY OF MATRIX SOLUTIONS C DOTPRD - ARRAY OF DOT PRODUCTS OF RHS VECTORS WITH MATRIX C SOLUTIONS C C SUBPROGRAMS CALLED: C UNIQUE: - VSOLVE C C REMARKS: ILL CONDITIONED OR NON POSITIVE DEFINITE MATRIXES ARE C IDENTIFIED BY DOT PRODUCTS GT 1 OR LT 0 OR BY A MESSAGE C FROM VSOLVE. FIVE ATTEMPTS ARE MADE TO SOLVE BAD ONES, C BY RIDGE REGRESSION, AFTER WHICH A NULL SOLUTION IS RETURNED. C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ C----------------------------------------------------------------------- SUBROUTINE DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT,LEV,IV) DIMENSION FAALL(1000,10), DOTPRD(1000,1), . RAALL(1000,4,1), NDIM(1000) DIMENSION A(1000,10),B(1000,4,1),BAD(1000),SMOOTH(6) LOGICAL BAD DATA SMOOTH /1.00,1.01,1.02,1.05,1.10,2.00/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- C LOOP FOR POSSIBILITY OF BAD MATRIXS C ----------------------------------- DO 50 ITRY=1,6 NBAD = 0 C INITIALIZE THE WORKING ARRAYS C ----------------------------- DO 10 J=1,MAXDIM*(MAXDIM+1)/2 DO 10 I=1,NXXYY 10 A(I,J) = FAALL(I,J) DO 11 K=1,NFT DO 11 J=1,MAXDIM DO 11 I=1,NXXYY 11 B(I,J,K) = RAALL(I,J,K) DO 12 J=1,NFT DO 12 I=1,NXXYY 12 DOTPRD(I,J) = 0. DO 13 J=1,MAXDIM JJ = J*(J+1)/2 DO 13 I=1,NXXYY 13 A(I,JJ) = FAALL(I,JJ)*SMOOTH(ITRY) C CALL THE MATRIX SOLVER C ---------------------- CALL VSOLVE (A,B,NDIM,BAD,NFT,NXXYY,MAXDIM) C MAKE THE DOT PRODUCTS OF SOLUTIONS WITH RIGHT HAND SIDES C -------------------------------------------------------- DO 20 K=1,NFT DO 20 J=1,MAXDIM DO 20 I=1,NXXYY DOTPRD(I,K) = DOTPRD(I,K) + RAALL(I,J,K)*B(I,J,K) 20 CONTINUE DO 25 K=1,NFT DO 25 I=1,NXXYY IF(DOTPRD(I,K).GT.1.)THEN DO 24 J=1,MAXDIM B(I,J,K) = B(I,J,K)/DOTPRD(I,K) 24 CONTINUE DOTPRD(I,K) = 1. ENDIF 25 CONTINUE C CHECK FOR BAD ONES - DO IT AGAIN IF NECESSARY C --------------------------------------------- DO 30 J=1,NFT DO 30 I=1,NXXYY BAD(I) = BAD(I) .OR. DOTPRD(I,J).LT.0. .OR. DOTPRD(I,J).GT.1. 30 CONTINUE DO 40 I=1,NXXYY IF(BAD(I)) THEN DO 35 K=1,NFT DOTPRD(I,K) = 0. DO 35 J=1,MAXDIM B(I,J,K) = 0. 35 CONTINUE NBAD = NBAD + 1 ENDIF 40 CONTINUE IF(NBAD.NE.0) THEN PRINT*, 'NBAD=',NBAD,' ON TRY ',ITRY . , ' LEV=',LEV,' IV=',IV ELSE GOTO 55 ENDIF 50 CONTINUE C COPY SOLUTIONS INTO OUTPUT ARRAY - ZERO BAD ONES OUT C ---------------------------------------------------- 55 DO 60 K=1,NFT DO 60 J=1,MAXDIM DO 60 I=1,NXXYY RAALL(I,J,K) = B(I,J,K) 60 CONTINUE RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EVENT WRITE AN EVENT. C PRGMMR: J. WOOLLEN ORG: W/NMC20 DATE: 94-MM-DD C C ABSTRACT: COMPUTE EXPANSION FACTOR FOR CORECT. C C PROGRAM HISTORY LOG: C 94-MM-DD J. WOOLLEN C C USAGE: CALL EVENT(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) C INPUT ARGUMENT LIST: C LUNIT - UNIT NUMBER C EVNSTR - EVENT STREAM OF CHARACTERS C NLV - NUMBER OF LEVELS C OBS - OBSERVED VALUE C QMS - QUALITY MARKER C RCS - REASON CODE C IND - INDIRECT ADDRESS OF VALUE C NEVN - NUMBER OF EVENTS C QCPC - PROGRAM CODE C C OUTPUT ARGUMENT LIST: C NONE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE EVENT(LUNIT,EVNSTR,NLV,OBS,QMS,RCS,IND,NEVN,QCPC) CHARACTER*(*) EVNSTR DIMENSION OBS(NEVN),QMS(NEVN),RCS(NEVN),IND(NEVN) DIMENSION EVNS(4,895) DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(NEVN.EQ.0) RETURN C CLEAR THE UFB ARRAY FIRST C ------------------------- C-CRA EVNS = BMISS EVNS = BMISS C DO IJ=1,4*895 C EVNS(IJ,1) = BMISS C ENDDO C TRANSFER EVENT ARRAYS INTO UFB ARRAY C ------------------------------------ DO I=1,NEVN J = IND(I) IF(OBS(I).LT.BMISS) THEN EVNS(1,J) = OBS(I) EVNS(2,J) = QMS(I) EVNS(3,J) = QCPC EVNS(4,J) = RCS(I) ENDIF ENDDO C WRITE THE EVENTS AND EXIT C ------------------------- CALL UFBINT(LUNIT,EVNS,4,NLV,IRET,EVNSTR) RETURN END C**************************************************** FUNCTION EXFACT(X,XBIG,X1,X2,EX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: EXFACT COMPUTE EXPANSION FACTOR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: COMPUTE EXPANSION FACTOR FOR CORECT. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL EXFACT(X, XBIG, X1, X2, EX) C INPUT ARGUMENT LIST: C XBIG - SCALING PARAMETER C X1,X2,EX - PARAMETERS C CC OUTPUT ARGUMENT LIST: C X - FACTOR C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ FFACT = X2 * ABS(X) / XBIG IF(FFACT.LE.1.) THEN EXFACT = 1.0 ELSE EXFACT = 1.0 + X1 * ALOG10(FFACT)**EX ENDIF RETURN END C***************************************************** SUBROUTINE FINDH(L1,L2,L3,L4,Z,T,M) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FINDH FIND LEVELS FOR TEMPLATE. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: FIND FOUR LEVELS FOR TEMPLATE WITH BOTH Z AND T NONMISSING. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL FINDL(L1, L2, L3, L4, Z, T, M) C INPUT ARGUMENT LIST: C L2 - GIVEN LEVEL C Z - HEIGHT (M) C T - TEMPERATURE (C) C M - LEVELS OF Z,T TO SEARCH C C OUTPUT ARGUMENT LIST: C L1,L3,L4 - LEVEL BELOW AND LEVELS ABOVE WHERE Z,T ARE NOT MISSING C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C LEVEL L2 IS GIVEN. C FIND LEVEL L1 BELOW AND LEVELS L3,L4 ABOVE, C IF THEY EXIST, WHERE Z,T ARE NOT MISSING. C M IS THE HIGHEST LEVEL TO SEARCH IN Z,T. C REAL Z(99), T(99) COMMON /MSGS/ VMAX(2),VMSG(2) DATA LMSG /99/ L2M = L2 - 1 L2P = L2 + 1 MM = M - 1 L1 = LMSG L3 = LMSG L4 = LMSG IF(L2.GT.1) THEN DO 10 L=1,L2M LL = L2 - L IF(ABS(Z(LL)).LT.VMAX(1) & .AND.ABS(T(LL)).LT.VMAX(2)) THEN L1 = LL GO TO 12 ENDIF 10 CONTINUE ENDIF 12 CONTINUE IF(L2.LT.M) THEN DO 20 L=L2P,M IF(ABS(Z(L)).LT.VMAX(1) & .AND.ABS(T(L)).LT.VMAX(2)) THEN L3 = L GO TO 22 ENDIF 20 CONTINUE ENDIF 22 CONTINUE L3P = L3 + 1 IF(L3.LT.M) THEN DO 30 L=L3P,M IF(ABS(Z(L)).LT.VMAX(1) & .AND.ABS(T(L)).LT.VMAX(2)) THEN L4 = L GO TO 32 ENDIF 30 CONTINUE ENDIF 32 CONTINUE RETURN END C***************************************************** SUBROUTINE FINDL(L1,L2,L3,L4,V,IV,M) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FINDL FIND LEVELS FOR TEMPLATE. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: FIND FOUR LEVELS FOR TEMPLATE. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL FINDL(L1, L2, L3, L4, V, IV, M) C INPUT ARGUMENT LIST: C L2 - GIVEN LEVEL C V - VARIABLE C IV = 1 FOR HEIGHT C = 2 FOR TEMPERATURE C M - LEVELS OF V TO SEARCH C C OUTPUT ARGUMENT LIST: C L1,L3,L4 - LEVEL BELOW AND LEVELS ABOVE WHERE V IS NOT MISSING C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C LEVEL L2 IS GIVEN. C FIND LEVEL L1 BELOW AND LEVELS L3,L4 ABOVE, C IF THEY EXIST, WHERE V IS NOT MISSING. C M IS THE HIGHEST LEVEL TO SEARCH IN V. C IV = 1 FOR Z, IV = 2 FOR T. C REAL V(21) COMMON /MSGS/ VMAX(2),VMSG(2) DATA LMSG /99/ L2M = L2 - 1 L2P = L2 + 1 MM = M - 1 L1 = LMSG L3 = LMSG L4 = LMSG IF(L2.GT.1) THEN DO 10 L=1,L2M LL = L2 - L IF(ABS(V(LL)).LT.VMAX(IV)) THEN L1 = LL GO TO 12 ENDIF 10 CONTINUE ENDIF 12 CONTINUE IF(L2.LT.M) THEN DO 20 L=L2P,M IF(ABS(V(L)).LT.VMAX(IV)) THEN L3 = L GO TO 22 ENDIF 20 CONTINUE ENDIF 22 CONTINUE L3P = L3 + 1 IF(L3.LT.M) THEN DO 30 L=L3P,M IF(ABS(V(L)).LT.VMAX(IV)) THEN L4 = L GO TO 32 ENDIF 30 CONTINUE ENDIF 32 CONTINUE RETURN END C************************************************************** SUBROUTINE FIRST(LAST,Z,T,ZL1,ZL2,ZL3,ZL4,TL1,TL2,TL3, & TL4,L1,L2,L3,L4,NLEV,IER) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FNLEV FIND FIRST 3 LEVELS OF DATA TO PROCESS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: WORKING UPWARD IN RADIOSONDE PROFILE OF MANDATORY C LEVELS, FIND THE FIRST 3 LEVELS TO HYDROSTATICALLY CHECK. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL FIRST(LAST, Z, T, ZL1, ZL2, ZL3, ZL4, TL1, C TL2, TL3, TL4, L1, L2, L3, L4, NLEV, IER) C INPUT ARGUMENT LIST: C LAST - =0 C Z - PROFILE OF MANDATORY HEIGHTS (METERS) C T - PROFILE OF MANDATORY TEMPS (CELCIUS) C C OUTPUT ARGUMENT LIST: C LAST - NEXT LOWEST OF 3 COMPLETE LEVELS C ZL1...ZL4- LEVEL HEIGHTS (METERS) C TL1...TL4- LEVEL TEMPERSTURES (CELCIUS) C L1...L4 - LEVELS C NLEV - NUMBER OF LEVELS OF Z, T. C IER - 0 3 MORE COMPLETE LEVELS FOUND C - 1 LESS THAN 3 MORE COMPLETE LEVELS FOUND C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ DIMENSION Z(99), T(99), ZL(4), TL(4) INTEGER L(4) COMMON /MSGS/ VMAX(2),VMSG(2) DATA LMSG /99/ IER = 0 DO 5 I=1,4 L(I) = LMSG ZL(I) = VMSG(1) TL(I) = VMSG(2) 5 CONTINUE LL = LAST + 1 DO 30 I=1,3 DO 20 J=LL,NLEV JJ = J IF(Z(J).LT.VMAX(1).AND.T(J).LT.VMAX(2)) GO TO 25 20 CONTINUE IF(I.LE.3) IER = 1 GO TO 40 25 CONTINUE ZL(I+1) = Z(JJ) TL(I+1) = T(JJ) L(I+1) = JJ IF(I.EQ.1) LAST = JJ LL = JJ + 1 30 CONTINUE 40 CONTINUE L1 = L(1) L2 = L(2) L3 = L(3) L4 = L(4) ZL1 = ZL(1) ZL2 = ZL(2) ZL3 = ZL(3) ZL4 = ZL(4) TL1 = TL(1) TL2 = TL(2) TL3 = TL(3) TL4 = TL(4) RETURN END C*************************************************************** SUBROUTINE FNLEV(LAST,Z,T,ZL1,ZL2,ZL3,ZL4,TL1,TL2,TL3, & TL4,L1,L2,L3,L4,NLEV,IER) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FNLEV FIND NEXT LEVELS OF DATA TO PROCESS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: WORKING UPWARD IN RADIOSONDE PROFILE OF MANDATORY C LEVELS, FIND THE NEXT LEVELS TO HYDROSTATICALLY CHECK. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL FNLEV(LAST, Z, T, ZL1, ZL2, ZL3, ZL4, TL1, C TL2, TL3, TL4, L1, L2, L3, L4, NLEV, IER) C INPUT ARGUMENT LIST: C LAST - LOWEST OF LAST LEVELS FOUND C Z - PROFILE OF MANDATORY HEIGHTS (METERS) C T - PROFILE OF MANDATORY TEMPS (CELCIUS) C C OUTPUT ARGUMENT LIST: C LAST - NEXT LOWEST OF 4 COMPLETE LEVELS C ZL1...ZL4- LEVEL HEIGHTS (METERS) C TL1...TL4- LEVEL TEMPERSTURES (CELCIUS) C L1...L4 - LEVELS C NLEV - NUMBER OF LEVELS OF Z, T. C IER - 0 4 MORE COMPLETE LEVELS FOUND C - 1 LESS THAN 4 MORE COMPLETE LEVELS FOUND C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ REAL Z(99), T(99), ZL(4), TL(4) INTEGER L(4) COMMON /MSGS/ VMAX(2),VMSG(2) DATA LMSG /99/ IER = 0 DO 5 I=1,4 L(I) = LMSG ZL(I) = VMSG(1) TL(I) = VMSG(2) 5 CONTINUE LL = LAST + 1 DO 30 I=1,4 DO 20 J=LL,NLEV JJ = J IF(Z(J).LT.VMAX(1).AND.T(J).LT.VMAX(2)) GO TO 25 20 CONTINUE IER = 1 GO TO 40 25 CONTINUE ZL(I) = Z(JJ) TL(I) = T(JJ) L(I) = JJ IF(I.EQ.1) LAST = JJ LL = JJ + 1 30 CONTINUE 40 CONTINUE L1 = L(1) L2 = L(2) L3 = L(3) L4 = L(4) ZL1 = ZL(1) ZL2 = ZL(2) ZL3 = ZL(3) ZL4 = ZL(4) TL1 = TL(1) TL2 = TL(2) TL3 = TL(3) TL4 = TL(4) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FULL FILL IN 'FULL' ARRAYS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: COMBINE THE SIGNIFICANT LEVEL AND MANDATORY LEVEL DATA C INTO SINGLE ARRAYS FOR PRESSURE, HEIGHT AND TEMPERATURE. THESE C COMBINED ARRAYS ARE USED IN COMPUTATION OF RESIDUALS. ALSO C DETERMINED ARE AUXILIARY INDICES THAT HELP IN THESE C COMPUTATIONS. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C 94-11-28 W. COLLINS USE BUFR QUALITY MARKS C C USAGE: CALL FULL(IDENT,HOUR,P,ZS,T,CFLAG,NSIG,PM,ZM,TM,JFLAG,MAN, C PC,XPC,ZC,TC,CFLAGC,MC,INDX,ITYP,TTRYC) C INPUT ARGUMENT LIST: C IDENT - STATION IDENTIFIER C HOUR - OBSERVATION HOUR (HOURS GMT) C ZS - STATION ELEVATION (M) C T - SIGNIFICANT LEVEL TEMPERATURE (C) C PPQ - SIG LVL PRESSURE QUALITY MARK (TABLE VALUE) C ZZQ - SIG LVL HEIGHT QUALITY MARK (TABLE VALUE) C TTQ - SIG LVL TEMPERATURE QUALITY MARK (TABLE VALUE) C NSIG - NUMBER OF SIGNIFICANT LEVELS C PM - MANDATORY LEVEL PRESSURES (HPA) C ZM - MANDATORY LEVEL HEIGHTS (M) C TM - MANDATORY LEVEL TEMPERATURES (C) C PMQ - MAND LVL PRESSURE QUALITY MARK (TABLE VALUE) C ZMQ - MAND LVL HEIGHT QUALITY MARK (TABLE VALUE) C TMQ - MAND LVL TEMPERATURE QUALITY MARK (TABLE VALUE) C MAN - NUMBER OF MANDATORY LEVELS C C OUTPUT ARGUMENT LIST: C PC - COMBINED PRESSURE (HPA) C XPC - NATURAL LOG OF PC C ZC - COMBINED HEIGHTS (M) C TC - COMBINED TEMPERATURE (C) C TNEWC - COMBINED TEMPERATURE (C) C CFLAGS - COMBINED FLAGS C MC - NUMBER OF COMBINED LEVELS C INDX - INDEX OF LEVEL FROM WHICH DATA CAME C ITYP - TYPE OF LEVEL C = 0 SIGNIFICANT LEVEL C = 1 SURFACE DATA WITH (Z,T) GOOD C = 2 MANDATORY LEVEL WITH (Z,T) GOOD C = 3 MANDATORY LEVEL WITH (T) GOOD C = 4 MANDATORY LEVEL WITH (Z) GOOD C OR SURFACE DATA WITH (Z) GOOD C = 5 MANDATORY LEVEL WITH DAT MSG OR NOT GOOD C TTRYC - TRIAL TEMPERATURE (C) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ SUBROUTINE FULL(IDENT,HOUR,P,ZS,T,PPQ,ZZQ,TTQ,NSIG, & PM,ZM,TM,PMQ,ZMQ,TMQ,MAN, & PC,XPC,ZC,TC,TNEWC,PQC,ZQC,TQC,MC,INDX,ITYP,TTRYC) REAL P(*), ZS, T(*), PM(*), ZM(*), TM(*), PC(*), & XPC(*), ZC(*), TC(*), WKSP(895), TTRYC(*), TNEWC(*), & PMQ(21), ZMQ(21), TMQ(21), PPQ(895), ZZQ(895), TTQ(895), & ZQC(895), TQC(895), PQC(895) INTEGER NSIG, MAN, INDX(*), ITYP(*), & IWKSP(895) C-MK & IWKSP(895), NEVNTI(2) CHARACTER*8 NEVNTC, TFLAG(99) LOGICAL LZGOOD, LTGOOD, LTYP2, LTYP3, LTYP4 COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) INTEGER*8 NEVNTI(2) EQUIVALENCE (NEVNTI,NEVNTC) C COMBINE ARRAYS. MANDATORY LEVELS FIRST. DO K=1,MAN INDX(K) = K PC(K) = PM(K) IF(PC(K).LT.VMAX(1).AND.PC(K).GT.0.) THEN XPC(K) = ALOG(PC(K)) ELSE XPC(K) = VMSG(1) ENDIF TC(K) = TM(K) TTRYC(K) = TM(K) ZC(K) = ZM(K) PQC(K) = PMQ(K) ZQC(K) = ZMQ(K) TQC(K) = TMQ(K) C SEE IF HEIGHT AND TEMPERATURE ARE 'GOOD'. C LOOK FOR MATCHES OF STATION, TIME, LEVEL AND VARIABLE C WITHIN THE EVENTS FILE. LZGOOD = .TRUE. LTGOOD = .TRUE. DO 50 J=1,IR IF(NEVNT(21,J).NE.IDENT .OR. DHOUR(J).NE.HOUR) GO TO 50 C RIGHT STATION AND TIME... CALL UNPACK(NEVNT(7,J),IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) CALL UNPCK2(NEVNT(6,J),IV,LEV,ISCAN,IDECSN) IF(LEV.EQ.K) THEN C RIGHT LEVEL... IF(IV.EQ.1) THEN IF(IDECSN.LE.2) THEN LZGOOD = .TRUE. ELSE LZGOOD = .FALSE. ENDIF ENDIF IF(IV.EQ.2) THEN IF(IDECSN.LE.2) THEN LTGOOD = .TRUE. ELSE LTGOOD = .FALSE. ENDIF ENDIF ENDIF 50 CONTINUE C ADDITIONAL TESTS BASED UPON PRIOR QUALITY MARKS. IF(ZQC(K).GT.2) LZGOOD = .FALSE. IF(TQC(K).GT.2) LTGOOD = .FALSE. LTYP2 = LTGOOD .AND. LZGOOD & .AND. (TC(K).LT.VMAX(2)) & .AND. (ZC(K).LT.VMAX(1)) LTYP3 = LTGOOD .AND. (TC(K).LT.VMAX(2)) LTYP4 = LZGOOD .AND. (ZC(K).LT.VMAX(1)) IF( LTYP2 ) THEN ITYP(K) = 2 ELSEIF( LTYP3 ) THEN ITYP(K) = 3 ELSEIF( LTYP4 ) THEN ITYP(K) = 4 ELSE ITYP(K) = 5 ENDIF ENDDO C NOW SIGNIFICANT LEVELS. DO I=1,NSIG K = I+MAN INDX(K) = I PC(K) = P(I) TC(K) = T(I) TTRYC(K) = T(I) ZQC(K) = ZZQ(I) TQC(K) = TTQ(I) PQC(K) = PPQ(I) IF(PC(K).GT.0..AND.PC(K).LT.VMAX(1)) THEN XPC(K) = ALOG(PC(K)) ELSE XPC(K) = VMSG(1) ENDIF IF(I.EQ.1) THEN ZC(K) = ZS IF(TC(K).LT.VMAX(2)) THEN ITYP(K) = 1 ELSE ITYP(K) = 4 ENDIF ELSE ITYP(K) = 0 ZC(K) = VMSG(1) ENDIF ENDDO MC = MAN + NSIG C INITIALIZE TNEWC. DO I=1,MC TNEWC(I) = TC(I) ENDDO C SORT COMBINED ARRAYS PC,TC,ZC,INDX AND ITYP ACCORDING TO C DESCENDING PC. C WRITE(6,500) 500 FORMAT(' FULL--PC,XPC,TC,TTRYC,ZC,INDX,ITYP,PQC,ZQC,TQC', & ' (BEFORE SORT):') C WRITE(6,501) (PC(I),XPC(I),TC(I),TTRYC(I),ZC(I),INDX(I), C & ITYP(I),PQC(I),ZQC(I),TQC(I),I=1,MC) 501 FORMAT(7X,F7.0,1X,F7.2,1X,F7.1,1X,F7.1,1X,F7.0,1X,I5,1X, & I5,1X,3F4.0) IREV = 1 CALL SHELL(PC ,IWKSP,MC,IREV) CALL SORT(XPC ,IWKSP,MC) CALL SORT(TC ,IWKSP,MC) CALL SORT(TTRYC ,IWKSP,MC) CALL SORT(ZC ,IWKSP,MC) CALL ISORT(INDX ,IWKSP,MC) CALL ISORT(ITYP ,IWKSP,MC) CALL SORT(PQC ,IWKSP,MC) CALL SORT(ZQC ,IWKSP,MC) CALL SORT(TQC ,IWKSP,MC) C WRITE(6,502) 502 FORMAT(' FULL--PC,XPC,TC,TTRYC,ZC,INDX,ITYP,PQC,ZQC,TQC', & ' (AFTER SORT):') C WRITE(6,501) (PC(I),XPC(I),TC(I),TTRYC(I),ZC(I),INDX(I), C & ITYP(I),PQC(I),ZQC(I),TQC(I),I=1,MC) C DONE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GESTPS OBTAIN FIRST GUESS OF MEAN SEA LVL PRES C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-11-18 C C ABSTRACT: OBTAIN FIRST GUESS OF MEAN SEA LEVEL PRESSURE AT STATION C LOCATIONS. C C PROGRAM HISTORY LOG: C 91-11-18 W. COLLINS C C USAGE: CALL GESTPS(ZS) C C INPUT ARGUMENTS: C ZS - MODEL SURFACE ELEVATIONS AT OB LOCATIONS C C OUTPUT ARGUMENTS: C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE GESTPS C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / MANDP(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ MANDP(21) DATA RBOG / .19026/ DATA BB / -.0065/ DATA GORB /5.25597/ DATA BMISS / 10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C AT EACH STATION USE FIRST LEVEL ABOVE MODEL SURFACE TO COMPUTE MSLP C ------------------------------------------------------------------- DO 100 N=1,NOBS DO L=1,NLEV-1 IF(MANDP(L).LE.GESPS(N)) THEN P1 = MANDP(L ) P2 = MANDP(L+1) Z1 = GES(L ,1,N) Z2 = GES(L+1,1,N) GESPS(N) = BMISS IF(Z1.LT.BMISS .AND. Z2.LT.BMISS) THEN ZL = (Z1+Z2)*.5 AL = (P2/P1)**RBOG TL = -0.5*BB*(Z2-Z1)*(1.+AL)/(1.-AL) TB = TL-BB*ZL RD = 1.+BB*Z1/TB IF(RD.LT.0.) RD = 1. GESPS(N) = P1*RD**(-GORB) ENDIF GOTO 100 ENDIF ENDDO 100 ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GESSIG OBTAIN TEMPERATURE GUESS AT SIGMA LEVELS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 93-12-14 C C ABSTRACT: INTERPOLATE VERTICALLY FROM ALREADY OBTAINED MANDATORY C LEVEL TEMPERATURES TO SIGNIFICANT LEVELS. C C PROGRAM HISTORY LOG: C 93-12-14 W. COLLINS C C USAGE: CALL GESSIG(NSIG,P,TG,TMG) C INPUT ARGUMENT LIST: C NSIG - NUMBER OF SIGNIFICANT LEVELS C P - SIGNIFICANT LEVEL PRESSURES (HPA) C TMG - GUESS TEMPERATURES ON MAND LVLS (K) C C OUTPUT ARGUMENT LIST: C TG - GUESS TEMPERATURES ON SIG LVLS (K) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77, VERSION 2 C MACHINE: , CRAY (COMPATIBLE WITH CRAY) C C$$$ SUBROUTINE GESSIG(NSIG,P,TMG,TG) REAL P(*), TG(*), TMG(*) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) DO LSIG=1,NSIG TG(LSIG) = VMSG(2) IF(P(LSIG).GT.VMAX(1).OR.P(LSIG).LT.PMAND(NLEV)) GO TO 99 LEV = 1 DO WHILE(IPLVL(LEV).GE.P(LSIG).AND.LEV.LE.NLEV) LEV = LEV + 1 ENDDO LP = LEV C LP AND LP-1 SPAN P(LSIG), UNLESS LP=1. IF(LP.EQ.1) LP = 2 CP = (ALOG(P(LSIG))-PLOG(LP-1)) / (PLOG(LP)-PLOG(LP-1)) CM = 1. - CP TG(LSIG) = CM*TMG(LP-1) + CP*TMG(LP) C WRITE(6,500) LP,P(LSIG),TG(LSIG),CM,TMG(LP-1),CP,TMG(LP) 500 FORMAT(' GESSIG--LP,P,TG: ',I5,F6.0,F7.1,' CM,TMG(LP-1):', & F7.3,F7.1,' CP,TMG(LP): ',F7.3,F7.1) 99 CONTINUE ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: GETGES COPY TEMPERATURE GUESS AT SIGMA LEVELS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 93-12-14 C C ABSTRACT: COPY GUESS SAVED FOR ALL STATIONS TO ARRAY C FOR SINGLE STATION--AT MANDITORY LEVELS. C C PROGRAM HISTORY LOG: C 93-12-14 W. COLLINS C C USAGE: CALL GETGES(IDENT, ID, TGES, NOBS, NPLVL, TMG) C INPUT ARGUMENT LIST: C IDENT - STATION IDENTIFIER OF PRESENT STATION C ID - ARRAY OF ALL STN ID'S C TGES - GUESS TEMPERATURES ON MAND LVLS (K) C NOBS - NUMBER OF OBSERVATIONS C NPLVL - NUMBER OF PRESSURE LEVELS C C OUTPUT ARGUMENT LIST: C TMG - GUESS TEMPERATURES ON MAND LVLS (K) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77, VERSION 2 C MACHINE: , CRAY (COMPATIBLE WITH CRAY) C C$$$ SUBROUTINE GETGES(IDENT,ID,TGES,NOBS,NPLVL,TMG) COMMON /MSGS/ VMAX(2),VMSG(2) C GET THE STORED GES FOR THIS STATION. REAL TGES(21,899), TMG(*) LOGICAL LGESOK INTEGER ID(*) LGESOK = .FALSE. DO IS=1,NOBS IF(ID(IS).EQ.IDENT) THEN LGESOK = .TRUE. DO I=1,NPLVL TMG(I) = TGES(I,IS) ENDDO ENDIF ENDDO IF(.NOT.LGESOK) THEN WRITE(6,500) IDENT DO I=1,NPLVL TMG(I) = TGES(I,IS) ENDDO ENDIF 500 FORMAT(' TEMPERATURE (MAND LVL) GUESS NOT AVAILABLE FOR',I8) RETURN END C*********************************************************************** C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: HOI PERFORM HORIZONTAL ANALYSIS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM HORIZONTAL STATISTICAL ANALYSIS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-02-19 W. COLLINS MADE MORE EFFICIENT. C 92-11-24 J. WOOLLEN VECTORIZED FOR CRAY C C USAGE: CALL HOI C OUTPUT FILES: C FT06F001 - PRINT FOR ERROR CONDITION C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE HOI CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) CHARACTER*8 MSG COMMON /INIMSG/MSG DIMENSION DMAX(21,2) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(MSG.NE.'OKAY') CALL INTHOI C DO THE QC HORIZONTAL CHECK C -------------------------- DO 10 I=1,2 DO 10 L=1,NLEV DMAX(L,I) = XINC(L,I) * CCON 10 CONTINUE CALL SEARCH (21,2,NLEV,2,1,NOBS,IDH,OINC,DMAX) CALL QCOI (21,2,NLEV,2,1,NOBS,IDH,OINC,HINC,HSTD,WTH) C HORIZONTAL CHECK FLAGS C ---------------------- DO 80 LEV=1,NLEV DO 80 IV=1,2 DO 80 N=1,NOBS CALL UNPACK(NERR(LEV,IV,N,ISCAN),IINC,IHSC,IHOI, . IVOI,IBAS,IIPL,IHPL) IF(HINC(LEV,IV,N).LT.VMAX(IV)) THEN IHOI = MIN(2.*ABS(HINC(LEV,IV,N))/HOIRES(LEV,IV),2.) ELSE IHOI = 0 ENDIF CALL PACK (NERR(LEV,IV,N,ISCAN),IINC,IHSC,IHOI, . IVOI,IBAS,IIPL,IHPL) 80 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: HOIPS PERFORM HORIZONTAL ANALYSIS OF SFC PRESS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM HORIZONTAL STATISTICAL ANALYSIS OF SURFACE PRESSURE. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-11-24 J. WOOLLEN VECTORIZED FOR CRAY C C USAGE: CALL HOIPS C OUTPUT FILES: C FT06F001 - PRINT FOR ERROR CONDITION C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE HOIPS CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) DIMENSION HSTDPS(899),DMAX(1,1) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C PERFORM HORIZONTAL STATISTICAL CHECK FOR SURFACE PRESSURE C FOR STATIONS REPORTING 1000 AND 850MB HEIGHTS C --------------------------------------------- DMAX(1,1) = CCON * PSRES CALL SEARCH(1,1,1,1,1,NOBS,IDHPS,OINCPS,DMAX) CALL QCOI (1,1,1,1,1,NOBS,IDHPS,OINCPS,HINCPS,HSTDPS,WTHPS) C SQUIRREL AWAY THE DECISION C -------------------------- DO 50 N=1,NOBS IF(HINCPS(N).LT.VMAX(2)) THEN IHPL = MIN(2.*ABS(HINCPS(N))/PSRES,2.) ELSE IHPL = 0 ENDIF DO 50 L=1,NLEV DO 50 IV=1,2 CALL UNPACK(NERR(L,IV,N,ISCAN),IINC,IHSC,IHOI, . IVOI,IBAS,IIPL,IH) CALL PACK (NERR(L,IV,N,ISCAN),IINC,IHSC,IHOI, . IVOI,IBAS,IIPL,IHPL) 50 CONTINUE RETURN END C**************************************************************** SUBROUTINE HSC C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: HSC CALCULATE HYDROSTATIC RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CALCULATE HYDROSTATIC RESIDUALS. SAVE RESIDUALS, LAYER C LIMITS, NO. OF LAYERS, AND BSUM. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL HSC C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C CALCULATE HYDROSTATIC RESIDUALS. SAVE RESIDUALS, LAYER C LIMITS, NO. OF LAYERS AND BSUM. C REAL Z(99), T(99), RES(20), SB(20) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /MSGS/ VMAX(2),VMSG(2) NPLVLM = NPLVL - 1 DO 20 N=1,NOBS DO 4 L=1,NPLVLM RES(L) = VMSG(1) HYRES(L,N) = VMSG(1) SBIG(L,N) = VMSG(1) 4 CONTINUE MANN = MAN(N) DO 10 K=1,MANN Z(K) = OBS(K,1,N) T(K) = OBS(K,2,N) 10 CONTINUE CALL RESID(Z,T,MANN,RES,SB, & BSUM(1,N),ISL(1,N),ISU(1,N),KMAX(N)) KMAXN = KMAX(N) DO 15 K=1,KMAXN IUP = ISU(K,N) HYRES(IUP,N) = RES(K) SBIG(IUP,N) = SB(K) 15 CONTINUE 20 CONTINUE RETURN END C************************************************************* SUBROUTINE HSC1 C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: HSC1 CALCULATE HYDROSTATIC RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CALCULATE HYDROSTATIC RESIDUALS FOR CORRECTED FIELDS. C SAVE RESIDUALS, LAYER LIMITS, NO. OF LAYERS, AND BSUM. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL HSC1 C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C CALCULATE HYDROSTATIC RESIDUALS. SAVE RESIDUALS, LAYER C LIMITS, NO. OF LAYERS AND BSUM. C INTEGER LL(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /MSGS/ VMAX(2),VMSG(2) DATA LMSG /99/ C C UPDATE ZH, TH WITH CORRECTIONS. C IF(LZ1.EQ.LH1) ZH(1) = ZZC(1) IF(LT1.EQ.LH1) TH(1) = TTC(1) ZH(2) = ZZC(2) TH(2) = TTC(2) IF(LZ3.EQ.LH3) ZH(3) = ZZC(3) IF(LT3.EQ.LH3) TH(3) = TTC(3) IF(LZ4.EQ.LH3) ZH(3) = ZZC(4) IF(LT4.EQ.LH3) TH(3) = TTC(4) IF(LZ4.EQ.LH4) ZH(4) = ZZC(4) IF(LT4.EQ.LH4) TH(4) = TTC(4) LL(1) = LH1 LL(2) = L2 LL(3) = LH3 LL(4) = LH4 DO 10 L=1,3 CHYRES(L) = VMSG(1) 10 CONTINUE C C DO NOT COMPUTE RESIDUALS UNLESS Z,T ARE BOTH C AVAILABLE AT L2. C IF(ZH(2).GT.VMAX(1).OR.TH(2).GT.VMAX(2)) RETURN DO 20 L=1,3 IF(ZH(L).GT.VMAX(1) & .OR.TH(L).GT.VMAX(2) & .OR.ZH(L+1).GT.VMAX(1) & .OR.TH(L+1).GT.VMAX(2)) GO TO 20 ASUM = 0. CBSUM(L) = 0. KL = LL(L) KH = LL(L+1) IF(KL.EQ.LMSG.OR.KH.EQ.LMSG) GO TO 20 KHM = KH - 1 DO 15 K=KL,KHM ASUM = ASUM + A(K) CBSUM(L) = CBSUM(L) + B(K) 15 CONTINUE CHYRES(L) = ZH(L+1) - ZH(L) - ASUM - CBSUM(L) * & (TH(L) + TH(L+1)) 20 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: HYD CALCULATE HYDROSTATIC RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 93-03-09 C C ABSTRACT: CALCULATE HYDROSTATIC RESIDUALS, BOTH FOR MANDATORY C LEVEL DATA ALONE AND FOR ALL LEVELS. C C PROGRAM HISTORY LOG: C 93-11-24 W. COLLINS C C USAGE: CALL HYD(PC,XPC,TC,ZC,INDX,ITYP,MC,IDECC,IHYDC,HM,HA, C HMC,HAC) C C INPUT ARGUMENT LIST: C PC - PRESSURE (HPA) C XPC - NATURAL LOGARITHM OF COLLECTED PRESSURES (NON-DIMEN) C ZC - COMBINED HEIGHTS (M) C TC - COMBINED TEMPERATURES (C) C INDX - INDEX IN ORIGINAL ARRAYS FROM WHICH DATA COME C ITYP - TYPE OF DATA C = 0 SIGNIFICANT LEVEL DATA C = 1 SURFACE DATA C = 2 MANDATORY LEVEL DATA WITH Z, T NON-MISSING C = 3 MANDATORY LEVEL DATA WITH ONLY T NON-MISSING C = 4 MANDATORY LEVEL DATA WITH ONLY Z NON-MISSING C = 5 MANDATORY LEVEL DATA WITH Z, T MISSING C IDECC - DECISION C IHYDC - HYDROSTATIC ERROR TYPE C MC - NUMBER OF COMBINED LEVELS C C OUTPUT ARGUMENT LIST: C HMC - HYDROSTATIC RESIDUALS USING MANDATORY LEVEL C HEIGHTS AND TEMPERATURES, COMBINED LEVELS C HAC - HYDROSTATIC RESIDUALS USING MANDATORY LEVEL C HEIGHTS AND TEMPERATURES AND SIGNIFICANT LEVEL C TEMPERATURES, COMBINED LEVELS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE HYD(PC,XPC,TC,ZC,INDX,ITYP,MC,IDECC,HMC,HAC) REAL TC(*), PC(*), ZC(*), XPC(*), HMC(*), HAC(*) INTEGER INDX(*), ITYP(*), MC, IDECC(*) LOGICAL ISOK COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DATA DIFMAXXPC /.55/, DIFMAXPC /10./ C PURPOSE: C ROUTINE TO COMPUTE LAYER HYDROSTATIC RESIDUALS IN TWO WAYS: C 1) USING MANDATORY LEVEL HEIGHTS AND TEMPERATURES ONLY, AND C 2) USING MANDATORY LEVEL HEIGHTS AND TEMPERATURES AND SIGNIFICANT C LEVEL TEMPERATURES AND PRESSURES. THE SURFACE WILL BE TREATED AS C AN ADDITIONAL MANDATORY LEVEL IF ITS PRESSURE AND TEMPERATURE ARE C GIVEN. ANY MANDATORY LEVEL WITH HEIGHT MISSING IS TREATED AS A C SIGNIFICANT LEVEL AND A MANDATORY LEVEL WITH TEMPERATURE MISSING C IS TREATED AS COMPLETELY MISSING. C ANY QUESTIONABLE DATA ARE TREATED AS MISSING. C C THE VALUE ASSIGNED AT EACH SIGNIFICANT LEVEL IS THE VALUE C APPROPRIATE TO THE LAYER IN WHICH THE DATA IS FOUND. IF THE LAYER C BOUNDING DATA (HEIGHT AND TEMPERATURE) ARE NOT COMPLETE, THEN A C VALUE OF MISSING IS ASSIGNED FOR THE SIGNIFICANT LEVEL. ROG = R/G C INITIALIZE THE HYDROSTATIC RESIDUALS TO MISSING. DO I=1,NPLVL+NSLVL HMC(I) = VMSG(1) HAC(I) = VMSG(1) ENDDO C FIND THE FIRST (LOWEST) MANDATORY LEVEL WITH NON-MISSING C 'GOOD' HEIGHT AND TEMPERATURE. INIT = 1 CALL NEXMNZ(INIT,ITYP,IDECC,MC,I1) C RETURN IF THERE IS NO FIRST LEVEL FOUND (I1 = MC+1) C OR IF IT IS THE TOP LEVEL (I1 = MC). IF(I1.GE.MC) RETURN C FIND THE NEXT MANDATORY LEVEL. 10 CONTINUE INIT = I1+1 CALL NEXMNZ(INIT,ITYP,IDECC,MC,I2) IF(I2.GT.MC) THEN C NORMAL RETURN. RETURN ENDIF C SOLVE FOR THE LAYER HYDROSTATIC RESIDUALS. SA = VMSG(1) SM = VMSG(1) ISOK = .TRUE. IF(XPC(I1)-XPC(I2).GT.DIFMAXXPC .AND. & PC(I1)-PC(I2).GT.DIFMAXPC) ISOK = .FALSE. IF(ISOK .AND. I1+1.LE.I2-1) THEN SA = ZC(I2) - ZC(I1) SM = SA + ROG*(T0 + .5*(TC(I1)+TC(I2))) * (XPC(I2)-XPC(I1)) XPC1 = XPC(I1) TC1 = TC(I1) DO I=I1,I2-1 IF(TC(I+1).LT.VMAX(2)) THEN XPC2 = XPC(I+1) TC2 = TC(I+1) SA = SA + ROG*(T0 + .5*(TC1+TC2)) * (XPC2-XPC1) XPC1 = XPC2 TC1 = TC2 ENDIF ENDDO C ASSIGN SA AND SM TO VARIABLES HAC AND HMC AT C ALL LEVELS I1+1 TO I2-1. DO I=I1+1,I2-1 HAC(I) = SA HMC(I) = SM ENDDO ENDIF C CONTINUE UNTIL TOP IS REACHED. I1 = I2 GO TO 10 END C*************************************************************** SUBROUTINE INCR C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INCR FORM OBSERVED INCREMENTS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: FORM OBSERVED INCREMENTS (OBS-GUESS) C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL INCR C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C FORM OBSERVED INCREMENTS (OBS-GUESS). C C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) DO 30 IOB=1,NOBS C C FORM INCREMENT FOR SEA LEVEL PRESSURE C IF(ABS(PSL(IOB)).LT.VMAX(2). AND. IGES.EQ.0 & .AND.REDUC(IOB).NE.0. & .AND.ABS(GESPS(IOB)).LT.VMAX(2)) THEN OINCPS(IOB) = (PSL(IOB) - GESPS(IOB))/REDUC(IOB) ELSE OINCPS(IOB) = VMSG(1) ENDIF IF(ABS(OINCPS(IOB)).GT.500.) THEN IIPL = 0 ELSE IIPL = 2.*ABS(OINCPS(IOB)) / PSRES ENDIF IIPL = MIN(IIPL,2) DO IL=1,NLEV DO IV=1,2 IF(ABS(OBS(IL,IV,IOB)).GT.VMAX(IV).OR.IGES.NE.0) THEN OINC(IL,IV,IOB) = VMSG(IV) ELSE OINC(IL,IV,IOB) = OBS(IL,IV,IOB) - GES(IL,IV,IOB) ENDIF C C OBSERVED INCREMENT FLAG. C CALL UNPACK(NERR(IL,IV,IOB,ISCAN),IHSC,IINC,IHOI, & IVOI,IBAS,II,IHPL) IF(ABS(OINC(IL,IV,IOB)).GT.VMAX(IV)) THEN IINC = 0 ELSE IINC = 2. * ABS(OINC(IL,IV,IOB))/XINC(IL,IV) ENDIF IINC = MIN(IINC,2) CALL PACK(NERR(IL,IV,IOB,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) ENDDO ENDDO C C INITIALIZE UNUSED LEVELS. C NLEVP = NLEV + 1 DO IL=NLEVP,NPLVL DO IV=1,2 OINC(IL,IV,IOB) = VMSG(IV) ENDDO ENDDO 30 CONTINUE RETURN END C*********************************************************** SUBROUTINE INCR1(COINC,COB,GES,IV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INCR1 FORM OBSERVED INCREMENT FOR ONE POINT, LVL. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: FORM OBSERVED INCREMENTS (OBS-GUESS) FOR A SINGLE POINT C AND LEVEL. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL INCR1 C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C COMPUTE INCREMENT FOR A SINGLE POINT AND LEVEL. C COMMON /MSGS/ VMAX(2),VMSG(2) IF(ABS(COB).LT.VMAX(IV).AND.ABS(GES).LT.VMAX(IV)) THEN COINC = COB - GES ELSE COINC = VMSG(IV) ENDIF RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INTHOI GET READY FOR HORIZONTAL SEARCH C PRGMMR: J. WOOLLEN ORG: W/NMC22 DATE: 92-??-?? C C ABSTRACT: GET READY FOR HORIZONTAL SEARCH C C PROGRAM HISTORY LOG: C 92-??-?? J. WOOLLEN C C USAGE: CALL INTHOI C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE INTHOI CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /SERCH / RSCAN,DELLAT,DELLON(181) C-CRA COMMON /CORP /CHLP(0:1500),CVC,IFA(4,4) COMMON /CORP /CHLP(0:1500),CVC COMMON /CORPI/IFA(4,4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) CHARACTER*8 MSG COMMON /INIMSG/MSG DATA PI180/.0174532/, RADE/6371./, MAXDIM/4/ C--------------------------------------------------------------------- C--------------------------------------------------------------------- C MAKE THE OBSERVATION INDEX MAP C ------------------------------ CALL MIMAP(SLON,SLAT,NOBS) C SET UP THE SEARCH ARRAYS C ------------------------ RSCAN = 1000. DELLAT = RSCAN/(PI180*RADE) DO I=1,181 BLAT = I - 91 COSLAT = COS(BLAT*PI180) DELLON(I) = MIN(DELLAT/COSLAT,180.0) ENDDO C SYMMETRIC MATRIX STORAGE CHART C ------------------------------ IJ = 1 DO 10 I = 1,MAXDIM DO 10 J = 1,I IFA(I,J) = IJ IFA(J,I) = IJ IJ = IJ + 1 10 CONTINUE C MAKE A TABLE OF LENGTH SCALES BY MILIBARS C ----------------------------------------- DO 20 I=1,1500. CHLP(I) = 120. 20 CONTINUE CVC = 5.0 C SET HOI ARRAYS TO MISSING VALUES C -------------------------------- DO 30 NOB=1,NOBS HINCPS ( NOB) = VMSG(1) DO 30 IV =1,2 DO 30 LEV=1,NPLVL HINC (LEV,IV,NOB) = VMSG(IV) HSTD (LEV,IV,NOB) = VMSG(IV) DO 30 I=1,4 IDH (I,LEV,IV,NOB) = 0 WTH (I,LEV,IV,NOB) = VMSG(IV) IDHPS (I ,NOB) = 0 WTHPS (I ,NOB) = VMSG(IV) 30 CONTINUE C LET OTHERS KNOW WE HAVE BEEN HERE C --------------------------------- MSG = 'OKAY' RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ISOLAT GET LIST OF ISOLATED STATIONS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: GET LIST OF ISOLATED STATIONS. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL ISOLAT(ID) C INPUT ARGUMENT LIST: C ID - STATION IDENTIFIER C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE ISOLAT(ID) C C COLLECT LIST OF ISOLATED STATIONS. C THESE STATIONS HAD NO NEIGHBORS FOR HORIZONTAL CHECK. C COMMON /ISO/ IDISO(899), NUM DATA ISTART /0/ IF(ISTART.EQ.0) THEN DO I=1,899 IDISO(I) = 0 END DO ISTART = 1 NUM = 0 ENDIF C CHECK TO SEE IF ID IS ON THE LIST. DO I=1,NUM IF(ID.EQ.IDISO(I)) GO TO 10 END DO NUM = NUM + 1 IDISO(NUM) = ID 10 CONTINUE RETURN END C----------------------------------------------------------------------- FUNCTION MAN925(P) COMMON /LEV926/ ISET,MANLIN(1001) C DATA ISET /0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(ISET.EQ.0) THEN DO I=1,1001 MANLIN(I) = 0 IF(I.EQ.1000) MANLIN(I) = 1 IF(I.EQ. 925) MANLIN(I) = 2 IF(I.EQ. 850) MANLIN(I) = 3 IF(I.EQ. 700) MANLIN(I) = 4 IF(I.EQ. 500) MANLIN(I) = 5 IF(I.EQ. 400) MANLIN(I) = 6 IF(I.EQ. 300) MANLIN(I) = 7 IF(I.EQ. 250) MANLIN(I) = 8 IF(I.EQ. 200) MANLIN(I) = 9 IF(I.EQ. 150) MANLIN(I) = 10 IF(I.EQ. 100) MANLIN(I) = 11 IF(I.EQ. 70) MANLIN(I) = 12 IF(I.EQ. 50) MANLIN(I) = 13 IF(I.EQ. 30) MANLIN(I) = 14 IF(I.EQ. 20) MANLIN(I) = 15 IF(I.EQ. 10) MANLIN(I) = 16 IF(I.EQ. 7) MANLIN(I) = 17 IF(I.EQ. 5) MANLIN(I) = 18 IF(I.EQ. 3) MANLIN(I) = 19 IF(I.EQ. 2) MANLIN(I) = 20 IF(I.EQ. 1) MANLIN(I) = 21 ENDDO ISET = 1 ENDIF IP = NINT(P*10.) IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN MAN925 = 0 ELSE MAN925 = MANLIN(NINT(P)) ENDIF RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: LAPSE CHECK LAPSE RATES. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: C 1) SET UP ARRAYS CONTAINING DECISIONS AND ERROR TYPES C FOR MANDATORY LEVELS. C 2) CHECK LAPSE RATES AT MANDATORY LEVLES ONLY IF THE C TEMPERATUES WERE MODIFIED. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C 94-11-28 W. COLLINS USE BUFR QUALITY MARKS C C USAGE: CALL LAPSE(PC, XPC, TC, TMG, MC, INDX, ITYP, IDENT, C IDECC, IHYDC, PQC, ZQC, TQC) C INPUT ARGUMENT LIST: C PC - PRESSURE (HPA) C XPC - NATURAL LOG OF PRESSURE C TC - COLLECTED TEMPERATURES (C) C TMG - GUESS TEMP ON MAND SFC (C) C MC - NUMBER OF COLLECTED LEVELS C INDX - INDEX WITHIN ORIGINAL ARRAY C ITYP - LEVEL TYPE C IDENT - STATION ID C C OUTPUT ARGUMENT LIST: C IDECC - DECISION FOR COLLECTED LEVELS C IHYDC - HYDROSTATIC ERROR TYPE FOR COLLECTED LEVELS C PQC - PRESSURE QUALITY MARK (TABLE VALUE) C ZQC - HEIGHT QUALITY MARK (TABLE VALUE) C TQC - TEMPERATURE QUALITY MARK (TABLE VALUE) C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE LAPSE(PC,XPC,TC,TMG,MC,INDX,ITYP, & IDENT,HOUR,IDECC,IHYDC,PQC,ZQC,TQC) REAL XPC(*), TC(*), TMG(*), PQC(*), ZQC(*), TQC(*), PC(*) INTEGER IDECC(*), IHYDC(*), INDX(*), ITYP(*) LOGICAL LLOWER, LUPPER COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C PURPOSE: C 1) SET UP ARRAYS CONTAINING DECISIONS AND ERROR TYPES C FOR MANDATORY LEVELS. C 2) CHECK LAPSE RATES AT MANDATORY LEVLES ONLY IF THE C TEMPERATUES WERE MODIFIED. C SET UP COMBINED ARRAYS OF DECISION, ERROR TYPE AND NEW TEMP. DO I=1,MC IDECC(I) = 0 IHYDC(I) = 0 ENDDO C SEARCH EVENTS FILE FOR MAND LVL TEMP CHANGES. DO I=1,MC IF(ITYP(I).GT.1) THEN C DO FOLLOWING ONLY FOR MANDATORY LEVELS. C LOOP THROUGH EVENTS, LOOKING FOR TEMP CORRS C AND OBSERVATIONAL ERROR REJECTIONS. II = INDX(I) DO 10 J=1,IR IF(NEVNT(21,J).NE.IDENT .OR. DHOUR(J).NE.HOUR) GO TO 10 CALL UNPACK(NEVNT(7,J),IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) CALL UNPCK2(NEVNT(6,J),IV,LEV,ISCAN,IDECSN) IF(LEV.EQ.II.AND.IV.EQ.2) THEN C MAND LEVEL TEMP FOUND AT THIS LEVEL. C SAVE DECISION AND ERROR TYPE. IDECC(I) = IDECSN IHYDC(I) = IHSC IF(IDECSN.NE.1.AND.IDECSN.NE.4) GO TO 10 C HAVE FOUND MAND LVL TEMP CORR OR MAND LVL TEMP C REJECTION AT THIS STN AND LEVEL. C CHECK THE LAPSE RATE, USING THE CORRECTED TEMP VALUE. C GET PREVIOUS LEVEL WITH TEMPERATURE. INIT = I - 1 IF(INIT.GE.1) THEN CALL PRVTEMP(INIT,I,ITYP,IDECC,PC,1,ILOW) ELSE ILOW = 0 ENDIF C GET NEXT LEVEL WITH TEMPERATURE. INIT = I + 1 IF(INIT.LE.MC) THEN CALL NEXTEMP(INIT,I,ITYP,IDECC,PC,MC,IUP) ELSE IUP = MC + 1 ENDIF C WRITE(6,500) I,ILOW,IUP 500 FORMAT(' LAPSE--I,ILOW,IUP:',3I6) TCOR = NEVNT(10,J) * 0.1 TC(I) = TCOR OVER = 1.1 LLOWER = .FALSE. LUPPER = .FALSE. IF(I.GT.1 .AND. ILOW.GE.1 .AND. IUP.LE.MC) & CALL SUPER(TC(ILOW),TCOR,XPC(ILOW),XPC(I), & 2,OVER,LLOWER,IER) IF(I.LT.MC .AND. ILOW.GE.1 .AND. IUP.LE.MC) & CALL SUPER(TCOR,TC(IUP),XPC(I),XPC(IUP), & 2,OVER,LUPPER,IER) IF((LLOWER.OR.LUPPER) .AND. IDECSN.NE.4) THEN C SUPERADIABATIC LAPSE RATE FOUND. C CORRECTED TEMPERATURE IS NOT GOOD. C MUST RESET CORRECTION TO 0. AND COMPUTE C THE INCREMENT. BASE DECISION ON INCREMENT. TC(I) = NEVNT(9,J) * 0.1 TINC = NEVNT(9,J) * 0.1 - TMG(LEV) NEVNT(10,J) = NEVNT(9,J) IF(ABS(TINC).GT.2.0*DTALL & .AND. TINC.LT.VMAX(2)) THEN IDECSN = 4 TQC(I) = 13 ELSE IDECSN = 3 TQC(I) = 3 ENDIF IHSC = IHSC + 200 IDECC(I) = IDECSN IHYDC(I) = IHSC IF(ITYP(I).EQ.2) ITYP(I) = 4 IF(ITYP(I).EQ.3) ITYP(I) = 5 C WRITE(6,501) IHSC,TC(I),TMG(I),TINC,IDECC(I),ITYP(I) 501 FORMAT(' LAPSE--TYPE ',I5,' ERROR. TC,TMG,TINC:', & 3F7.1,' IDECC,ITYP:',2I5) NEVNT(6,J) = ((IV*100+LEV)*100+ISCAN)*100+IDECSN CALL PACK(NEVNT(7,J),IINC,IHSC,IHOI,IVOI,IBAS,IIPL,IHPL) C ELSEIF(.NOT.(LLOWER.OR.LUPPER) .AND. IDECSN.EQ.4) THEN C C SUPERADIABATIC LAPSE RATE NOT FOUND FOR TEMP FLAGGED C AS BAD. CHANGE DECISION FROM 4 TO 3. C C IDECSN = 3 C IHSC = IHSC + 200 C IDECC(I) = IDECSN C IHYDC(I) = IHSC C TQC(I) = 3 C NEVNT(6,J) = ((IV*100+LEV)*100+ISCAN)*100+IDECSN C CALL PACK(NEVNT(7,J),IINC,IHSC,IHOI,IVOI,IBAS,IIPL,IHPL) ENDIF ENDIF 10 CONTINUE C END OF LOOP THROUGH EVENTS. ENDIF ENDDO RETURN END C********************************************************************** C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MANEVN WRITE AN EVENT FOR MANDATORY LEVELS. C PRGMMR: J. WOOLLEN ORG: W/NMC20 DATE: 94-03-17 C C ABSTRACT: WRITE AN EVENT FOR MANDATORY LEVELS. C C PROGRAM HISTORY LOG: C 94-03-17 J. WOOLLEN C C USAGE: CALL MANEVN C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE MANEVN C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), C-CRA. PQ (895),TQ (895),ZQ (895),IN (895), C-CRA. PR (895),TR (895),ZR (895) COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), . PQ (895),TQ (895),ZQ (895), . PR (895),TR (895),ZR (895) COMMON /EVNSNDI/IN (895) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) CHARACTER*8 COB(2),SID,CID DIMENSION IDQM(0:5) INTEGER*8 IOB(2) EQUIVALENCE (COB(1),IOB(1)) LOGICAL SDM,WIND,LEVCHK DATA IDQM /1,1,1,3,13,13/ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CLEAR THE WORK ARRAYS FOR THIS OB C --------------------------------- NEV = 0 C-CRA PO = BMISS C-CRA TO = BMISS C-CRA ZO = BMISS C-CRA IN = BMISS PO = BMISS TO = BMISS ZO = BMISS IN = BMISS C DO IJ=1,895 C PO(IJ) = BMISS C TO(IJ) = BMISS C ZO(IJ) = BMISS C IN(IJ) = BMISS C ENDDO WIND = ITP.EQ.20000 C SET INDEXES FOR MANDATORY LEVELS OR SURFACE WIND LEVEL C ------------------------------------------------------ IF(.NOT.WIND) THEN DO L=1,NLV MI = MANLEV(POB(L)) IF(CAT(L).EQ.1 .AND. MI.LE.NPLVL) THEN IN(MI) = IND(L) NEV = MAX(NEV,MI) ENDIF ENDDO ENDIF C LOOP OVER ALL EVENTS LOOKING FOR THIS PARTICULAR OB C --------------------------------------------------- 10 DO 100 I=1,IR IOB(1) = NEVNT(2,I) IOB(2) = NEVNT(3,I) CID = COB(1)(1:4)//COB(2)(1:2) CALL UNPCK2(NEVNT(6,I),IV,IL,IS,ID) IF(SID.NE.CID .OR. DHOUR(I).NE.DHR) GOTO 100 C FOUND A MATCH - DOUBLE CHECK TO MAKE SURE C ----------------------------------------- IF(.NOT.WIND) THEN LEVCHK = IL.LT.1 .OR. IL.GT.NEV .OR. IN(IL).GT.NLV IF(LEVCHK) WRITE(80,'(2A8,2I8)') 'ILL: ',SID,IL,NEV IF(LEVCHK) GOTO 100 ELSE IF(IV.NE.4) GOTO 100 POD = NEVNT(9,I)*.1 ISF = 0 DO L=1,NLV DIF = ABS(POB(L)-POD) IF(DIF.LT..1) ISF = L ENDDO ENDIF IF(IV.EQ.1) THEN OP = POB(IN(IL)) OB = ZOB(IN(IL)) O1 = NEVNT(8,I) O2 = NEVNT(9,I) QM = ZQM(IN(IL)) ELSEIF(IV.EQ.2) THEN OP = POB(IN(IL)) OB = TOB(IN(IL)) O1 = NEVNT(8,I)*.1 O2 = NEVNT(9,I)*.1 QM = TQM(IN(IL)) ELSEIF(IV.EQ.4) THEN IF(ISF.EQ.0) GOTO 100 OP = POB(ISF) OB = POB(ISF) O1 = NEVNT(8,I)*.1 O2 = NEVNT(9,I)*.1 QM = PQM(ISF) ELSE GOTO 100 ENDIF DIF = ABS(OB-O1) IF(DIF.GT..1) DIF = ABS(OB-O2) IF(DIF.GT..1) WRITE(80,80) SID,IV,ID,OP,O1,O2,OB,NEVNT(10,I) IF(DIF.GT..1) GOTO 100 80 FORMAT(A8,1X,2I2,4F8.1,I8) C HONOR KEEPS OR PURGES - RECORD CQC JUDGMENT ANYWAY C -------------------------------------------------- SDM = QM.EQ.0.OR.QM.EQ.8.OR.QM.EQ.9.OR.QM.EQ.12.OR.QM.EQ.14 ID = MOD(ID,10) IF(SDM) THEN IF(QM.EQ.0) IDC = 50+ID IF(QM.GT.0) IDC = 90+ID NEVNT(6,I) = ((IV*100+IL)*100+IS)*100+IDC ELSE QM = IDQM(ID) ENDIF C PUT TOGETHER A BUFR EVENT C ------------------------- IF(IV.EQ.1) THEN ZOB(IN(IL)) = NEVNT(10,I) ZQM(IN(IL)) = QM ZO(IL) = ZOB(IN(IL)) ZQ(IL) = ZQM(IN(IL)) ZR(IL) = ID ELSEIF(IV.EQ.2) THEN TOB(IN(IL)) = NEVNT(10,I)*.1 TQM(IN(IL)) = QM TO(IL) = TOB(IN(IL)) TQ(IL) = TQM(IN(IL)) TR(IL) = ID ELSE POB(ISF) = NEVNT(10,I)*.1 PQM(ISF) = QM PO(1) = POB(ISF) PQ(1) = PQM(ISF) PR(1) = ID ENDIF C WRITE(6,500) CID,DHR,ZO(IL),ZQ(IL),TO(IL),TQ(IL),PO(IL),PQ(IL) 500 FORMAT(' MANEVN--STATION,HOUR,ZO,ZQ,TO,TQ,PO,PQ: ',A8,1X,7F10.1) 100 CONTINUE RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MANSIG MAKE COINCIDENT LEVEL T'S AGREE C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: MAKE COINCIDENT MANDATORY AND SIGNIFICANT LEVEL C TEMPERATURES AGREE. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL MANSIG(PC, TC, PQC, ZQC, TQC, ITYP, MC) C INPUT ARGUMENT LIST: C PC - COLLECTED PRESSURES (HPA) C TC - COLLECTED TEMPERATURES (C) C PQC - PRESSURE QUALITY MARK (TABLE VALUE) C ZQC - HEIGHT QUALITY MARK (TABLE VALUE) C TQC - TEMPERATURE QUALITY MARK (TABLE VALUE) C ITYP - LEVEL TYPE C MC - NUMBER OF COLLECTED LEVELS C C OUTPUT ARGUMENT LIST: C TC - COLLECTED TEMPERATURES (C) C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE MANSIG(PC,TC,PQC,ZQC,TQC,ITYP,MC) REAL PC(*), TC(*), PQC(*), ZQC(*), TQC(*) INTEGER ITYP(*), IFI, IFIP COMMON /MSGS/ VMAX(2),VMSG(2) I = 1 10 CONTINUE IF(ABS(PC(I+1)-PC(I)).LT.0.02) THEN C TWO LEVELS AT THE SAME PRESSURE. C WRITE(6,500) (J,PC(J),TC(J), C & PQC(J),ZQC(J),TQC(J),ITYP(J),J=I,I+1) 500 FORMAT(' MANSIG--J,PC,TC,PQC,ZQC,TQC,ITYP: ', & 1X,I5,1X,F7.0,1X,F7.1,1X,3F4.0,1X,I5/ & 31X,I5,1X,F7.0,1X,F7.1,1X,3F4.0,1X,I5) IF(ITYP(I+1).GT.1.AND.ITYP(I).LE.1) THEN LEVELMAND = I+1 LEVELSIG = I ELSEIF(ITYP(I).GT.1.AND.ITYP(I+1).LE.1) THEN LEVELMAND = I LEVELSIG = I+1 ELSE I = I+1 IF(I.LT.MC) GO TO 10 RETURN ENDIF C CHECK FOR TEMP CORR AT MAND LEVEL. IF(TQC(LEVELMAND).EQ.16) THEN IF(ABS(TC(LEVELMAND)-TC(LEVELSIG)).LT.2.0) THEN TC(LEVELMAND) = TC(LEVELSIG) TQC(LEVELSIG) = 1 ENDIF ELSE IF(TC(LEVELSIG).NE.TC(LEVELMAND)) THEN IF(TC(LEVELMAND).LT.VMAX(2)) THEN TC(LEVELSIG) = TC(LEVELMAND) TQC(LEVELSIG) = 16 ELSEIF(TC(LEVELSIG).LT.VMAX(2)) THEN TC(LEVELMAND) = TC(LEVELSIG) TQC(LEVELMAND) = 16 TQC(LEVELSIG) = 1 ENDIF ENDIF ENDIF ENDIF I = I+1 IF(I.LT.MC) GO TO 10 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MIMAP FILL IMAP FOR HORIZONTAL SEARCH C PRGMMR: J. WOOLLEN ORG: W/NMC22 DATE: 92-??-?? C C ABSTRACT: FILL IMAP FOR HORIZONTAL SEARCH C C PROGRAM HISTORY LOG: C 92-??-?? J. WOOLLEN C C USAGE: CALL MIMAP C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE MIMAP(XQC,YQC,NREP) DIMENSION XQC(NREP),YQC(NREP) COMMON /OBLIST/ NOB,INOB(1000),IMAP(360,181) DIMENSION INDD(1000) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MAKE SURE NONE OF THE LONGITUDES EQUAL 360. C ------------------------------------------- DO 5 N=1,NREP IF(XQC(N).EQ.360.) XQC(N) = 0. 5 CONTINUE C LONGITUDE SORT C -------------- NN = 0 DO 10 NX=1,360 DO 10 N=1,NREP IX = XQC(N)+1. IF(IX.EQ.NX) THEN NN = NN+1 INDD(NN) = N ENDIF 10 CONTINUE C LATITUDE SORT C ------------- NOB = 0 DO 20 NY=1,181 DO 20 N=1,NN IY = YQC(INDD(N))+91. IF(IY.EQ.NY) THEN NOB = NOB+1 INOB(NOB) = INDD(N) ENDIF 20 CONTINUE C INITIALIZE IMAP ARRAY C --------------------- IF(NN.NE.NREP .OR. NOB.NE.NREP) STOP'IMAP' DO 25 J=1,181 DO 25 I=1,360 IMAP(I,J) = 0 25 CONTINUE DO 30 N=1,NOB NX = XQC(INOB(N)) + 1. NY = YQC(INOB(N)) + 91. IF(IMAP(NX,NY).EQ.0) IMAP(NX,NY) = N 30 CONTINUE C FILL GAPS IN IMAP FOR CONTINUITY (BACKWARDS) C -------------------------------------------- LASTN = NOB DO 40 NY=181,1,-1 DO 40 NX=360,1,-1 IF(IMAP(NX,NY).EQ.0) THEN IMAP(NX,NY) = LASTN ELSE LASTN = IMAP(NX,NY) ENDIF 40 CONTINUE RETURN END C*********************************************************** SUBROUTINE MTCOR C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MTCOR SET VALUES OF /TCOR/ TO MISSING C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: SET VALUES OF /TCOR/ TO MISSING. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL MTCOR C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C SET ARRAYS OF /TCOR/ TO MISSING. C COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) DO 30 J=1,2 CDH3(J) = VMSG(1) CDH2(J) = VMSG(1) CDO3(J) = VMSG(1) CDO2(J) = VMSG(1) DO 10 I=1,2 CVRES(I,J) = VMSG(1) 10 CONTINUE DO 20 I=1,4 CHRES(I,J) = VMSG(1) COINC(I,J) = VMSG(1) 20 CONTINUE 30 CONTINUE DO 40 I=1,3 CBSUM(I) = VMSG(1) CHYRES(I) = VMSG(1) 40 CONTINUE CBRES = VMSG(1) CZSC = VMSG(1) CPSC = VMSG(1) CZ2C = VMSG(1) CZ1C = VMSG(1) RETURN END C*********************************************************** SUBROUTINE NEWVAL C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NEWVAL CHANGE OBS TO CORRECTED VALUES. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHANGE OBSERVATIONS TO CORRECTED VALUES. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-28 W. COLLINS USES NEW EVENTS FILE. C C USAGE: CALL NEWVAL C INPUT ARGUMENT LIST: C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C C CHANGE OBSERVATIONS TO CORRECTED VALUES. C DO 100 I=1,IR CALL UNPCK2(NEVNT(6,I),IV,L,ISC,IDS) IF(IV.LT.1 .OR. IV.GT.4 & .OR. L.LT.1 .OR. L.GT.NPLVL & .OR. ISC.LT.1 ) GO TO 100 DO 10 IS=1,NOBS IF(ID(IS).EQ.NEVNT(21,I) & .AND. DHR(IS).EQ.DHOUR(I)) GO TO 11 10 CONTINUE GOTO 100 11 CONTINUE C WRITE(6,500) ID(IS), DHR(IS), L, IV 500 FORMAT(' NEWVAL--DATA UPDATED FOR ',I6,' HOUR:',F6.0, & ' L,IV:',2I3) IF(IV.EQ.1) THEN OBS(L,IV,IS) = NEVNT(10,I) ELSEIF(IV.EQ.2) THEN OBS(L,IV,IS) = 0.1 * NEVNT(10,I) ELSEIF(IV.EQ.4) THEN PS(IS) = 0.1 * NEVNT(10,I) ENDIF 100 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NEXMAN FIND NEXT MAND LEVEL WITH GOOD TEMP C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: FIND THE NEXT MANDATORY LEVEL WITH A GOOD TEMPERATURE. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL NEXMAN(INIT, ITYP, IDEC, MC, NEXT) C INPUT ARGUMENT LIST: C INIT - FIRST LEVEL TO TRY C ITYP - LEVEL TYPE C IDEC - DECISION C MC - NUMBER OF COLLECTED LEVELS C C OUTPUT ARGUMENT LIST: C NEXT - NEXT LEVEL WITH GOOD TEMPERATURE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE NEXMAN(INIT,ITYP,IDEC,MC,NEXT) INTEGER ITYP(*), IDEC(*) C FIND NEXT MANDATORY LEVEL W NON-MISSING TEMP, C BEGINNING WITH INIT. RETURN ANSWER IN NEXT. C CONSIDER SURFACE AS A MANDATORY LEVEL. IF(INIT.GE.MC) THEN NEXT = MC + 1 RETURN ENDIF DO I=INIT,MC NEXT = I IF((ITYP(I).EQ.1.OR.ITYP(I).EQ.2.OR.ITYP(I).EQ.3) & .AND. IDEC(I).LE.1) GO TO 10 ENDDO NEXT = MC + 1 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NEXMNZ FIND NEXT MAND LEVEL W NON-MSG TEMP C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: FIND THE NEXT MANDATORY LEVEL WITH A NON-MISSING C TEMPERATURE. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL NEXMNZ(INIT, ITYP, IDEC, MC, NEXT) C INPUT ARGUMENT LIST: C INIT - FIRST LEVEL TO TRY C ITYP - LEVEL TYPE C IDEC - DECISION C MC - NUMBER OF COLLECTED LEVELS C C OUTPUT ARGUMENT LIST: C NEXT - NEXT LEVEL WITH GOOD TEMPERATURE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE NEXMNZ(INIT,ITYP,IDEC,MC,NEXT) INTEGER ITYP(*), IDEC(*) C FIND NEXT MANDATORY LEVEL W NON-MISSING TEMP, C BEGINNING WITH INIT. RETURN ANSWER IN NEXT. C CONSIDER SURFACE AS A MANDATORY LEVEL. IF(INIT.GE.MC) THEN NEXT = MC + 1 RETURN ENDIF DO I=INIT,MC NEXT = I IF((ITYP(I).EQ.1.OR.ITYP(I).EQ.2) .AND. IDEC(I).LE.1) GO TO 10 ENDDO NEXT = MC + 1 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NEXTEMP FIND NEXT LEVEL WITH GOOD TEMP C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: FIND THE NEXT LEVEL WITH A GOOD TEMPERATURE. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL NEXTEMP(INIT, ITYP, IDEC, MC, NEXT) C INPUT ARGUMENT LIST: C INIT - FIRST LEVEL TO TRY C ITYP - LEVEL TYPE C IDEC - DECISION C MC - NUMBER OF COLLECTED LEVELS C C OUTPUT ARGUMENT LIST: C NEXT - NEXT LEVEL WITH GOOD TEMPERATURE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE NEXTEMP(INIT,I0,ITYP,IDEC,P,MC,NEXT) REAL P(*) INTEGER ITYP(*), IDEC(*) C FIND NEXT LEVEL (AT DIFFERENT PRESSURE) WITH GOOD TEMPERTURE. C RETURN ANSWER IN NEXT. DO I=INIT,MC NEXT = I IF(ITYP(I).LE.3.AND.IDEC(I).LE.1 & .AND.P(I).NE.P(I0)) GO TO 10 ENDDO NEXT = MC + 1 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NEXTS FIND NEXT LEVELS ABOVE AND BELOW ... C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: FIND THE NEXT LEVELS ABOVE AND BELOW WITH SPECIFIED C CRITERIA. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL NEXTS(ITYP, MC, MB, NB, NA) C INPUT ARGUMENT LIST: C ITYP - LEVEL TYPE C MC - NUMBER OF COLLECTED LEVELS C C OUTPUT ARGUMENT LIST: C MB - NEXT LEVEL WITH ITYP = 2 OR 3 BELOW (MAND WITH T) C MA - NEXT LEVEL WITH ITYP = 2 OR 3 ABOVE (MAND WITH T) C NB - NEXT LEVEL WITH ITYP < 4 BELOW (EITHER WITH T) C NA - NEXT LEVEL WITH ITYP < 4 ABOVE (EITHER WITH T) C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE NEXTS(ITYP,MC,MB,MA,NB,NA) INTEGER ITYP(*), MB(*), MA(*), NB(*), NA(*) C PURPOSE: C DETERMINE INDICES OF FIRST LEVELS ABOVE AND BELOW THAT C HAVE SPECIFIED CHARACTERISITCS. C C INPUT: C ITYP - TYPE OF DATA C MC - NUMBER OF COMBINED LEVELS C C OUTPUT: C ITYP - TYPE OF DATA C = 0 SIGNIFICANT LEVEL DATA C = 1 SURFACE DATA C = 2 MAND LEVEL DATA WITH Z, T NON-MISSING, GOOD C = 3 MAND LEVEL DATA WITH ONLY T NON-MISSING, GOOD C = 4 MAND LEVEL DATA WITH ONLY Z NON-MISSING, GOOD C = 5 MAND LEVEL DATA WITH Z, T MISSING OR NOT GOOD C C FOLLOWING REFER TO INDICES WITHIN THE COMBINED ARRAYS C AFTER THEY HAVE BEEN SORTED ACCORDING TO DESCENDING PRESSURE. C C MB - NEXT LEVEL WITH ITYP = 2 OR 3 BELOW (MAND WITH T) C MA - NEXT LEVEL WITH ITYP = 2 OR 3 ABOVE (MAND WITH T) C NB - NEXT LEVEL WITH ITYP < 4 BELOW (EITHER WITH T) C NA - NEXT LEVEL WITH ITYP < 4 ABOVE (EITHER WITH T) C SOLVE FOR SPECIAL INDICES MB, MA, NB AND NA. C FOR THESE ARRAYS, A VALUE OF 0 IS USED WHEN NO LEVEL WITH C THE REQUIRED CONDITIONS IS MET. MB(1) = 0 NB(1) = 0 IF(MC.EQ.0) THEN MA(1) = 0 NA(1) = 0 RETURN ENDIF MA(MC) = 0 NA(MC) = 0 DO K=2,MC-1 C BELOW... MB(K) = 0 DO II=1,K-1 I = K-II IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2 .OR. ITYP(I).EQ.3) THEN MB(K) = I GO TO 10 ENDIF ENDDO 10 CONTINUE NB(K) = 0 DO II=1,K-1 I = K-II IF(ITYP(I).LT.4) THEN NB(K) = I GO TO 20 ENDIF ENDDO 20 CONTINUE C ABOVE... MA(K) = 0 DO I=K+1,MC IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2 .OR. ITYP(I).EQ.3) THEN MA(K) = I GO TO 30 ENDIF ENDDO 30 CONTINUE NA(K) = 0 DO I=K+1,MC IF(ITYP(I).LT.4) THEN NA(K) = I GO TO 40 ENDIF ENDDO 40 CONTINUE ENDDO C DONE RETURN END C*********************************************************** SUBROUTINE PACK(IPACK,IINC,IHSC,IHOI,IVOI,IBAS,IIPL,IHPL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PACK PACK ERROR FLAGS INTO IPACK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PACK ERROR FLAGS INTO IPACK. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-31 W. COLLINS COMBINE IN POWERS OF 10. C C USAGE: CALL PACK(IPACK, IINC, IHSC, IHOI, IVOI, IBAS, IIPL, IHPL) C INPUT ARGUMENT LIST: C IINC - INCREMENT RESIDUAL CODE C IHSC - HYDROSTATIC ERROR TYPE C IHOI - HORIZONTAL RESIDUAL CODE C IVOI - VERTICAL RESIDUAL CODE C IBAS - BASELINE RESIDUAL CODE C IIPL - MSL PRESSURE INCREMENT CODE C IHPL - MSL PRESSURE HORIZONTAL RESIDUAL CODE C C OUTPUT ARGUMENT LIST: C IPACK - PACKED CODES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PACK ERROR FLAGS INTO IPACK. C IPACK = (((((IHSC*10 + IINC)*10 + IHOI)*10 + IVOI)*10 & + IBAS)*10 + IIPL)*10 + IHPL RETURN END C********************************************************** C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PARAM CALCULATE HYDROSTATIC PARAMETERS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CALCULATE PARAMETERS FOR HYDROSTATIC COMPUTATIONS. C READY EVENTS FILE FOR ADDITIONS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL PARAM C C INPUT FILES: C FT12F001 - EVENTS FILE C C OUTPUT FILES: C FT12F001 - EVENTS FILE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C SPECIFY PARAMETERS FOR THIS RUN. C SUBROUTINE PARAM INTEGER YEAR, MONTH, DAY, HOUR, FHR, ANL, VER CHARACTER*132 LINE C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /GDATE/ YEAR, MONTH, DAY, HOUR, FHR, ANL, VER COMMON /GDATE/ YEAR, DAY, HOUR, FHR, ANL, VER COMMON /GDATEI/ MONTH C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /LEVMAN/ ISET,MANLIN(1001) C SET MANLIN FOR MANLEV C --------------------- ISET = 1 DO I=1,1001 MANLIN(I) = 0 IF(I.EQ.1000) MANLIN(I) = 1 IF(I.EQ. 925) MANLIN(I) = 2 IF(I.EQ. 850) MANLIN(I) = 3 IF(I.EQ. 700) MANLIN(I) = 4 IF(I.EQ. 500) MANLIN(I) = 5 IF(I.EQ. 400) MANLIN(I) = 6 IF(I.EQ. 300) MANLIN(I) = 7 IF(I.EQ. 250) MANLIN(I) = 8 IF(I.EQ. 200) MANLIN(I) = 9 IF(I.EQ. 150) MANLIN(I) = 10 IF(I.EQ. 100) MANLIN(I) = 11 IF(I.EQ. 70) MANLIN(I) = 12 IF(I.EQ. 50) MANLIN(I) = 13 IF(I.EQ. 30) MANLIN(I) = 14 IF(I.EQ. 20) MANLIN(I) = 15 IF(I.EQ. 10) MANLIN(I) = 16 IF(I.EQ. 7) MANLIN(I) = 17 IF(I.EQ. 5) MANLIN(I) = 18 IF(I.EQ. 3) MANLIN(I) = 19 IF(I.EQ. 2) MANLIN(I) = 20 IF(I.EQ. 1) MANLIN(I) = 21 ENDDO C C COMPUTE TEMPERATURE INCREMENTS FOR SIMPLE. C DO 5 I=1,NT IMOD = MOD(I,2) + 1 ALLT(I) = (-1.)**IMOD * AINT((I+.1)/2.) 5 CONTINUE C C COMPUTE CONSTANTS FOR HYDROSTATIC CHECK C NPLVLM = NPLVL - 1 DO 10 I=1,NPLVLM ARG = FLOAT(IPLVL(I))/FLOAT(IPLVL(I+1)) A(I) = (R*T0/G) * ALOG(ARG) B(I) = (0.5*R/G) * ALOG(ARG) 10 CONTINUE C C INPUT REGION FOR CHECKING. C LONGITUDES ARE MEASURED EAST FROM GRENWICH C LATITUDES ARE + NORTH, - SOUTH C ALONN = 0. ALONX = 360. ALATN = -90. ALATX = 90. C C SET OBS, GES TO MISSING. C DO 119 IS=1,899 DO 118 IV=1,2 DO 117 L=1,NPLVL OBS(L,IV,IS) = VMSG(IV) GES(L,IV,IS) = VMSG(IV) 117 CONTINUE 118 CONTINUE 119 CONTINUE C C ZERO ERROR FLAG FIELD. C DO 20 ISC=1,2 DO 19 IS=1,899 DO 18 IV=1,2 DO 17 L=1,NPLVL NERR(L,IV,IS,ISC) = 0 17 CONTINUE 18 CONTINUE 19 CONTINUE 20 CONTINUE C C READ TO END OF DATA ON UNIT 12, THEN C BACKSPACE OVER EOF AND LAST RECORD. C THIS UNIT IS USED TO ACCUMULATE THE EVENTS FILE. C 700 CONTINUE READ(12,600,END=710) LINE 600 FORMAT(A132) GO TO 700 710 CONTINUE BACKSPACE 12 C C READ TO END OF DATA ON UNIT 16, THEN C BACKSPACE OVER EOF AND LAST RECORD. C THIS UNIT IS USED TO ACCUMULATE THE STATION LIST. C 800 CONTINUE READ(16,850,END=810) LINE 850 FORMAT(A80) GO TO 800 810 CONTINUE BACKSPACE 16 RETURN END C************************************************************ SUBROUTINE PBLOCK(IBL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PBLOCK PRINT /CDMA/ CONTENTS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PRINT /CDMA/ CONTENTS FOR DIAGNOSIS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL PBLOCK(IBL) C INPUT ARGUMENT LIST: C IBL - PRINT PERFORMED ONLY IF IBL = 1 C C OUTPUT FILES: C FT64F001 - DIAGNOSTIC PRINT FILE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PRINT COMMON BLOCK CONTENTS. C INTEGER ICZ(4), ICT(4), LZ(4), LT(4), LH(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) IF(IBL.EQ.1) THEN ICZ(1) = ICZ1 ICZ(2) = IC2 ICZ(3) = ICZ3 ICZ(4) = ICZ4 ICT(1) = ICT1 ICT(2) = IC2 ICT(3) = ICT3 ICT(4) = ICT4 LZ(1) = LZ1 LZ(2) = L2 LZ(3) = LZ3 LZ(4) = LZ4 LT(1) = LT1 LT(2) = L2 LT(3) = LT3 LT(4) = LT4 LH(1) = LH1 LH(2) = L2 LH(3) = LH3 LH(4) = LH4 WRITE(64,500) 500 FORMAT(' LZ ICZ ZZ ZZCOR ZZC LT ICT TT', & ' TTCOR TTC') WRITE(64,501) (I,LZ(I),ICZ(I),ZZ(I),ZZCOR(I),ZZC(I),LT(I), & ICT(I),TT(I),TTCOR(I),TTC(I),I=1,4) 501 FORMAT(1X,I2,2I4,3F8.0,2I4,3F8.1) WRITE(64,502) 502 FORMAT(' LH ZH TH HYS BB OINCZ', & ' HRESZ VRESZ OINCT HREST VREST') WRITE(64,503) (I,LH(I),ZH(I),TH(I),HYS(I),BB(I),OINCZ(I), & HRESZ(I),VRESZ(I),OINCT(I),HREST(I),VREST(I),I=1,3) 503 FORMAT(1X,I2,I4,F8.0,F8.1,F8.0,F8.3,3F8.0,3F8.1) I = 4 WRITE(64,507) I,LH(I),ZH(I),TH(I),OINCZ(I), & HRESZ(I),VRESZ(I),OINCT(I),HREST(I),VREST(I) 507 FORMAT(1X,I2,I4,F8.0,F8.1,16X,3F8.0,3F8.1) WRITE(64,504) 504 FORMAT(' DOZ DHZ DOT DHT') WRITE(64,505) DOZ2,DHZ2,DOT2,DHT2 505 FORMAT(' 2',2F8.0,2F8.1) WRITE(64,506) DOZ3,DHZ3,DOT3,DHT3 506 FORMAT(' 3',2F8.0,2F8.1) ENDIF RETURN END C************************************************************ SUBROUTINE PEVENT C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PEVENT PRINT EVENTS FILE. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PRINT EVENTS FILE. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-28 W. COLLINS USES NEW EVENTS FILE. C C USAGE: CALL PEVENT C OUTPUT FILES: C FT12F001 - EVENTS FILE FOR MANDATORY LEVELS C FT62F001 - PRINT FILE, EVENTS FILE, SUMMARY FORM. C FT63F001 - PRINT FILE, EVENTS FILE, FULL FORM. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PRINT EVENTS FILE. C CHARACTER*3 CVAR(0:4) CHARACTER*4 CP(0:21) CHARACTER*8 NV1C, NV2C C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) INTEGER*8 NV1,NV2 EQUIVALENCE (NV1,NV1C), (NV2,NV2C) DATA CVAR /'XXX',' Z',' T','Z,T',' PS'/ DATA CP /'XXXX','1000',' 925',' 850',' 700',' 500',' 400', & ' 300',' 250',' 200',' 150',' 100',' 70',' 50',' 30', & ' 20',' 10',' 7',' 5',' 3',' 2',' 1'/ WRITE(62,499) 499 FORMAT('1----- EVENTS FILE -----') C C SORT EVENTS FILE BY STATION ID. C CALL SORTE C IB = 0 III = 0 WRITE(62,520) NEVNT(1,1) 520 FORMAT('1DATE/TIME: ',I8) DO 100 I=1,IR CALL UNPCK2(NEVNT(6,I),IVI,LI,ISI,IDI) CALL UNPACK(NEVNT(7,I),IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) C C SEARCH EARLIER ON LIST FOR DUPLICATE. C IPR = 0 IM = I-1 IF(IM.EQ.0) GO TO 15 DO 10 II=1,IM CALL UNPCK2(NEVNT(6,II),IVII,LII,ISII,IDII) IF( LI.EQ.LII & .AND. NEVNT(21,I).EQ.NEVNT(21,II) & .AND. DHOUR(I).EQ.DHOUR(II) & .AND. IVI.EQ.IVII & .AND. NEVNT(10,I).EQ.NEVNT(10,II) & .AND. IDI.EQ.IDII) GO TO 20 10 CONTINUE C C NO DUPLICATE FOUND ==> WRITE EVENT TO FILES. C 15 CONTINUE IPR = 1 20 CONTINUE IF(IPR.EQ.1) THEN NV1 = NEVNT(2,I) NV2 = NEVNT(3,I) WRITE(12,511) NEVNT(1,I), NV1C(1:4), NV2C(1:2), & (NEVNT(J,I),J=4,20) IF(IHSC.GE.100) THEN IB = 1 WRITE(62,502) WRITE(62,501) NV1C(1:4), NV2C(1:2), & CVAR(IVI),CP(LI),ISI,IDI, & IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL, & (NEVNT(J,I),J=8,20),(NEVNT(J,I),J=4,5), & NEVNT(1,I),DHOUR(I) ELSE III = III + 1 IF(IB.NE.0) THEN IB = 0 III = 1 ENDIF IF(MOD(III,5).EQ.1) WRITE(62,500) WRITE(62,501) NV1C(1:4), NV2C(1:2), & CVAR(IVI),CP(LI),ISI,IDI, & IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL, & (NEVNT(J,I),J=8,20),(NEVNT(J,I),J=4,5), & NEVNT(1,I),DHOUR(I) ENDIF ENDIF 100 CONTINUE 500 FORMAT(' STN ID VAR PRES SS DD HSC IN--H--V B-IP-HP', & ' Z-OLD T-OLD NEW OINC HY12 HY23 NHY12 NHY23', & ' HRES VRES TERR OTRES NTRES LONG LAT DATE') 502 FORMAT(' STN ID VAR PRES SS DD HSC IN--H--V B-IP-HP', & ' Z-SFC OLD NEW BRES NBRES PMSL PMSLI PMSLR', & ' Z1INC Z2INC TERR OTRES NTRES LONG LAT DATE') 501 FORMAT(1X,A4,A2,2X,A3,A5,2I3,I4,6I3,10I6,4I6,I5,I9,F6.0) 511 FORMAT(1X,I8,1X,A4,A2,2X,2I6,2I10,13I6) C C PRINT RESULTS FROM STNCNT. C IDUM = 0 CALL STNCNT(IDUM,2) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PILNLNP PRESSURE INTERPOLATION LINEAR IN LOG P C PRGMMR: WOOLLEN ORG: W/NMC22 DATE: 92-07-29 C C ABSTRACT: FUNCTION WHICH GIVEN AN PROFILE OF DESCENDING PRESSURES C AND A PROFILE OF QUANTITIES VALID AT THOSE PRESSURES, RETURNS C AN INTERPOLATED QUANTITY VALID AT A GIVEN ARBITRARY PRESSURE. C C PROGRAM HISTORY LOG: C 86-03-21 G. DIMEGO C 88-11-24 D. DEAVEN RECODED FOR CYBER 205 C C USAGE: X = PILNLNP(P,PARAY,QARAY,KMAX) C C INPUT ARGUMENTS: C P - PRESSURE TO INTERPOLATE TO C PARAY - GIVEN PRESSURE PROFILE C QARAY - QUANTITIES VALID FOR PRESSURE PROFILE C KMAX - LENGTH OF PROFILE C C FUNCTION RETURN VALUE C PILNLNP - INTERPOLATED QUANTITY C C ATTRIBUTES: C LANGUAGE: CDC FORTRAN200 C MACHINE: CYBER C C$$$ FUNCTION PILNLNP(P,PARAY,QARAY,KMAX) DIMENSION PARAY(KMAX),QARAY(KMAX) BMISS = 10E10 PILNLNP = 0. C FIND ADJACENT LEVELS C -------------------- DO 10 LA=1,KMAX IF(P.GE.PARAY(LA)) GOTO 11 10 CONTINUE 11 IF(LA.GT.KMAX) THEN LA = KMAX LB = KMAX ELSE IF(LA.EQ.1) THEN LA = 1 LB = 1 ELSE LB = LA-1 ENDIF C INTERPOLATE IF BOTH ADJACENT VALUES PRESENT C ------------------------------------------- IF(QARAY(LA).LT.BMISS .AND. QARAY(LB).LT.BMISS) THEN PA = PARAY(LA) PB = PARAY(LB) IF(PA.NE.PB) THEN WK = LOG(P/PB) / LOG(PA/PB) ELSE WK = 0. ENDIF PILNLNP = QARAY(LB) + (QARAY(LA)-QARAY(LB)) * WK ENDIF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PRISO PRINT LIST OF ISOLATED STATIONS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PRINT LIST OF ISOLATED STATIONS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL PEVENT C OUTPUT FILES: C FT06F001 - PRINT FILE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE PRISO C C PRINT LIST OF ISOLATED STATIONS TO UNIT 6. C COMMON /ISO/ IDISO(899), NUM WRITE(6,500) (IDISO(I),I=1,NUM) 500 FORMAT('1LIST OF ISOLATED STATIONS:',/, . (10(2X,I6))) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PRVTEMP FIND PREVIOUS LEVEL WITH GOOD TEMP C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: FIND THE PREVIOUS LEVEL WITH A GOOD TEMPERATURE. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL PRVTEMP(INIT, ITYP, IDEC, I0, NEXT) C INPUT ARGUMENT LIST: C INIT - FIRST LEVEL TO TRY C ITYP - LEVEL TYPE C IDEC - DECISION C I0 - INDEX OF FIRST LEVEL TO CONSIDER C C OUTPUT ARGUMENT LIST: C NEXT - NEXT LEVEL WITH GOOD TEMPERATURE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE PRVTEMP(INIT,II,ITYP,IDEC,P,I0,NEXT) REAL P(*) INTEGER ITYP(*), IDEC(*) C FIND PREVIOUS LEVEL (AT DIFF PRESS)WITH GOOD TEMPERATURE. C RETURN ANSWER IN NEXT. DO I=INIT,I0,-1 NEXT = I IF(ITYP(I).LE.3.AND.IDEC(I).LE.1 & .AND.P(I).NE.P(II)) GO TO 10 ENDDO NEXT = I0 - 1 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: QCOI THE QC ANALYSIS KERNAL C PRGMMR: DEAVEN ORG: W/NMC22 DATE: 88-02-05 C PRGMMR: WOOLLEN ORG: W/NMC22 DATE: 90-03-24 C C ABSTRACT: COMPUTES AND SETS UP THE COEFFICIENT MATRIX AND RIGHT C HAND SIDES. SOLVES THE MATRIX PROBLEMS. APPLIES THE COMPUTED C WEIGHTS TO THE RESIDUALS TO OBTAIN THE ANALYSIS INCREMENTS AND C ANALYSIS ERRORS. C C USAGE: C INPUT ARGUMENTS: C C OUTPUT ARGUMENTS: C C SUBPROGRAMS CALLED: C UNIQUE: - COORS,DRCTSL C C LIBRARY: C C EXIT STATES: C C REMARKS: C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ C----------------------------------------------------------------------- SUBROUTINE QCOI(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,HINC,HSTD,WTS) DIMENSION IDH (4,LDIM,IDIM,NOBN) DIMENSION OINC( LDIM,IDIM,NOBN) DIMENSION HINC( LDIM,IDIM,NOB1:NOB2) DIMENSION HSTD( LDIM,IDIM,NOB1:NOB2) DIMENSION WTS (4,LDIM,IDIM,NOB1:NOB2) COMMON /OBLIST/ NOBN,INOB(1000),IMAP(360,181) C-CRA COMMON /CORP /CHLP(0:1500),CVC,IFA(4,4) COMMON /CORP /CHLP(0:1500),CVC COMMON /CORPI/IFA(4,4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) DIMENSION NCIND(1000+1),NDIM(1000),NKOBS(4000), . XXCP(4000),YYCP(4000),IICP(4000), . XXOBS(4000),YYOBS(4000),FCAOBS(4000), . CHTWV(10000),DIST(10000),ZZ(10000), . XXI(10000),YYI(10000),XXJ(10000),YYJ(10000) DIMENSION FAALL(1000,10),RAALL(1000,4,1),DOTPRD(1000,1) DATA MAXDIM /4/ DATA MINDIM /2/ DATA MAXOBS /1000/ DATA NFT /1/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C SEE IF THIS IS A ONE SHOT DEAL C ------------------------------ IF(NOB1.EQ.NOB2) THEN L1 = L0 L2 = L0 IV1 = IV0 IV2 = IV0 ELSE L1 = 1 L2 = L0 IV1 = 1 IV2 = IV0 ENDIF C LOOP OVER VARIABLES AND LEVELS C ------------------------------ DO 100 IV=IV1,IV2 DO 100 LEV=L1,L2 LL = LEV IPRES = PMAND(LL) C CLEAR OUT THE GARBAGE IN THE MATRIX ARRAYS C ------------------------------------------ DO 1 J=1,MAXDIM*(MAXDIM+1)/2 DO 1 I=1,MAXOBS 1 FAALL(I,J) = 0. DO 2 K=1,NFT DO 2 J=1,MAXDIM DO 2 I=1,MAXOBS 2 RAALL(I,J,K) = 0. DO 3 NOB=NOB1,NOB2 HINC(LEV,IV,NOB) = VMSG(IV) HSTD(LEV,IV,NOB) = VMSG(IV) DO 3 I=1,4 WTS(I,LEV,IV,NOB) = 0. 3 CONTINUE C STORE THE DATA INDEXS FOR THIS LEVEL C ------------------------------------ IVMAX = 0 NXXYY = 0 NCIND(1) = 1 DO 20 NOB=NOB1,NOB2 NXXYY = NXXYY + 1 MDIM = 0 IF(IDH(MINDIM,LEV,IV,NOB).NE.0) THEN DO 10 N=1,MAXDIM INDEX = IDH(N,LEV,IV,NOB) IF(INDEX.NE.0) THEN IVMAX = IVMAX + 1 IICP(IVMAX) = NOB NKOBS(IVMAX) = INDEX IF(N.GE.MINDIM) MDIM = N ENDIF 10 CONTINUE ENDIF NDIM(NXXYY) = MDIM NCIND(NXXYY+1) = NCIND(NXXYY) + MDIM 20 CONTINUE C PULL THE OBSERVATION INFORMATION OUT OF STORAGE C ----------------------------------------------- DO 30 I=1,IVMAX IOB = IICP(I) NOB = NKOBS(I) XXCP(I) = SLON(IOB) YYCP(I) = SLAT(IOB) XXOBS(I) = SLON(NOB) YYOBS(I) = SLAT(NOB) FCAOBS(I) = OINC(LEV,IV,NOB) CHTWV(I) = CHLP(IPRES) 30 CONTINUE C INITIALIZE THE MATRIX DIAGONAL TERMS C ------------------------------------ DO 40 IGRP=1,NXXYY DO 40 IOB=1,NDIM(IGRP) FAALL(IGRP,IFA(IOB,IOB)) = 1.5 40 CONTINUE C COMPUTE THE RIGHT HAND SIDES C ---------------------------- CALL COORS(IVMAX,CHTWV,XXOBS,YYOBS,XXCP,YYCP,DIST,ZZ) C STACK THE RHS TERMS IN THE SOLVER ARRAY C --------------------------------------- DO 50 IGRP=1,NXXYY DO 50 IOB=1,NDIM(IGRP) I = NCIND(IGRP) + IOB - 1 RAALL(IGRP,IOB,1) = ZZ(I) 50 CONTINUE C COMPUTE THE MATRIX TERMS AND STORE IN THE SOLVER C ------------------------------------------------ M = 0 DO 60 IGRP=1,NXXYY IF(NDIM(IGRP).GT.0) THEN DO 55 IOB = 1,NDIM(IGRP)-1 DO 55 JOB = IOB+1,NDIM(IGRP) I = NCIND(IGRP) + IOB - 1 J = NCIND(IGRP) + JOB - 1 M = M+1 XXI(M) = XXOBS(I) YYI(M) = YYOBS(I) XXJ(M) = XXOBS(J) YYJ(M) = YYOBS(J) CHTWV(M) = CHLP(IPRES) 55 CONTINUE ENDIF 60 CONTINUE CALL COORS(M,CHTWV,XXI,YYI,XXJ,YYJ,DIST,ZZ) M = 0 DO 70 IGRP=1,NXXYY IF(NDIM(IGRP).GT.0) THEN DO 65 IOB = 1,NDIM(IGRP)-1 DO 65 JOB = IOB+1,NDIM(IGRP) M = M+1 FAALL(IGRP,IFA(IOB,JOB)) = ZZ(M) 65 CONTINUE ENDIF 70 CONTINUE C CALL THE MATRIX SOLVER C------------------------ CALL DRCTSL(FAALL,RAALL,DOTPRD,NDIM,MAXDIM,NXXYY,NFT,LEV,IV) C AFTER SOLUTION OF ALL THE PROBLEMS STORE THE RESULTS C ---------------------------------------------------- DO 80 IGRP=1,NXXYY IF(NDIM(IGRP).GT.0 .AND. DOTPRD(IGRP,1).GT.0.) THEN NNOB = IICP(NCIND(IGRP)) SUM = 0. DO 75 IOB=1,NDIM(IGRP) I = NCIND(IGRP) + IOB - 1 SUM = SUM + FCAOBS(I) * RAALL(IGRP,IOB,1) WTS(IOB,LEV,IV,NNOB) = RAALL(IGRP,IOB,1) 75 CONTINUE IF(ABS(OINC(LEV,IV,NNOB)).LT.VMAX(IV)) THEN HINC(LEV,IV,NNOB) = OINC(LEV,IV,NNOB) - SUM ELSE HINC(LEV,IV,NNOB) = VMSG(1) ENDIF HSTD(LEV,IV,NNOB) = SQRT(1.5 - DOTPRD(IGRP,1)) ENDIF 80 CONTINUE 100 CONTINUE RETURN END C************************************************************ C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RES CALCULATE HYDROSTATIC RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-02-02 C C ABSTRACT: CALCULATE HYDROSTATIC RESIDUAL FOR MANDATORY C LAYERS. ACCOUNT FOR MISSINGS. C C PROGRAM HISTORY LOG: C 89-02-02 ORIGINAL W. COLLINS C C USAGE: CAL RES(Z1,Z2,T1,T2,L1,L2,A,B,SS,S,BSUM,SBIG) C C C INPUT ARGUMENT LIST: C (Z1,T1) - LOWER HEIGHT (M) AND TEMPERATURE (CELCIUS) C (Z2,T2) - UPPER HEIGHT AND TEMPERATURE C (L1,L2) - INDICES FOR TWO LEVELS C A,B - ARRAYS OF COEFFICIENTS C SS - ARRAY OF ADMISSIBLE RESIDUALS C C OUTPUT ARGUMENT LIST: C S - RESIDUAL FOR LAYER C BSUM - B FOR LAYER C SBIG - ADMISSIBLE RESIDUAL FOR LAYER C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE RES(Z1,Z2,T1,T2,L1,L2,A,B,SS,S,BSUM,SBIG) REAL A(20), B(20), SS(20) ASUM = 0. BSUM = 0. SSUM = 0. L2M = L2 - 1 DO 10 L=L1,L2M ASUM = ASUM + A(L) BSUM = BSUM + B(L) SSUM = SSUM + SS(L)**2 10 CONTINUE SBIG = SQRT(SSUM) S = Z2 - Z1 - ASUM - BSUM*(T1+T2) RETURN END C************************************************************* SUBROUTINE RESID(Z,T,MAN,S,SBIG,BSUM,ISL,ISU,KMAX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RESID CALCULATE HYDROSTATIC RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 88-09-14 C C ABSTRACT: CALCULATE HYDROSTATIC RESIDUALS FOR MANDATORY C LAYERS. ACCOUNT FOR MISSINGS. C C PROGRAM HISTORY LOG: C 88-09-14 ORIGINAL W. COLLINS C C USAGE: CALL RESID(Z, T, MAN, S, SBIG, BSUM, ISL, C ISU, KMAX) C C INPUT ARGUMENT LIST: C Z - HEIGHT PROFILE (METERS) C T - TEMPERATURE PROFILE (CELSIUS) C MAN - NUMBER OF MANDATORY LEVELS C SBIG - ADMISSIBLE RESIDUALS (METERS) C C OUTPUT ARGUMENT LIST: C S - HYDROSTATIC RESIDUALS (METERS) C BSUM - B FOR OUTPUT LAYERS C ISL - INDICES FOR LOWER LAYER LIMITS C ISU - INDICES FOR UPPER LAYER LIMITS C KMAX - NUMBER OF OUTPUT LAYERS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ DIMENSION Z(*), T(*), S(*), SBIG(*), ISL(21), ISU(21), & BSUM(20) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) COMMON /MSGS/ VMAX(2),VMSG(2) RES(Z1,Z2,T1,T2,A0,B0) = Z2 - Z1 - A0 - B0 * (T1+T2) MANM = MAN - 1 C C COMPUTE RESIDUALS. C DO 10 K=1,20 S(K) = 0. SBIG(K) = 0. BSUM(K) = 1.E-6 ISL(K) = 0 ISU(K) = 0 10 CONTINUE IK = 1 KMAX = IK - 1 DO 50 K=1,MANM IF(Z(K).GT.VMAX(1).OR.T(K).GT.VMAX(2)) GO TO 50 C C KLOW IS LOWER LEVEL WITHOUT MISSING DATA. C KLOW = K KP = K + 1 DO 20 KK=KP,MAN KHIGH = KK IF(Z(KK).LT.VMAX(1).AND.T(KK).LT.VMAX(2)) GO TO 25 20 CONTINUE GO TO 50 C C KHIGH IS UPPER LEVEL WITHOUT MISSING DATA. C 25 ASUM = 0. SSUM = 0. KHIGHM = KHIGH - 1 ISL(IK) = KLOW ISU(IK) = KHIGH DO 30 KK=KLOW,KHIGHM ASUM = ASUM + A(KK) BSUM(IK) = BSUM(IK) + B(KK) SSUM = SSUM + SS(KK)**2 30 CONTINUE SBIG(IK) = SQRT(SSUM) S(IK)=RES(Z(KLOW),Z(KHIGH),T(KLOW),T(KHIGH), & ASUM,BSUM(IK)) IK = IK + 1 C C KMAX IS NUMBER OF LEVELS OF RESIDUALS. C KMAX = IK - 1 50 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SEARCH C PRGMMR: WOOLLEN ORG: NMC22 DATE: 90-11-01 C C ABSTRACT: SELECTS OBS TO BE USED FOR OI QUALITY CONTROL. FIVE C FIVE GROUPS OF OBSERVATIONS ARE SELECTED FOR EACH OB BEING C CHECKED. ANY OB SELECTED MUST HAVE PASSED THE QC IN THE PREVIOUS C ITERATION. INDEXES OF EACH SELECTED OB ARE STORED IN A LIST C WHICH THE OI ANALYSIS (SUBROUTINE QCOI) USES TO PERFORM THE C QC ANALYSIS ON A PACKAGE OF OBS BEING CHECKED AT ONE TIME. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN C C USAGE: C INPUT ARGUMENTS: C C INPUT ARGUMENTS: IN COMMON /CKLIST/ C C OUTPUT ARGUMENTS: IN COMMON /HVECT/ C C SUBPROGRAMS CALLED: C UNIQUE: - CHDIST C C LIBRARY: C C EXIT STATES: C C REMARKS: C C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE SEARCH(LDIM,IDIM,L0,IV0,NOB1,NOB2,IDH,OINC,DMAX) DIMENSION IDH (4,LDIM,IDIM,NOBN) DIMENSION OINC( LDIM,IDIM,NOBN) DIMENSION DMAX( LDIM,IDIM ) COMMON /OBLIST/ NOBN,INOB(1000),IMAP(360,181) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /SERCH / RSCAN,DELLAT,DELLON(181) DIMENSION NIND(1000),RLAT(1000),RLON(1000), . DIST(1000),DIRN(1000),OBOK(1000), . NDIR(1000),IA(2),IB(2) LOGICAL OBOK DATA PI180/.0174532/, RADE/6371./ DATA MAXCYL/1000/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- C SEE IF THIS IS A ONE SHOT DEAL C ------------------------------ IF(NOB1.EQ.NOB2) THEN L1 = L0 L2 = L0 IV1 = IV0 IV2 = IV0 ELSE L1 = 1 L2 = L0 IV1 = 1 IV2 = IV0 ENDIF C LOOP OVER STATIONS TO BE CHECKED C -------------------------------- DO 60 NOB=NOB1,NOB2 BLAT = SLAT(NOB) BLON = SLON(NOB) C ITEMIZE REPORTS IN THE SEACH CYLINDER C ------------------------------------- LASTN = 0 NOBS = 0 J1 = MAX(BLAT-DELLAT,-90.) + 91 J2 = MIN(BLAT+DELLAT, 90.) + 91 DO 11 J=J1,J2 I1 = MOD(BLON-DELLON(J)+360.,360.) + 1 I2 = MOD(BLON+DELLON(J) ,360.) + 1 IF(I1.LT.I2) THEN IA(1) = I1 IB(1) = I2 KK = 1 ELSE IF(I1.GT.I2) THEN IA(1) = I1 IB(1) = 360 IA(2) = 1 IB(2) = I2 KK = 2 ELSE IF(I1.EQ.I2) THEN IA(1) = 1 IB(2) = 360 KK = 1 ENDIF DO 11 K=1,KK DO 10 N=IMAP(IA(K),J),IMAP(IB(K),J) IF(N.NE.LASTN .AND. INOB(N).NE.NOB) THEN NOBS = NOBS+1 NIND(NOBS) = INOB(N) RLAT(NOBS) = SLAT(INOB(N)) RLON(NOBS) = SLON(INOB(N)) ENDIF 10 CONTINUE LASTN = N-1 11 CONTINUE C IF(NOBS.GT.MAXCYL) CALL SABORT('SEARCH - NOBS GT MAXCYL') C COMPUTE DISTANCE AND DIRECTION FROM THE CYLINDER CENTER C ------------------------------------------------------- CALL CHDIST(BLON,BLAT,RLON,RLAT,DIST,DIRN,NOBS) C CATAGORIZE OBS BY DISTACE AND DIRECTION C --------------------------------------- DO 20 N=1,NOBS NDIR(N) = MIN(IFIX(DIRN(N)/90.) + 1.,4.) 20 CONTINUE C LOOP OVER THE OBSERVATION LEVELS AND VARIABLES TO BE CHECKED C ------------------------------------------------------------ NPICS = 0 NPICV = 0 DO 50 L=L1,L2 DO 50 IV=IV1,IV2 IF(ABS(OINC(L,IV,NOB)).LT.VMAX(1)) NPICV = NPICV + 1 C CLEAR THE SEARCH ARRAY C ---------------------- DO 30 I=1,4 IDH(I,L,IV,NOB) = 0 30 CONTINUE C MARK MISSING DATA C ----------------- DO 35 N=1,NOBS OBOK(N) = ABS(OINC(L,IV,NIND(N))) .LT. DMAX(L,IV) 35 CONTINUE C PICK CLOSEST DATA FROM EACH DIRECTION C ------------------------------------- IF(ABS(OINC(L,IV,NOB)).LT.VMAX(IV)) THEN NPIC = 0 DO 45 J=1,4 DMIN = 10E10 DO 40 N=1,NOBS IF(NDIR(N).EQ.J .AND. OBOK(N) .AND. DIST(N).LT.DMIN) THEN DMIN = DIST(N) NN = N ENDIF 40 CONTINUE IF(DMIN.LT.RSCAN) THEN NPIC = NPIC+1 NPICS = NPICS + 1 IDH(NPIC,L,IV,NOB) = NIND(NN) ENDIF 45 CONTINUE ENDIF 50 CONTINUE IF(NPICS.EQ.0 .AND. NPICV.NE.0) CALL ISOLAT(ID(NOB)) 60 CONTINUE RETURN END C************************************************************ SUBROUTINE SELCT(MSK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SELCT MAKE MASK FOR COMPUTING STATISTICS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: MAKE MASK (0,1) FOR VARIABLES TO INCLUDE OR EXCLUDE C FROM STATISTICS. EXCLUDE VALUES WITH KNOWN PROBLEM. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL SELCT(MSK) C OUTPUT ARGUMENT LIST: C MSK - MASK, VALUES (0,1) C C OUTPUT FILES: C FT06F001 - PRINT FILE, LIST OF EXCLUDED STATIONS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ INTEGER MSK(899) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /MSGS/ VMAX(2),VMSG(2) NPLVLM = NPLVL - 1 DO 30 I=1,NOBS IHY = 0 MSK(I) = 0 DO 5 L=1,NPLVLM IF(HYRES(L,I).GT.VMAX(1).OR.SBIG(L,I).GT.VMAX(1)) GO TO 5 IF(ABS(HYRES(L,I)).GT.SBIG(L,I) & .OR.ABS(HYRES(L,I)).GT.100.) IHY = IHY + 1 5 CONTINUE DO 20 IV=1,2 DO 10 L=1,NPLVL CALL UNPACK(NERR(L,IV,I,1),IHSC,IINC,IHOI, & IVOI,IBAS,IIPL,IHPL) IF( IHSC.NE.0 & .OR. IHY. NE.0 & .OR. IINC.EQ.2 & .OR. IHOI.EQ.2 & .OR. IVOI.EQ.2 & .OR. IBAS.EQ.2 & .OR. IIPL.EQ.2 & .OR. IHPL.EQ.2) MSK(I) = 1 10 CONTINUE 20 CONTINUE 30 CONTINUE RETURN END C************************************************************ C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHELL SHELL SORT BASED ON V. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 12-24-91 C C ABSTRACT: SHELL SORT, BASED UPON THE VALUES OF V. C IV IS THE ORIGINAL INDEX OF EACH ELEMENT OF V. C C PROGRAM HISTORY LOG: C 91-12-24 W. COLLINS C C USAGE: CALL SHELL(V,IV,MAX) C INPUT ARGUMENT LIST: C V - VARIABLE C MAX - DIMENSION OF V C IREV = 0 FOR ASCENDING ORDER C <> 0 FOR DESCENDING ORDER C C OUTPUT ARGUMENT LIST: C IV - ORIGINAL INDEX OF VARIABLE C V - VARIABLE, SORTED. C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE SHELL(V,IV,MAX,IREV) REAL V(MAX) INTEGER IV(MAX) DO 10 I=1,MAX IV(I) = I 10 CONTINUE IOFSET = MAX/2 20 CONTINUE LIM = MAX - IOFSET 30 CONTINUE ISW = 0 DO 40 I=1,LIM IF(V(I).GT.V(I+IOFSET)) THEN VT = V(I) V(I) = V(I+IOFSET) V(I+IOFSET) = VT IVT = IV(I) IV(I) = IV(I+IOFSET) IV(I+IOFSET) = IVT ISW = I ENDIF 40 CONTINUE LIM = ISW - IOFSET IF(ISW.NE.0) GO TO 30 IOFSET = IOFSET/2 IF(IOFSET.GT.0) GO TO 20 IF(IREV.NE.0) THEN C REVERSE SORT ORDER... NH = MAX/2 DO I=1,NH ITEMP = IV(I) IV(I) = IV(MAX+1-I) IV(MAX+1-I) = ITEMP TEMP = V(I) V(I) = V(MAX+1-I) V(MAX+1-I) = TEMP ENDDO ENDIF RETURN END SUBROUTINE SHIFT(X,Y,L,IV,NS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHIFT SHIFT DATA FROM Y TO X. CHANGE FORM. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: RESTRUCTURE DATA. SHIFT FROM Y TO X. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL SHIFT(X, Y, L, IV, NS) C INPUT ARGUMENT LIST: C Y - VARIABLE C L - LEVEL C IV - VARIABLE C NS - NO. STATIONS C C OUTPUT ARGUMENT LIST: C X - VARIABLE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C REARRANGE Y INTO X. C REAL X(899), Y(21,2,899) DO 10 I=1,NS X(I) = Y(L,IV,I) 10 CONTINUE RETURN END C********************************************************** SUBROUTINE SHIFT1(X,Y,L,NS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHIFT1 SHIFT DATA FROM Y TO X. CHANGE FORM. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: RESTRUCTURE DATA. SHIFT FROM Y TO X. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL SHIFT1(X, Y, L, IV, NS) C INPUT ARGUMENT LIST: C Y - VARIABLE C L - LEVEL C NS - NO. STATIONS C C OUTPUT ARGUMENT LIST: C X - VARIABLE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C REARRANGE Y INTO X. C REAL X(899), Y(20,899) DO 10 I=1,NS X(I) = Y(L,I) 10 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SIGTCH GET PROPOSED SIG LVL TEMP CORRECTION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 90-02-28 C C ABSTRACT: GET PROPOSED SIGNIFICANT LEVEL TEMPERATURE CORRECTION. C ASSIGN FLAGS AND DECISIONS. C C PROGRAM HISTORY LOG: C 90-02-28 W. COLLINS C 94-11-01 W. COLLINS USE BUFR QUALITY MARKS C C USAGE: CALL SIGTCH(TI, VM, TSTAR, VA, T, TNEW, IDECSN, C IER, TQD, TTRY) C INPUT ARGUMENT LIST: C TI - TEMPERATURE INCREMENTS (C) C VM - VERTICAL RESIDUAL OF TEMP, MAND LVLS ONLY (C) C TSTAR - TEMP GIVING HYDROSTATIC RESID = 0. (C) C VA - VERTICAL RESIDUAL OF TEMP, ALL LVLS (C) C T - TEMPERATURE (C) C C OUTPUT ARGUMENT LIST: C TNEW - NEW TEMPERATURE (C) C IDECSN - DECISION C = 3 QUESTIONABLE VALUE C = 4 BAD VALUE C IER - ERROR TYPE C = 502 CORRECTION C = 503 RESIDUALS NOT CLOSE ENOUGH TO EACH OTHER C FOR CORRECTION C = 505 PROPOSED CORRECTION IS TOO SMALL C TQC - TEMPERATURE QUALITY MARK (TABLE VALUE) C TTRY - SAVED TEMPERATURE FOR PRINTING C C ATTRIBUTES: C LANGUAGE: FORTRAN 77, VERSION 2.5 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE SIGTCH(TI,VM,TSTAR,VA,T,TNEW,IDECSN, & IER,TQD,TTRY) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DATA CLOSELIMIT /4./ C FORM PROVISIONAL CORRECTION FROM TI AND VM. C REQUIRE THAT TI AND VM BE CLOSE TO EACH OTHER C BEFORE PROCEEDING FURTHER. NUM = 0 SUM = 0. TCORR = 0. IF(ABS(TI-VM).LE.2.*CLOSELIMIT & .OR. TI.GT.VMAX(2) & .OR. VM.GT.VMAX(2)) THEN IF(TI.LT.VMSG(2)) THEN SUM = SUM - TI NUM = NUM + 1 ENDIF IF(VM.LT.VMSG(2)) THEN SUM = SUM - VM NUM = NUM + 1 ENDIF IF(NUM.NE.0) THEN TCORR = SUM/NUM ENDIF C IS THIS CLOSE TO TSTAR. IF( ABS(-TCORR + TSTAR) .LE. CLOSELIMIT ) THEN C IMPLICATION IS THAT THE ERROR IS A COMMUNICATION ERROR C AND IS ISOLATED SO THAT TSTAR AND VA MAY ALSO BE USED. IF(TSTAR.LT.VMSG(2)) THEN SUM = SUM + TSTAR NUM = NUM + 1 ENDIF IF(VA.LT.VMSG(2)) THEN SUM = SUM - VA NUM = NUM + 1 ENDIF IF(NUM.NE.0) THEN TCORR = SUM/NUM ENDIF ENDIF ENDIF IF(TCORR.EQ.0.) THEN C RESIDUALS NOT CLOSE ENOUGH TO EACH OTHER. IER = 503 TNEW = T TTRY = T + TCORR IF((ABS(TI).GT.2.0*DTALL .AND. TI.LT.VMAX(2)) & .OR. (ABS(VM).GT.2.0*DTALL .AND. VM.LT.VMAX(2))) THEN IDECSN = 4 TQD = 13. ELSE IDECSN = 3 TQD = 3. ENDIF ELSEIF(ABS(TCORR).GT.1.5*CLOSELIMIT) THEN C LIKELY GOOD CORRECTION. IER = 502 ICOR = 10. * TCORR IT = 10. * T TCOR = ICOR TT = IT IDECSN = 1 TQD = 16. CALL SIMPLE(TCOR,TT,ALLT,NT) TCORR = 0.1 * TCOR TNEW = 0.1 * (TCOR + TT) TTRY = TNEW ELSE C PROPOSED CORRECTION IS TOO SMALL. IER = 505 TNEW = T TTRY = T + TCORR IF((ABS(TI).GT.2.0*DTALL .AND. TI.LT.VMAX(2)) & .OR. (ABS(VM).GT.2.0*DTALL .AND. VM.LT.VMAX(2))) THEN IDECSN = 4 TQD = 13. ELSE IDECSN = 3 TQD = 3. ENDIF ENDIF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SIGTQC CHECK OF SIG LVL TEMPERATURES C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 90-02-28 C C ABSTRACT: PERFORM CHECK, AND IF POSSIBLE, CORRECTION OF C SIGNIFICANT LEVEL TEMPERATURES (AND PRESSURES IN SOME CASES) C FOR RAWINSONDES. THIS SUBROUTINE COMBINES MANDATORY AND C SIGNIFICANT LEVEL AND CALLS OTHER ROUTINES TO DO THE WORK. C C PROGRAM HISTORY LOG: C 90-02-28 W. COLLINS C 92-05-07 W. COLLINS CHANGES TO USE NEW O.N. 29 FLAGS C 94-11-28 W. COLLINS USE BUFR QUALITY MARKS (TABLE VALUE) C C USAGE: CALL SIGTQC(ZM,TM,P,T,TMG,TG,LMAN,NSIG, C PMQ,ZMQ,TMQ,PPQ,ZZQ,TTQ, C IDENT,XLAT,XLON,SLEV) C INPUT ARGUMENT LIST: C C ZM - MANDATORY LEVEL HEIGHT (M) C TM - MANDATORY LEVEL TEMPERATURE (C) C TMG - MANDATORY LEVEL GUESS TEMP (C) C TG - SIGNIFICANT LEVEL GUESS TEMP (C) C LMAN - NUMBER OF MANDATORY LEVELS C NSIG - NUMBER OF SIGNIFICANT LEVELS C IDENT - STATION ID C XLAT - STATION LATITUDE (DEG-NORTH) C XLON - STATION WEST LONGITUDE (DEG-WEST) C SELV - STATION ELEVATION (M) C C OUTPUT ARGUMENT LIST: C C PS - SIGNIFICANT LEVEL PRESSURE (HPA) C TS - SIGNIFICANT LEVEL TEMPERATURE (C) C PMQ - MAND LVL PRESSURE QUALITY MARKS (TABLE VALUE) C ZMQ - MAND LVL HEIGHT QUALITY MARKS (TABLE VALUE) C TMQ - MAND LVL TEMPERATURE QUALITY MARKS (TABLE VALUE) C PPQ - SIG LVL PRESSURE QUALITY MARKS (TABLE VALUE) C ZZQ - SIG LVL HEIGHT QUALITY MARKS (TABLE VALUE) C TTQ - SIG LVL TEMPERATURE QUALITY MARKS (TABLE VALUE) C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: , CRAY C C$$$ SUBROUTINE SIGTQC(ZM,TM,P,T,TMG,TG,LMAN,NSIG, & PMQ,ZMQ,TMQ,PPQ,ZZQ,TTQ,IDM,IDS, & IOBS,IDENT,HOUR,XLAT,XLON,ZS) REAL ZM(*), TM(*), P(*), T(*), TMG(21), & Z(895), PC(895), XPC(895), ZC(895), TC(895), & TFU(895), TGES(21,899), TG(895), TD(895), TTRY(895), TTRYC(895), & PD(895), XPD(895), ZD(895), TID(895), HMD(895), HAD(895), & VMD(895), VAD(895), TSTRD(895), TNEW(895), TNEWC(895), & TIC(895), HMC(895), HAC(895), VMC(895), VAC(895), TSTARC(895), & PMQ(21), ZMQ(21), TMQ(21), PPQ(895), ZZQ(895), TTQ(895), & PQD(895), ZQD(895), TQD(895), PQC(895), ZQC(895), TQC(895) INTEGER INDX(895), ITYP(895), MB(895), MA(895), NB(895), NA(895), & IDECC(895), IHYDC(895), IERRC(895), INDXD(895), ITYPD(895), & IDECD(895), IHYDD(895), IERRD(895), IDM(*), IDS(*) CHARACTER*1 CA CHARACTER*4 CP925F, CDATE CHARACTER*132 LINE C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /DATEC/ CDATE(2), IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE(2) COMMON /DATEI/ IYR, IMO, IDY, IHR C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /REPRT/ PSSU, ZU(21), TU(21), PSIGU(895), TSIGU(895), & P925U, T925U, CP925F COMMON /SLIMS/ RLIMM(21), RLIMS(21) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) DATA CA /'A'/ DATA NUMSTATION /0/ NUMSTATION = NUMSTATION + 1 C NOTE! VARIABLES WITH LAST CHARACTER 'D' ARE FOR PARTIAL C PROFILE, FROM ONE MANDATORY LEVEL TO THE NEXT. C PUT DATA INTO COMBINDED ARRAYS PC, TC AND ZC. ALSO SET C UP ARRAYS THAT POINT TO NEIGHBORS (VERTICALLY). LOOK AT C SUBROUTINE FULL FOR EXPLANATION. CALL FULL(IDENT,HOUR,P,ZS,T,PPQ,ZZQ,TTQ,NSIG, & PMAND,ZM,TM,PMQ,ZMQ,TMQ,LMAN, & PC,XPC,ZC,TC,TNEWC,PQC,ZQC,TQC,MC,INDX,ITYP,TTRYC) C CHECKS LAPSE RATES OF MANDATORY LEVEL TEMPERATUES THAT C WERE CORRECTED, THUS AVOIDING OCCASSIONAL ERRONEOUS CORRS. C NOTE... NOT ALL INFORMATION IS PASSED IN THE CALL, MUCH C IS IN COMMONS. C IF A CORRECTION IS DEEMED TO BE BAD, 200 IS ADDED TO THE C HYDROSTATIC TYPE AND THE DECISION IS SET TO 3. C ALSO SET UP ARRAYS OF DECISIONS: IDECC C AND ERROR TYPES: IHYDC FOR ALL LEVELS. CALL LAPSE(PC,XPC,TTRYC,TMG,MC,INDX,ITYP,IDENT,HOUR, & IDECC,IHYDC,PQC,ZQC,TQC) C SOLVE FOR INDICES OF LEVELS ABOVE AND BELOW SATISFYING C VARIOUS CRITERIA. CALL NEXTS(ITYP,MC,MB,MA,NB,NA) C CHECK FOR COINCIDENT MANDATORY AND SIGNIFICANT LEVELS. CALL MANSIG(PC,TTRYC,PQC,ZQC,TQC,ITYP,MC) C FORM TEMPERATURE INCREMENTS ON SIG LVLS. CALL TINCS(TC,TG,TMG,LMAN,NSIG,INDX,ITYP,TIC) C CALCULATE VERTICAL RESIDUALS. CALL VRES(PC,XPC,TC,ZC,INDX,ITYP,MC,MB,MA,NB,NA,VMC,VAC) C CALCULATE HYDROSTATIC RESIDUAL BETWEEN EACH PAIR OF COMPLETE C MANDATORY LEVELS. CALCULATE FOR MAND LVL DATA ONLY AND FOR C ALL LEVELS. ASSIGN RESULTS TO EACH SIGNIFICANT LEVEL BETWEEN C THE COMPLETE MANDATORY LEVELS. C (HERE, THE TERM 'COMPLETE' REFERS TO A LEVEL CONTAINING BOTH C A HEIGHT AND TEMPERATURE THAT ARE NON-MISSING AND WITHOUT C ERROR SUSPICION.) CALL HYD(PC,XPC,TC,ZC,INDX,ITYP,MC,IDECC,HMC,HAC) C COMPUTE TEMPERATURE INCREMENTS, TSTAR, AT SIGNIFICANT LEVELS C WHICH GIVE ZERO RESIDUALS. CALL TSTARS(PC,ZC,TC,INDX,ITYP,MC,TSTARC) C STORE INFORMATION FOR IERR, TNEW. DO I=1,MC IERRC(I) = 0 TNEWC(I) = TC(I) ENDDO C FIND THE FIRST MANDATORY LEVEL WITH TEMPERATURE. INIT = 1 CALL NEXMAN(INIT,ITYP,IDECC,MC,I1) IF(I1.GE.MC) RETURN C AND NEXT. 100 CONTINUE INIT = I1 + 1 CALL NEXMAN(INIT,ITYP,IDECC,MC,I2) IF(I2.GT.MC) GO TO 200 C STORE INFORMATION IN LOCAL ARRAYS FOR SENDING TO C THE DMA FOR SIG LVL TEMPERATURES: DMASIG. IF(I2.EQ.I1+1) THEN I1 = I2 GO TO 100 ENDIF C STORE BASIC INFORMATION. DO II=I1,I2 I = II - I1 + 1 PD(I) = PC(II) XPD(I) = XPC(II) ZD(I) = ZC(II) TD(I) = TC(II) TTRY(I) = TTRYC(II) INDXD(I) = INDX(II) ITYPD(I) = ITYP(II) IDECD(I) = IDECC(II) IHYDD(I) = IHYDC(II) ENDDO C NOW STORE RESIDUALS. DO II=I1+1,I2-1 I = II - I1 + 1 TID(I) = TIC(II) HMD(I) = HMC(II) HAD(I) = HAC(II) VMD(I) = VMC(II) VAD(I) = VAC(II) TSTRD(I) = TSTARC(II) ENDDO C AND FLAGS. DO II=I1,I2 I = II - I1 + 1 PQD(I) = PQC(II) ZQD(I) = ZQC(II) TQD(I) = TQC(II) ENDDO C CALL DMA FOR SIGNIFICANT LEVEL TEMPERATURES. NUM = I2-I1+1 CALL DMASIG(PD,XPD,ZD,TD,I1,INDX,ITYPD,IDECD,IHYDD, & TID,HMD,HAD,VMD,VAD,TSTRD, & PQD,ZQD,TQD,NUM,TNEW,TTRY,IERRD) C PUT DATA BACK INTO 'COMBINED' AND ORIGINAL ARRAYS. DO II=I1,I2 I = II-I1+1 TNEWC(II) = TNEW(I) TTRYC(II) = TTRY(I) IDECC(II) = IDECD(I) IERRC(II) = IERRD(I) PQC(II) = PQD(I) ZQC(II) = ZQD(I) TQC(II) = TQD(I) HAC(II) = HAD(I) J = INDX(II) IF(ITYP(II).LT.2) THEN T(J) = TNEW(I) PPQ(J) = PQD(I) ZZQ(J) = ZQD(I) TTQ(J) = TQD(I) IDS(J) = IDECC(II) ELSE TM(J) = TNEW(I) PMQ(J) = PQD(I) ZMQ(J) = ZQD(I) TMQ(J) = TQD(I) IDM(J) = IDECC(II) ENDIF ENDDO C RETURN FOR THE NEXT GROUP OF LEVELS. I1 = I2 GO TO 100 200 CONTINUE C PRINT PROFILE DATA FOR ANY PROFILE WITH IERRC.NE.0, C IDECC.EQ.1 OR IHYDC.GE.200 AT ANY LEVEL. IN THAT WAY I CAN C SEE THE EFFECT OF POSSIBLY ERRONEOUS MAND LVL TEMP CORRS C ON THE SIG LVL DIAGNOSIS. IERRCOUNT = 0 IDECCOUNT = 0 IHYDCOUNT = 0 DO I=1,MC IF(IERRC(I).NE.0 ) IERRCOUNT = IERRCOUNT + 1 IF(IDECC(I).EQ.1 ) IDECCOUNT = IDECCOUNT + 1 IF(IHYDC(I).GE.200) IHYDCOUNT = IHYDCOUNT + 1 ENDDO IF(IERRCOUNT.NE.0 .OR. IDECCOUNT.NE.0 .OR. IHYDCOUNT.NE.0) THEN WRITE(6,530) IDENT, HOUR, XLAT, XLON, ZS WRITE(6,531) (PC(I),ZC(I),TC(I),TTRYC(I),TNEWC(I), & PQC(I),ZQC(I),TQC(I),INDX(I), & ITYP(I),IDECC(I),IHYDC(I),IERRC(I),TIC(I),HMC(I),HAC(I), & VMC(I),VAC(I),TSTARC(I),I=1,MC) WRITE(60,530) IDENT, HOUR, XLAT, XLON, ZS WRITE(60,531) (PC(I),ZC(I),TC(I),TTRYC(I),TNEWC(I), & PQC(I),ZQC(I),TQC(I),INDX(I), & ITYP(I),IDECC(I),IHYDC(I),IERRC(I),TIC(I),HMC(I),HAC(I), & VMC(I),VAC(I),TSTARC(I),I=1,MC) ENDIF 530 FORMAT('0STATION: ',I6,' HOUR:',F6.0,' (',F7.2,',',F7.2,') ', & ' ZS:',F6.0) 531 FORMAT(' PRESS HT TEMP T-TRY TNEW', & ' PQC ZQC TQC INDX ITYP IDEC IHYD', & ' IERRD TI HM HA VM VA TSTAR'/ & (1X,F6.1,F7.0,3F7.1,3F4.0,5I5,6F7.1)) C WRITE ITEMS TO EVENTS FILE FOR SIGNIFICANT LEVELS. C FIRST TIME, POSITION TO END OF UNIT ISIGUNIT. ISIGUNIT = 13 IF(NUMSTATION.EQ.1) THEN 700 CONTINUE READ(ISIGUNIT,600,END=710) LINE 600 FORMAT(A132) GO TO 700 710 BACKSPACE ISIGUNIT WRITE(62,534) WRITE(62,533) ENDIF DO I=1,MC IF(IERRC(I).GE.500 .OR. IHYDC(I).GE.200) THEN IF(MOD(NUMSTATION,5).EQ.0) WRITE(62,533) WRITE(ISIGUNIT,532) IYR, IMO, IDY, IHR, IDENT, XLAT, XLON, & ZS,PC(I),ZC(I),TC(I),TTRYC(I),TNEWC(I), & PQC(I),ZQC(I),TQC(I),INDX(I), & ITYP(I),IDECC(I),IHYDC(I),IERRC(I),TIC(I),HMC(I),HAC(I), & VMC(I),VAC(I),TSTARC(I) WRITE(62,532) IYR, IMO, IDY, IHR, IDENT, XLAT, XLON, & ZS,PC(I),ZC(I),TC(I),TTRYC(I),TNEWC(I), & PQC(I),ZQC(I),TQC(I),INDX(I), & ITYP(I),IDECC(I),IHYDC(I),IERRC(I),TIC(I),HMC(I),HAC(I), & VMC(I),VAC(I),TSTARC(I) ENDIF ENDDO 532 FORMAT(1X,4I2,I6,F6.2,F7.2,F6.0,F7.1,F7.0,3F7.1, & 3F4.0,I3,2I2,2I4,6F7.1) 533 FORMAT(' DATE IDENT LAT LONG ZS PRES HT', & ' TEMP T-TRY TNEW', & ' PQC ZQC TQC I T D HYD ERR INCR HYD-M', & ' HYD-A VRT-M VRT-A TSTAR') 534 FORMAT('1SIGNIFICANT LEVEL EVENTS FILE--') RETURN END C*************************************************************** SUBROUTINE SIMPLE(COR, VAL, ALL, N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SIMPLE ATTEMPT TO FIND ONE-DIGIT CORRECTION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 88-10-17 C C ABSTRACT: TESTS CORRECTION OF ONE DIGIT OR INTERCHANGE C OF DIGITS OF VAL C WITH A VALUE OF COR WITHIN RANGE SPECIFIED BY ALL. C C PROGRAM HISTORY LOG: C 88-10-17 W. COLLINS C C USAGE: CALL SIMPLE(COR, VAL, ALL, N) C INPUT ARGUMENT LIST: C COR - HYDROSTATIC CORRECTION (UNITS VARY) C VAL - VALUE TO BE CORRECTED (UNITS VARY) C ALL - ARRAY OF ALLOWABLE VARIATION C N - DIMENSION OF ALL C C OUTPUT ARGUMENT LIST: C COR - CORRECTION AS (POSSIBLY) MODIFIED BY C - THIS SUBROUTINE C C ATTRIBUTES: C LANGUAGE: VSFORTRAN C MACHINE: , CRAY C C$$$ C C SUBROUTINE TO TEST CORRECTION OF ONE DIGIT OF VAL C OR TWO OR MORE DIGITS OF VAL FOR PERMUTATION C WITH A VALUE OF COR WITHIN RANGE SPECIFIED BY ALL. C AS AN EXAMPLE: C FOR HEIGHT, ALL MIGHT HAVE VALUES OF 0., -10., +10. C THE VALUES SHOULD BE IN THE ORDER TO BE TESTED. C REAL ALL(N) INTEGER IDIG(10), IDIGT(10), JDIG(10), JDIGT(10) DO 100 NN=1,N DO 10 I=1,10 IDIG(I) = 0 IDIGT(I) = 0 JDIG(I) = 0 JDIGT(I) = 0 10 CONTINUE C C PUT THE DIGITS OF VAL INTO IDIG, BEGINNING WITH THE C UNIT DIGIT AND GOING TO HIGHER DIGITS. C DO NOT PAY ATTENTION TO THE SIGN. C ALSO COUNT NUMBER OF EACH DIGIT IN JDIG. C IVAL = ABS(VAL) IF(IVAL.EQ.0) GO TO 40 DO 30 I=1,10 IDIG(I) = IVAL - 10 * (IVAL/10) II = IDIG(I) + 1 JDIG(II) = JDIG(II) + 1 IVAL = IVAL/10 IF(IVAL.EQ.0) GO TO 40 30 CONTINUE 40 CONTINUE C C MAKE A PROVISIONAL CORRECTION TO VAL. C VALT = VAL + COR + ALL(NN) C C PUT DIGITS OF VALT INTO IDIGT. C ALSO COUNT NUMBER OF EACH DIGIT IN JDIGT. C IVALT = ABS(VALT) IF(IVALT.EQ.0) GO TO 60 DO 50 I=1,10 IDIGT(I) = IVALT - 10 * (IVALT/10) II = IDIGT(I) + 1 JDIGT(II) = JDIGT(II) + 1 IVALT = IVALT/10 IF(IVALT.EQ.0) GO TO 60 50 CONTINUE 60 CONTINUE C C COUNT THE NUMBER OF DIGITS THAT ARE DIFFERENT C BETWEEN IDIG AND IDIGT. C ICNT = 0 DO 70 I=1,10 IF(IDIG(I).NE.IDIGT(I)) ICNT = ICNT + 1 70 CONTINUE C C TEST OF PERMUTATION OF DIGITS. C JCNT = 0 DO 80 I=1,10 JCNT = JCNT + (JDIG(I) - JDIGT(I))**2 80 CONTINUE C C IF (ICNT.EQ.1.(ONE DIGIT) C OR .JCNT.EQ.0) (PERMUTATION OF DIGITS) C THEN COR + ALL(NN) IS ACCEPTABLE. C IF(ICNT.EQ.1.OR.JCNT.EQ.0) THEN COR = COR + ALL(NN) RETURN ENDIF 100 CONTINUE C C IF THIS POINT IS REACHED, THE ORIGINAL COR IS RETAINED. C RETURN END C******************************************************* C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SORT SORT, BASED ON ORDER IN INDX C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 94-03-17 C C ABSTRACT: C SORT RA ACCORDING TO THE ORDER SPECIFIED BY THE C INDICES IN INDX. C C PROGRAM HISTORY LOG: C 94-03-17 W. COLLINS C C USAGE: CALL SORT(RA, INDX, N) C INPUT ARGUMENT LIST: C RA - VARIABLE C INDX - ORDER FOR REARRANGEMENT OF RA C N - DIMENSION OF RA C C OUTPUT ARGUMENT LIST: C RA - VARIABLE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE SORT(RA,INDX,N) C C SORT RA ACCORDING TO THE ORDER SPECIFIED BY THE C INDICES IN INDX. C DIMENSION RA(*), WKSP(899) INTEGER INDX(*) DO J=1,N WKSP(J) = RA(J) ENDDO DO J=1,N RA(J) = WKSP(INDX(J)) ENDDO RETURN END SUBROUTINE ISORT(IA,INDX,N) C C SORT RA ACCORDING TO THE ORDER SPECIFIED BY THE C INDICES IN INDX. C DIMENSION IA(*), IWKSP(899) INTEGER INDX(*) DO J=1,N IWKSP(J) = IA(J) ENDDO DO J=1,N IA(J) = IWKSP(INDX(J)) ENDDO RETURN END SUBROUTINE SORTE C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SORTE SORT EVENTS FILE C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: SORT EVENTS FILE BY STATION WMO IDENTIFIER. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 91-12-24 W. COLLINS MAKE MORE EFFICIENT. C C USAGE: CALL SORTE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C SORT EVENTS FILE ACCORDING TO STATION ID. C INTEGER NI(899), NTMP(899) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) IM = IR-1 DO 100 I=1,IM JL = IR - I DO 90 J=1,JL IF(NEVNT(21,J).GT.NEVNT(21,J+1)) THEN DO 20 II=1,21 NTEMP = NEVNT(II,J) NEVNT(II,J) = NEVNT(II,J+1) NEVNT(II,J+1) = NTEMP 20 CONTINUE TEMP = DHOUR(J) DHOUR(J) = DHOUR(J+1) DHOUR(J+1) = TEMP ENDIF 90 CONTINUE 100 CONTINUE RETURN END C*********************************************************** SUBROUTINE SORTID(ID,IDSORT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SORTID CREATE INDEX OF SORTED STATION ID-S. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CREATE INDEX OF SORTED STATION ID-S. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL SORTID(ID, IDSORT) C INPUT ARGUMENT LIST: C ID - STATION INDEX C C OUTPUT ARGUMENT LIST: C IDSORT - SORTED LIST OF STATION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C ID - STATION ID-S C IDSORT - INDEX OF STATION ID-S IN ORDER C INTEGER ITEMP(899), ID(899), IDSORT(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) NOBSM = NOBS - 1 DO 10 I=1,899 IDSORT(I) = I ITEMP(I) = ID(I) 10 CONTINUE DO 100 I=1,NOBSM JLIM = NOBS - I DO 90 J=1,JLIM IF(ITEMP(J).GT.ITEMP(J+1)) THEN IT = ITEMP(J) ITEMP(J) = ITEMP(J+1) ITEMP(J+1) = IT IT = IDSORT(J) IDSORT(J) = IDSORT(J+1) IDSORT(J+1) = IT ENDIF 90 CONTINUE 100 CONTINUE RETURN END C******************************************************* SUBROUTINE STAT C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: STAT CALCULATE STATISTICS FOR CHECKS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CALCULATE VARIOUS MOMENT STATISTICS FOR INCREMENTS C AND RESIDUALS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL STAT C C OUTPUT FILES: C FT63F001 - PRINT FILE, EVENTS FILE, (AND STATS), FULL FORM C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C CALCULATE STATISTICS: C V - VERTICAL C H - HORIZONTAL C I - INCREMENT C HY - HYDROSTATIC C B - BASELINE C REAL XLIM(2), X(899) INTEGER NDIST(23), MSK(899) C-CRA COMMON /STATS/ NV(21,2), AVGV(21,2), STDV(21,2), C-CRA& NH(21,2), AVGH(21,2), STDH(21,2), C-CRA& NI(21,2), AVGI(21,2), STDI(21,2), C-CRA& NHY(21), AVGHY(21), STDHY(21), C-CRA& NB, AVGB, STDB, C-CRA& SKV(21,2), XKV(21,2), C-CRA& SKH(21,2), XKH(21,2), C-CRA& SKI(21,2), XKI(21,2), C-CRA& SKHY(21), XKHY(21), C-CRA& SKB, XKB COMMON /STATS / AVGV(21,2), STDV(21,2), & AVGH(21,2), STDH(21,2), & AVGI(21,2), STDI(21,2), & AVGHY(21), STDHY(21), & AVGB, STDB, & SKV(21,2), XKV(21,2), & SKH(21,2), XKH(21,2), & SKI(21,2), XKI(21,2), & SKHY(21), XKHY(21), & SKB, XKB COMMON /STATSI/ NV(21,2), & NH(21,2), & NI(21,2), & NHY(21), & NB C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) ZLIM1 = -VMAX(1) ZLIM2 = VMAX(1) TLIM1 = -VMAX(2) TLIM2 = VMAX(2) NLEVM = NLEV - 1 NPLVLM = NPLVL - 1 WRITE(62,533) 533 FORMAT(1H1) C C ZERO FIELDS. C DO 20 IV=1,2 DO 10 I=1,NPLVL NV(I,IV) = 0 NH(I,IV) = 0 NI(I,IV) = 0 AVGV(I,IV) = 0. AVGH(I,IV) = 0. AVGI(I,IV) = 0. STDV(I,IV) = 0. STDH(I,IV) = 0. STDI(I,IV) = 0. 10 CONTINUE DO 15 I=1,NPLVL NHY(I) = 0 AVGHY(I) = 0. STDHY(I) = 0. 15 CONTINUE 20 CONTINUE NB = 0 AVGB = 0. STDB = 0. NZERO = 0 DZERO = 0. NDIV = 23 C C DEFINE MASK FOR OBSERVATIONS TO INCLUDE IN COMPUTATIONS. C CALL SELCT(MSK) C WRITE(62,535) (I,MSK(I),I=1,NOBS) 535 FORMAT(1X,20(I4,I2),/) DO 32 IV=1,2 IF(IV.EQ.1) THEN XLIM(1) = ZLIM1 XLIM(2) = ZLIM2 DDIV = 20. ELSE XLIM(1) = TLIM1 XLIM(2) = TLIM2 DDIV = 2. ENDIF IF(IV.EQ.1) WRITE(62,515) IF(IV.EQ.2) WRITE(62,516) WRITE(62,530) (XLIM(I),I=1,2) WRITE(62,534) 534 FORMAT(' ONLY STATIONS WITHOUT HYDROSTATIC SUSPICIONS', & ' ARE INCLUDED.') WRITE(62,512) DZERO, DDIV WRITE(62,513) DO 30 L=1,NLEV CALL SHIFT(X,OINC,L,IV,NOBS) CALL DISTR(X,MSK,XLIM,VMAX(IV),NOBS,NDIST,NDIV, & DDIV,NZERO,DZERO,NI(L,IV),AVGI(L,IV), & STDI(L,IV),SKI(L,IV),XKI(L,IV)) WRITE(62,514) L, (NDIST(I),I=1,NDIV) 30 CONTINUE 32 CONTINUE 512 FORMAT(' DISTRIBUTION FOR OBSERVED INCREMENTS.', & ' DIVISION ZERO = ',F8.3,' DIVISION INCREMENT = ', & F6.1) 513 FORMAT(1H0,'LEV ... -10 -9 -8 -7 -6 -5', & ' -4 -3 -2 -1 0 1 2 3 4 5 6', & ' 7 8 9 10 ...') 514 FORMAT(1H ,I4,1X,23I4) 515 FORMAT('0HEIGHT') 516 FORMAT('0TEMPERATURE') DO 42 IV=1,2 IF(IV.EQ.1) THEN XLIM(1) = ZLIM1 XLIM(2) = ZLIM2 DDIV = 20. ELSE XLIM(1) = TLIM1 XLIM(2) = TLIM2 DDIV = 2. ENDIF IF(IV.EQ.1) WRITE(62,515) IF(IV.EQ.2) WRITE(62,516) WRITE(62,530) (XLIM(I),I=1,2) 530 FORMAT(' MINIMUM, MAXIMUM VALUES USED IN', & ' CALCULATION OF STATISTICS: ',2F8.1) WRITE(62,534) WRITE(62,517) DZERO, DDIV WRITE(62,513) DO 40 L=1,NLEV CALL SHIFT(X,VINC,L,IV,NOBS) CALL DISTR(X,MSK,XLIM,VMAX(IV),NOBS,NDIST,NDIV, & DDIV,NZERO,DZERO,NV(L,IV),AVGV(L,IV), & STDV(L,IV),SKV(L,IV),XKV(L,IV)) WRITE(62,514) L, (NDIST(I),I=1,NDIV) 40 CONTINUE 42 CONTINUE 517 FORMAT(' DISTRIBUTION FOR VERTICAL RESIDUALS.', & ' DIVISION ZERO = ',F8.3,' DIVISION INCREMENT = ', & F6.1) DO 52 IV=1,2 IF(IV.EQ.1) THEN XLIM(1) = ZLIM1 XLIM(2) = ZLIM2 DDIV = 20. ELSE XLIM(1) = TLIM1 XLIM(2) = TLIM2 DDIV = 2. ENDIF IF(IV.EQ.1) WRITE(62,515) IF(IV.EQ.2) WRITE(62,516) WRITE(62,530) (XLIM(I),I=1,2) WRITE(62,534) WRITE(62,518) DZERO, DDIV WRITE(62,513) DO 50 L=1,NLEV CALL SHIFT(X,HINC,L,IV,NOBS) CALL DISTR(X,MSK,XLIM,VMAX(IV),NOBS,NDIST,NDIV, & DDIV,NZERO,DZERO,NH(L,IV),AVGH(L,IV), & STDH(L,IV),SKH(L,IV),XKH(L,IV)) WRITE(62,514) L, (NDIST(I),I=1,NDIV) 50 CONTINUE 52 CONTINUE 518 FORMAT(' DISTRIBUTION FOR HORIZONTAL RESIDUALS.', & ' DIVISION ZERO = ',F8.3,' DIVISION INCREMENT = ', & F6.1) XLIM(1) = ZLIM1 XLIM(2) = ZLIM2 DDIV = 20. WRITE(62,515) WRITE(62,530) (XLIM(I),I=1,2) WRITE(62,534) WRITE(62,519) DZERO, DDIV WRITE(62,513) DO 60 L=1,NPLVLM CALL SHIFT1(X,HYRES,L,NOBS) CALL DISTR(X,MSK,XLIM,VMAX(1),NOBS,NDIST,NDIV, & DDIV,NZERO,DZERO,NHY(L),AVGHY(L), & STDHY(L),SKHY(L),XKHY(L)) WRITE(62,514) L, (NDIST(I),I=1,NDIV) 60 CONTINUE 519 FORMAT(' DISTRIBUTION FOR HYDROSTATIC RESIDUALS.', & ' DIVISION ZERO = ',F8.3,' DIVISION INCREMENT = ', & F6.1) XLIM(1) = ZLIM1 XLIM(2) = ZLIM2 WRITE(62,520) DZERO, DDIV WRITE(62,513) WRITE(62,530) (XLIM(I),I=1,2) WRITE(62,534) DDIV = 5. CALL DISTR(BRES,MSK,XLIM,VMAX(1),NOBS,NDIST,NDIV,DDIV,NZERO, & DZERO,NB,AVGB,STDB,SKB,XKB) WRITE(62,521) (NDIST(I),I=1,NDIV) 520 FORMAT('0DISTRIBUTION FOR BASELINE RESIDUALS.', & ' DIVISION ZERO = ',F8.3,' DIVISION INCREMENT = ', & F6.1) 521 FORMAT(1H ,5X,23I4) C C PRINT STATISTICS. C THEY WILL BE PRINTED IN FIVE GROUPS: C NUMBER, AVERAGE, STANDARD DEVIATION, SKEWNESS, KURTOSIS. C C ----- TEMP ----- ------ HT ------ C LEVEL VERT HOR INC VERT HOR INC HYDRO C 1 X X X X X X X C ... ... ... ... ... ... ... ... C 14 X X X X X X X C 15 X X X X X X C WRITE(62,500) ALONN, ALONX, ALATN, ALATX 500 FORMAT('1 OVERALL STATISTICS FOR LONGITUDES:',2F8.1, & /,' AND LATITUDES:',2F8.1) WRITE(62,506) WRITE(62,501) 501 FORMAT('0 ------ TEMP ------ -------- HT ------') WRITE(62,502) 502 FORMAT(' LEVEL VERT HOR INC VERT HOR ', & 'INC HYDRO') DO 100 L=1,NPLVL WRITE(62,503) L,NV(L,2),NH(L,2),NI(L,2),NV(L,1),NH(L,1), & NI(L,1),NHY(L) 100 CONTINUE WRITE(62,505) NB 503 FORMAT(1X,I5,2X,7I7) 504 FORMAT(1X,I5,2X,6I7) 505 FORMAT(' BASELINE:',I7) 506 FORMAT('0NUMBERS OF OBSERVATIONS FOR EACH CHECK:') WRITE(62,507) WRITE(62,501) WRITE(62,502) DO 110 L=1,NPLVL WRITE(62,509) L,AVGV(L,2),AVGH(L,2),AVGI(L,2),AVGV(L,1), & AVGH(L,1),AVGI(L,1),AVGHY(L) 110 CONTINUE WRITE(62,511) AVGB 509 FORMAT(1X,I5,2X,7F7.1) 510 FORMAT(1X,I5,2X,6F7.1) 511 FORMAT(' BASELINE:',F7.1) 507 FORMAT('0MEAN OF OBSERVATIONS FOR EACH CHECK:') WRITE(62,508) WRITE(62,501) WRITE(62,502) DO 120 L=1,NPLVL WRITE(62,509) L,STDV(L,2),STDH(L,2),STDI(L,2),STDV(L,1), & STDH(L,1),STDI(L,1),STDHY(L) 120 CONTINUE WRITE(62,511) STDB 508 FORMAT('0STANDARD DEVIATION OF OBSERVATIONS FOR EACH CHECK:') WRITE(62,531) WRITE(62,501) WRITE(62,502) DO 130 L=1,NPLVL WRITE(62,509) L,SKV(L,2),SKH(L,2),SKI(L,2),SKV(L,1), & SKH(L,1),SKI(L,1),SKHY(L) 130 CONTINUE WRITE(62,511) SKB 531 FORMAT('0SKEWNESS OF OBSERVATIONS FOR EACH CHECK:') WRITE(62,532) WRITE(62,501) WRITE(62,502) DO 140 L=1,NPLVL WRITE(62,509) L,XKV(L,2),XKH(L,2),XKI(L,2),XKV(L,1), & XKH(L,1),XKI(L,1),XKHY(L) 140 CONTINUE WRITE(62,511) XKB 532 FORMAT('0KURTOSIS OF OBSERVATIONS FOR EACH CHECK:') RETURN END C********************************************************* C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: STCEVN SET UP ARRAYS FOR SIG LVL CHECKING. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 95-02-17 C C ABSTRACT: SET UP ARRAYS FOR SIGNIFICANT LEVEL TEMPERATURE CHECKING. C C PROGRAM HISTORY LOG: C 95-02-17 W. COLLINS C C USAGE: CALL STCEVN C INPUT ARGUMENT LIST: C NONE C C OUTPUT ARGUMENT LIST: C NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: CRAY C C$$$ SUBROUTINE STCEVN(IOBS,IDENT,HOUR,XLAT,XLON,ZS) C SUBROUTINE TO PERFORM SIGNIFICANT LEVEL CHECKING. C IOBS - SERIAL NUMBER OF REPORT C IDENT - STATION IDENTIFICATION C HOUR - TIME IN HUNDRETHS OF HOUR C XLAT - LATITUDE C XLON - EAST LONGITUDE C ZS - STATION ELEVATION (M) C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /EVNSND/ P (895),T (895),Z (895),CA (895), C-CRA. PQ (895),TQ (895),ZQ (895),IN (895), C-CRA. PR (895),TR (895),ZR (895) COMMON /EVNSND/ P (895),T (895),Z (895),CA (895), . PQ (895),TQ (895),ZQ (895), . PR (895),TR (895),ZR (895) COMMON /EVNSNDI/IN (895) C-CRA COMMON /SIGCHK/ TPRM(895),HRES(895),SRES(895),RES (895), C-CRA. MAN1(895),MAN2(895),IECM(895),IECS(895), C-CRA. RESS(895),RESM(895),REST(895) COMMON /SIGCHK / TPRM(895),HRES(895),SRES(895),RES (895), . RESS(895),RESM(895),REST(895) COMMON /SIGCHKI/ MAN1(895),MAN2(895),IECM(895),IECS(895) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /SLIMS/ RLIMM(21), RLIMS(21) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) INTEGER INX(895), IDM(21), IDS(895), IDEC(895) REAL ZM(21), TM(21), TMG(21), PP(895), TT(895), TG(895), & PMQ(21), ZMQ(21), TMQ(21), & PPQ(895), ZZQ(895), TTQ(895) LOGICAL CHEK,MAND,SIGT,PASS1,PASS2,SDM DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C INITIALIZE MANDATORY LEVELS. DO L=1,21 ZM(L) = BMISS TM(L) = BMISS TMG(L) = BMISS ENDDO C SET UP ARRAYS FOR SIGNIFICANT LEVEL CHECKING. LMAN = 0 NSIG = 0 DO L=1,NLV MAN = MIN(NPLVL,MANLEV(POB(L))) IF(CAT(L).EQ.1.AND.MAN.GT.0.AND.LMAN.LE.20) THEN LMAN = LMAN + 1 ZM(MAN) = ZOB(L) TM(MAN) = TOB(L) TMG(MAN) = TFC(L) PMQ(MAN) = PQM(L) ZMQ(MAN) = ZQM(L) TMQ(MAN) = TQM(L) ELSEIF(CAT(L).EQ.2.OR.CAT(L).EQ.0) THEN NSIG = NSIG + 1 PP(NSIG) = POB(L) TT(NSIG) = TOB(L) TG(NSIG) = TFC(L) PPQ(NSIG) = PQM(L) ZZQ(NSIG) = ZQM(L) TTQ(NSIG) = TQM(L) ENDIF ENDDO C PERFORM SIGNIFICANT LEVEL QC CHECKING. C VALUES AND/OR FLAGS MAY BE CHANGED. IF(IOBS.LE.20) THEN C WRITE(6,500) IDENT,IOBS,LMAN,NSIG C WRITE(6,501) (ZM(I),TM(I),TMG(I),PMQ(I), C & ZMQ(I),TMQ(I),I=1,LMAN) C WRITE(6,502) (PP(I),TT(I),TG(I),PPQ(I), C & ZZQ(I),TTQ(I),I=1,NSIG) 500 FORMAT('STCEVN---(BEFORE SIGTQC)', & 'IDENT,IOBS,LMAN,NSIG: ',4I5) 501 FORMAT(' ZM,TM,TMG,PMQ,ZMQ,TMQ: ', & F8.0,2F8.1,2X,3F4.0) 502 FORMAT(' PP,TT,TG ,PPQ,ZZQ,TTQ: ', & F8.0,2F8.1,2X,3F4.0) ENDIF CALL SIGTQC(ZM,TM,PP,TT,TMG,TG,LMAN,NSIG, & PMQ,ZMQ,TMQ,PPQ,ZZQ,TTQ,IDM,IDS, & IOBS,IDENT,HOUR,XLAT,XLON,ZS) IF(IOBS.LE.20) THEN C WRITE(6,503) IOBS,LMAN,NSIG C WRITE(6,501) (ZM(I),TM(I),TMG(I),PMQ(I), C & ZMQ(I),TMQ(I),I=1,LMAN) C WRITE(6,502) (PP(I),TT(I),TG(I),PPQ(I), C & ZZQ(I),TTQ(I),I=1,NSIG) 503 FORMAT('STCEVN---(AFTER SIGTQC)', & 'IDENT,IOBS,LMAN,NSIG: ',3I5) ENDIF C NOW PLACE VALUES BACK INTO ORIGINAL ARRAYS. NSIG = 0 DO L=1,NLV MAN = MIN(NPLVL,MANLEV(POB(L))) IF(CAT(L).EQ.1) THEN ZOB(L) = ZM(MAN) TOB(L) = TM(MAN) PQM(L) = PMQ(MAN) ZQM(L) = ZMQ(MAN) TQM(L) = TMQ(MAN) IND(L) = L IDEC(L) = IDM(MAN) ELSEIF(CAT(L).EQ.2.OR.CAT(L).EQ.0) THEN NSIG = NSIG + 1 POB(L) = PP(NSIG) TOB(L) = TT(NSIG) PQM(L) = PPQ(NSIG) ZQM(L) = ZZQ(NSIG) TQM(L) = TTQ(NSIG) IND(L) = L IDEC(L) = IDS(NSIG) ENDIF ENDDO C IF(IOBS.LE.20) THEN C WRITE(6,504) IOBS,LMAN,NSIG C WRITE(6,505) C WRITE(6,506) (POB(L),ZOB(L),TOB(L),PQM(L),ZQM(L), C & TQM(L),IDEC(L),IND(L),L=1,NLV) C ENDIF C PREPARE EVENT ARRAYS FOR UFB AND EXIT C LOOP THROUGH LEVELS, LOOKING FOR EVENTS AT SIG LVLS. C ---------------------------------------------------- IEV = 0 DO L=1,NLV IF(IDEC(L).NE.0) THEN IEV = IEV + 1 IN(IEV) = L T(IEV) = TOB(L) TQ(IEV) = TQM(L) IF(TQ(IEV).EQ.16.) TQ(IEV) = 1. TR(IEV) = IDEC(L) C WRITE(6,504) IOBS,LMAN,NSIG 504 FORMAT(/' STCEVN--EVENT FOR IOBS,LMAN,NSIG: ',3I5) C WRITE(6,505) 505 FORMAT(' PRESS HT TEMP PQM ZQM', & ' TQM IDEC IND') C WRITE(6,506) POB(L),ZOB(L),TOB(L),PQM(L),ZQM(L), C & TQM(L),IDEC(L),IND(L) 506 FORMAT(1X,F7.0,1X,F7.1,1X,F7.1,1X,F3.0,1X,F3.0, & 1X,F3.0,1X,I4,1X,I4) ENDIF NEV = IEV ENDDO RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: STNCNT COUNT STATIONS BY WMO BLOCK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: ACCUMULATE COUNT OF RADIOSONDE STATIONS PROCESSED BY C WMO BLOCK AND TOTAL NUMBER OF SHIPS/RECOS. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL STNCNT(ID,IN) C INPUT ARGUMENT LIST: C ID - STATION ID C IN - 0 ADD TOCOUNT FOR LAND STATIONS C - 1 ADD TO COUNT FOR SHIPS/RECOS C > 1 PRINT RESULTS C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: CRAY C C$$$ SUBROUTINE STNCNT(ID,IN) C-CRA COMMON /DATEC/ CDATE(2), IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE(2) COMMON /DATEI/ IYR, IMO, IDY, IHR COMMON /STNKNT/ ISHIP,IBLK(100) CHARACTER*4 CDATE CHARACTER*8 BLOCK DATA BLOCK /'BLOCK TO'/ DATA NZERO /0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C POSITION UNIT 15 DISP=MOD C ------------------------- 1 READ(15,'(A132)',END=2) GOTO 1 2 BACKSPACE 15 C GET THE STATION COUNT TOTAL C --------------------------- ISUM = 0 DO I=1,99 ISUM = ISUM + IBLK(I) ENDDO C WRITE THE SUMMARY TO STANDARD OUTPUT FILES C ------------------------------------------ WRITE(6 ,500) ISUM WRITE(6 ,501) ISHIP WRITE(6 ,507) WRITE(60,500) ISUM WRITE(60,501) ISHIP WRITE(60,507) WRITE(61,500) ISUM WRITE(61,501) ISHIP WRITE(61,507) C WRITE THE SUMMARY TO AN EVENTS FILE C ----------------------------------- DO I=0,90,10 IF(I.EQ.0) THEN WRITE(6 ,508) I, NZERO, (IBLK(J),J=1,9) WRITE(60,508) I, NZERO, (IBLK(J),J=1,9) WRITE(61,508) I, NZERO, (IBLK(J),J=1,9) ELSE WRITE(6 ,508) I, (IBLK(I+J-1),J=1,10) WRITE(60,508) I, (IBLK(I+J-1),J=1,10) WRITE(61,508) I, (IBLK(I+J-1),J=1,10) ENDIF ENDDO C WRITE VALUES TO EVENTS FILE FOR SUMMARY C --------------------------------------- WRITE(15,509) BLOCK, ISUM, ISHIP, (IBLK(I),I=1,25), CDATE WRITE(15,510) BLOCK, (IBLK(I),I=26,50), CDATE WRITE(15,510) BLOCK, (IBLK(I),I=51,75), CDATE WRITE(15,511) BLOCK, (IBLK(I),I=76,99), CDATE C FORMAT STATEMENTS C ----------------- 500 FORMAT('0TOTAL NO. OF LAND STATIONS CHECKED:',I5) 501 FORMAT(' TOTAL NO. OF SHIPS/RECOS CHECKED:',I5) 507 FORMAT(' STATION COUNTS BY WMO BLOCK:',//, . 6X,' 0 1 2 3 4 5 6 7', . ' 8 9',/) 508 FORMAT(1X,11I5) 509 FORMAT(1X,A8,I6,I5,25I4,1X,2A4) 510 FORMAT(1X,A8,11X ,25I4,1X,2A4) 511 FORMAT(1X,A8,11X ,24I4,5X,2A4) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SUPER TEST FOR SUPERADIABATIC LAPSE RATES C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: TEST FOR SUPERADIABATIC LAPSE RATES AT MANDATORY C LEVELS WHERE CORR IS PROPOSED. IF FOUND, DO NOT MAKE CORRECTION. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL SUPER(TL, TU, VL, VU, ICASE, OVER, C LSUPER, IER) C INPUT ARGUMENT LIST: C TL - LOWER TEMPERATURE (C) C TU - UPPER TEMPERATURE (C) C THE CONTENTS OF VL, VU DEPEND UPON ICASE: C IF ICASE = 1 THEN VL,VU ARE PRESSURES C = 2 LOGARITHM OF PRESSURES C = 3 HEIGHTS (M) C C OUTPUT ARGUMENT LIST: C LSUPER = .TRUE. IF THE LAPSE RATE IS AT LEAST C OVER * SUPERADIABATIC C = .FALSE. OTHERWISE C IER = 0 FOR NORMAL RETURN C = 1 FOR ILLEGAL CASE NUMBER C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ SUBROUTINE SUPER(TL,TU,VL,VU,ICASE,OVER,LSUPER,IER) C C TL, TU ARE TEMPERATURES (C) C CHECK LAPSE RATE BETWEEN VL AND VU. C THE CONTENTS OF VL, VU DEPEND UPON ICASE: C IF ICASE = 1 THEN VL,VU ARE PRESSURES C = 2 LOGARITHM OF PRESSURES C = 3 HEIGHTS (M) C LSUPER = .TRUE. IF THE LAPSE RATE IS AT LEAST C OVER * SUPERADIABATIC C = .FALSE. OTHERWISE C IER = 0 FOR NORMAL RETURN C = 1 FOR ILLEGAL CASE NUMBER C C THE METHOD ALLOWS THE RATE TO BE SUPERADIABATIC BY A C FACTOR OF 'OVER'. IT ALSO TAKES INTO ACCOUNT THE FACT C THAT ONE OF THE TEMPERATURES MAY HAVE BEEN CORRECTED C WITH AN ERROR OF UP TO TCORRERROR. C LOGICAL LSUPER COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) DATA ROCP /.2858/, GOCP /.00976/ DATA TCORRERROR /1.5/ IER = 0 LSUPER = .FALSE. IF(ICASE.EQ.1) THEN IF((TL+T0).GT.0. .AND. VL.GT.0.) THEN RATIOT = (TU+TCORRERROR+T0)/(TL+T0) RATIOP = (VU/VL)**(ROCP*OVER) IF(RATIOT.LT.RATIOP) LSUPER = .TRUE. C WRITE(6,500) TL, TU, VL, VU, RATIOT, RATIOP, LSUPER 500 FORMAT(' *** CASE1--TL,TU,PL,PU,RATIOT,RATIOP,LSUPER = ', & 2F7.1,2F7.0,2F10.3,L3) ENDIF ELSEIF(ICASE.EQ.2) THEN IF((VU-VL).LT.0.) THEN RATIO = (ALOG(TU+TCORRERROR+T0)-ALOG(TL+T0))/(VU-VL) IF(RATIO.GT.ROCP*OVER) LSUPER = .TRUE. C WRITE(6,501) TL, TU, VL, VU, RATIO, LSUPER 501 FORMAT(' *** CASE2--TL,TU,LN(PL),LN(PU),RATIO,LSUPER = ', & 2F7.1,2F8.4,F10.3,L3) ENDIF ELSEIF(ICASE.EQ.3) THEN TEST = TL - (TU+TCORRERROR) - OVER*GOCP*(VU-VL) IF(TEST.LT.0.) LSUPER = .TRUE. ELSE IER = 1 ENDIF RETURN END C*************************************************************** SUBROUTINE TCHK C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TCHK PERFORM TEMPORAL CHECK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 92-05-11 C C ABSTRACT: PREFORM TEMPORAL CHECK. C C PROGRAM HISTORY LOG: C 92-05-11 W. COLLINS C C USAGE: CALL TCHK C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ INTEGER IND(5) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DO 100 IV=1,2 DO 90 IS=1,NOBS DO 80 L=1,NPLVL DO 70 IT=1,4 IF(ITERR(IT).NE.0 & .OR.TOBS(L,IV,IS,IT).GT.VMAX(IV)) THEN IND(IT) = 0 ELSE IND(IT) = 1 ENDIF 70 CONTINUE IF(OBS(L,IV,IS).GT.VMAX(IV)) THEN IND(5) = 0 ELSE IND(5) = 1 ENDIF IF(IV.EQ.2.AND.L.LE.2 & .AND.IND(1)+IND(5)+IND(4).EQ.3) THEN IM = 1 IP = 4 TRES(L,IV,IS) = (OBS(L,IV,IS) & -0.5*(TOBS(L,IV,IS,1)+TOBS(L,IV,IS,4))) ELSEIF(IND(2)+IND(5)+IND(3).EQ.3) THEN IM = 2 IP = 3 TRES(L,IV,IS) = OBS(L,IV,IS) & - 0.5*(TOBS(L,IV,IS,2) + TOBS(L,IV,IS,3)) ELSEIF(IND(2)+IND(5)+IND(4).EQ.3) THEN IM = 2 IP = 4 TRES(L,IV,IS) = (OBS(L,IV,IS) & -(2./3.)*TOBS(L,IV,IS,2)-(1./3.)*TOBS(L,IV,IS,4)) ELSEIF(IND(1)+IND(5)+IND(3).EQ.3) THEN IM = 1 IP = 3 TRES(L,IV,IS) = (OBS(L,IV,IS) & -(1./3.)*TOBS(L,IV,IS,1)-(2./3.)*TOBS(L,IV,IS,3)) ELSEIF(IND(1)+IND(5)+IND(4).EQ.3) THEN IM = 1 IP = 4 TRES(L,IV,IS) = (OBS(L,IV,IS) & -0.5*(TOBS(L,IV,IS,1)+TOBS(L,IV,IS,4))) ELSE TRES(L,IV,IS) = VMSG(IV) ENDIF C C TEMPORAL CHECK FLAGS. C IF(TRES(L,IV,IS).GT.VMAX(IV)) THEN ITI = 0 ELSE ITI = 2.0*ABS(TRES(L,IV,IS)) & /(TMPSTD(L,IV)*TFACT(L,IV)) ITI = MIN(ITI,2) IF(ITI.NE.0) CALL CHTCHK(TOBS(L,IV,IS,IM), & OBS(L,IV,IS),TOBS(L,IV,IS,IP),TRES(L,IV,IS),ICK) IF(ICK.NE.0) THEN ITI = 0 TRES(L,IV,IS) = VMSG(IV) ENDIF ENDIF NERT(L,IV,IS,ISCAN) = ITI 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END C*************************************************************** SUBROUTINE TCORR(TC1,TC2,TC3,TCOR2,ZC1,ZC2,ZC3, & ALLT,NT,ICTYP,IC,ITYP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TCORR DETERMINE HYDROSTATIC TEMP CORRECTION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: DETERMINE HYDROSTATIC HEIGHT CORRECTION. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL TCORR(TC1, TC2, TC3, TCOR2, ZC1, ZC2, ZC3, ALLT, C NT, ICTYP, IC, ITYP) C INPUT ARGUMENT LIST: C TC - TEMPERATURE (CELCIUS) C TCOR2 - TEMPERATURE CORRECTION (CELCIUS) C ZC - GEOPOTENTIAL HEIGHT (METERS) C ALLT - ARRAY OF ALLOWABLE DEVIATIONS FROM TCOR2 C ITYP - CORRECTION TYPE C C OUTPUT ARGUMENT LIST: C TC - CORRECTED TEMPERATURE (CELCIUS) C TCOR2 - TEMPERATURE CORRECTION APPLIED (CELCIUS) C IC - SWITCH WHICH IS NORMALLY 0 OR POSITIVE, BUT C SET TO NEGATIVE IF ONLY LOWER LAPSE IS TO C BE CHECKED C ICTYP - CORRECTION TYPE C NORMALLY PASSED FROM INPUT, BUT IF CORRECTION C GIVES UNSTABLE LAYER(S), IT IS SET TO 12. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ DIMENSION ALLT(NT) DATA ALAPS /-.010737/, DTDIF /2.5/, AL0 /-.00976/ ICTYP = ITYP TCOLD = TC2 C C ALLOW FOR 10 PERCENT ERROR IN LAPSE RATE DUE TO C RANGE OF ALLOWABLE TEMPERATURES. C ALAPS = -(G/CP) * 1.10 C ORIGINAL LAPSE RATES, "PRODUCT". C IF(ZC2.NE.ZC1) THEN ALPSM0 = (TC2-TC1)/(ZC2-ZC1) ELSE ALPSM0 = 0. ENDIF IF(ZC3.NE.ZC2) THEN ALPSP0 = (TC3-TC2)/(ZC3-ZC2) ELSE ALPSP0 = 0. ENDIF PR0 = (TC3-TC2)*(TC2-TC1) C C LAPSES BASED UPON ASSUMPTION OF SIGN ERROR... C IF(ZC3.NE.ZC2.AND.IC.GE.0) THEN ALAPSP = (TC3+TC2)/(ZC3-ZC2) ELSE ALAPSP = 0. ENDIF IF(ZC2.NE.ZC1) THEN ALAPSM = (-TC2-TC1)/(ZC2-ZC1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) DIFP = ABS(ALAPSP-AL0) DIFP0 = ABS(ALPSP0-AL0) IF(ABS(2.*TC2+TCOR2).LT.DTDIF & .AND.(ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) & .AND.(ALAPSP.GE.ALAPS.OR.DIFP.LT.DIFP0)) THEN TCOR2 = -2. * TC2 TC2 = -TC2 ELSE C ROUND THE CORRECTION TO NEAREST TENTH DEGREE TCOR2 = .1 * ANINT(10.*TCOR2) C ROUND THE TEMPERATURE TO NEAREST TENTH DEGREE C (THIS SHOULD BE UNNECESSARY) TC2 = .1 * ANINT(10.*TC2) C C FIND SIMPLE CORRECTION FOR VALUES TO TENTHS. C ICORT = 10. * TCOR2 ICCT = 10. * TC2 TCORT = ICORT TCT = ICCT CALL SIMPLE(TCORT, TCT, ALLT, NT) TCOR2 = 0.1 * TCORT TC2 = 0.1 * (TCT + TCORT) ENDIF C C MAKE SURE THAT THE LAPSE RATES ABOVE AND BELOW C ARE ADIABATICALLY STABLE. IF NOT, RESTORE C THE ORIGINAL TEMPERATURE, TCOLD. C C ALSO, CHECK FOR TEMPERATURE LAPSES ABOVE AND C BELOW OF SAME SIGN. C C ALSO, DO NOT GIVE CORRECTIONS FOR LAYERS WITH C MORE THAN ONE LAYER MISSING. C IF(IC.GE.0) THEN IF(ZC3.NE.ZC2) THEN ALAPSP = (TC3-TC2)/(ZC3-ZC2) ELSE ALAPSP = 0. ENDIF IF(ZC2.NE.ZC1) THEN ALAPSM = (TC2-TC1)/(ZC2-ZC1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) DIFP = ABS(ALAPSP-AL0) DIFP0 = ABS(ALPSP0-AL0) PR = (TC3-TC2)*(TC2-TC1) IF((ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) & .AND.(ALAPSP.GE.ALAPS.OR.DIFP.LT.DIFP0) & .AND.(PR.GT.-200..OR.(PR.GT.PR0.AND.PR.LT.0.))) THEN ICTYP = ITYP ELSE TC2 = TCOLD ICTYP = 12 ENDIF C C FOR ICTYP = 7 (IC=-1) CHECK ONLY LOWER LAPSE C RATE FOLLOWING LOWER TEMPERATURE CHANGE. C ELSE IF(ZC2.NE.ZC1) THEN ALAPSM = (TC2-TC1)/(ZC2-ZC1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) IF(ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) THEN ICTYP = ITYP ELSE TC2 = TCOLD ICTYP = 12 ENDIF ENDIF RETURN END C********************************************************* SUBROUTINE TCORS(T1,T2,T3,TCOR2,P1,P2,P3,K,ALLT,TDIF,NL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TCORS TEMP CORRECTION AT SIGNIFICANT LEVELS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-12-27 C C ABSTRACT: DETERMINE CORRECTION FOR SIGNIFICANT LEVEL RAWINSONDE C TEMPERATURES. C C PROGRAM HISTORY LOG: C 89-12-27 W. COLLINS C C USAGE: CALL TCORS(T1, T2, T3, TCOR2, P1, P2, P3, ALLT, NL) C INPUT ARGUMENT LIST: C T'S - TEMPERATURE (CELCIUS) C P'S - PRESSURES (HPA) C ALLT - ARRAY OF ALLOWABLE DEVIATIONS FROM TCOR2 C C OUTPUT ARGUMENT LIST: C T2 - CORRECTED TEMPERATURE (CELCIUS) C TP - TEMPERATURE CORRECTION APPLIED (CELCIUS) C NL - LEVELS FOR WHICH TO CHECK LAPSE RATE: C 1 - LOWER ONLY C 2 - UPPER ONLY C 3 - LOWER AND UPPER C C ATTRIBUTES: C LANGUAGE: VSFORTRAN C MACHINE: , CRAY C C$$$ REAL ALLT(*), ZERR(20) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN DATA DTDIF /5./, AL0 /-.00976/, CP /1004.5/ DATA ZERR /11.2,9.0,12.0,10.3,11.5,9.5,10.6,12.4,15.9, & 17.3,15.8,19.9,18.9,25.1,29.,33.,36.,40.,45.,50./ C SAVE ORIGINAL TEMPERATURE. TCOLD = T2 C C ALLOW FOR 10 PERCENT ERROR IN LAPSE RATE DUE TO C RANGE OF ALLOWABLE TEMPERATURES. C ALAPS = -(R/CP) * 1.10 C ORIGINAL LAPSE RATES, "PRODUCT". C ALAPS = -(R/CP) * 1.1 C C FIND MANDATORY LEVEL NEAR K. C NPLVLM = NPLVL - 1 DO 5 KK=1,NPLVLM IF(IPLVL(KK).LT.P2) GO TO 6 5 CONTINUE 6 CONTINUE IF(KK.GT.1) KK = KK - 1 C C TDIF IS MAXIMUM RANGE FOR SEARCH FOR CORRECTION. C IF(P1.GT.0..AND.P3.GT.0..AND.P1.NE.P3) THEN TDIF = 2.*(G/R)*ZERR(KK) / ALOG(P1/P3) ELSE TDIF = 10. ENDIF IF(P2.NE.P1) THEN ALPSM0 = (T2-T1)/(P2-P1) ELSE ALPSM0 = 0. ENDIF IF(P3.NE.P2) THEN ALPSP0 = (T3-T2)/(P3-P2) ELSE ALPSP0 = 0. ENDIF PR0 = (T3-T2) * (T2-T1) C C LAPSES BASED UPON ASSUMPTION OF SIGN ERROR... C IF(P3.NE.P2.AND.NL.NE.1) THEN ALAPSP = (T3+T2)/(P3-P2) ELSE ALAPSP = 0. ENDIF IF(P2.NE.P1) THEN ALAPSM = (-T2-T1)/(P2-P1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) DIFP = ABS(ALAPSP-AL0) DIFP0 = ABS(ALPSP0-AL0) IF(ABS(2.*T2+TCOR2).LT.DTDIF & .AND.(ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) & .AND.(ALAPSP.GE.ALAPS.OR.DIFP.LT.DIFP0)) THEN TCOR2 = -2. * T2 IF(ABS(TCOR2).LT.TCLIM) THEN TCOR2 = 0. RETURN ENDIF T2 = -T2 ELSE C ROUND THE CORRECTION TO NEAREST TENTH DEGREE TCOR2 = .1 * ANINT(10.*TCOR2) C ROUND THE TEMPERATURE TO NEAREST TENTH DEGREE C (THIS SHOULD BE UNNECESSARY) T2 = .1 * ANINT(10.*T2) C C FIND SIMPLE CORRECTION FOR VALUES TO TENTHS. C ICORT = 10. * TCOR2 ICCT = 10. * T2 TCORT = ICORT TCT = ICCT C C SPECIFY NT, LIMITING RANGE TO LIMITS FOUND UNDER THE C ASSUMPTION OF A MAXIMUM HYDROSTATIC RESIDUAL OF ZERR METERS. C DO 10 I=1,101 IF(ABS(ALLT(I)).GT.10.*TDIF) GO TO 11 10 CONTINUE 11 CONTINUE NT = I-1 CALL SIMPLE(TCORT, TCT, ALLT, NT) TCOR2 = 0.1 * TCORT IF(ABS(TCOR2).LT.TCLIM) THEN TCOR2 = 0. RETURN ENDIF T2 = 0.1 * (TCT + TCORT) ENDIF C C MAKE SURE THAT THE LAPSE RATES ABOVE AND BELOW C ARE ADIABATICALLY STABLE. IF NOT, RESTORE C THE ORIGINAL TEMPERATURE, TCOLD. C C ALSO, CHECK FOR TEMPERATURE LAPSES ABOVE AND C BELOW OF SAME SIGN. C C ALSO, DO NOT GIVE CORRECTIONS FOR LAYERS WITH C MORE THAN ONE LAYER MISSING. C IF(NL.NE.1) THEN IF(P3.NE.P2) THEN ALAPSP = (T3-T2)/(P3-P2) ELSE ALAPSP = 0. ENDIF IF(P2.NE.P1) THEN ALAPSM = (T2-T1)/(P2-P1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) DIFP = ABS(ALAPSP-AL0) DIFP0 = ABS(ALPSP0-AL0) PR = (T3-T2)*(T2-T1) IF((ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) & .AND.(ALAPSP.GE.ALAPS.OR.DIFP.LT.DIFP0) & .AND.(PR.GT.-200..OR.(PR.GT.PR0.AND.PR.LT.0.))) THEN IDUM = 1 ELSE T2 = TCOLD TCOR2 = 0. ENDIF C C FOR NL = 1 CHECK ONLY LOWER LAPSE C RATE FOLLOWING LOWER TEMPERATURE CHANGE. C ELSE IF(P2.NE.P1) THEN ALAPSM = (T2-T1)/(P2-P1) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) IF(ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) THEN IDUM = 1 ELSE T2 = TCOLD TCOR2 = 0. ENDIF ENDIF RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TINCS DEFINE SIG LVL INCR, INCR DEVIATION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 93-03-12 C C ABSTRACT: SOLVE FOR SIGNIFICANT LEVEL INCREMENT AND SIG LVL C INTERPOLATION. C C PROGRAM HISTORY LOG: C 93-03-12 W. COLLINS C C USAGE: CALL TINCS(TC,TG,TMG,MAN,NSIG,INDX,ITYP,TIC) C INPUT ARGUMENT LIST: C TC - COMBINED TEMPERATURES C TG - SIGNIFICANT LEVEL GUESS C TMG - MANDATORY LEVEL GUESS (0=SFC) C MAN - NUMBER OF MANDATORY LEVELS C NSIG- NUMBER OF SIGNIFICANT LEVELS C INDX- INDEX OF LEVEL IN ORIGINAL ARRAY C ITYP- TYPE OF LEVEL C C OUTPUT ARGUMENT LIST: C TIC - SIG LVL INCREMENTS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE TINCS(TC,TG,TMG,MAN,NSIG,INDX,ITYP,TIC) REAL TC(*), TMG(*), TG(*), TIC(*) INTEGER INDX(*), ITYP(*) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) IER = 0 C WRITE(6,500) MAN,NSIG 500 FORMAT(' TINCS--MAN,NSIG: ',2I5) C FORM INCREMENTS. DO I=1,NSIG+MAN N = INDX(I) IF(TC(I).LT.VMAX(2) .AND. TG(N).LT.VMAX(2) & .AND. (ITYP(I).EQ.0 .OR. ITYP(I).EQ.1)) THEN TIC(I) = TC(I) - TG(N) ELSEIF(TC(I).LT.VMAX(2) .AND. TMG(N).LT.VMAX(2) & .AND. ITYP(I).GE.2) THEN TIC(I) = TC(I) - TMG(N) ELSE TIC(I) = VMSG(2) ENDIF END DO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TSTARS CALCULATE HYDROSTATIC 'T-STAR' C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 90-02-28 C C ABSTRACT: CALCULATE T-STAR. THIS IS THE TEMPERATURE INCREMENT C NEEDED AT A GIVEN SIGNIFICANT LEVEL TEMPERATURE SO THAT C THE HYDROSTATIC RESIDUAL FOR BOUNDING MANDATORY LEVELS C VANISHES. C C PROGRAM HISTORY LOG: C 90-02-28 W. COLLINS C C USAGE: CALL TSTARS(P,Z,T,ITYP,LEVS,TSTAR) C INPUT ARGUMENT LIST: C P - PRESSURE (HPA) C Z - HEIGHT (M) C T - TEMPERATUE (C) C ITYP - INDEX TELLING TYPE OF DATA AT LEVEL: C = 0 SIGNIFICANT LEVEL DATA C = 1 SURFACE DATA C = 2 MANDATORY LEVEL DATA WITH Z, T NON-MISSING C = 3 MANDATORY LEVEL DATA WITH ONLY T NON-MISSING C = 4 MANDATORY LEVEL DATA WITH ONLY Z NON-MISSING C = 5 MANDATORY LEVEL DATA WITH Z, T MISSING C LEVS - NUMBER OF LEVELS C C OUTPUT ARGUMENT LIST: C TSTAR - T-STAR (C) C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: , CRAY C C$$$ SUBROUTINE TSTARS(P,Z,T,INDX,ITYP,LEVS,TSTARC) REAL P(*), Z(*), T(*), TSTARC(*) INTEGER INDX(*), ITYP(*) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) ROG = R/G DO I=1,LEVS TSTARC(I) = VMSG(2) ENDDO C C FIND TWO CONSECUTIVE MANDATORY LEVELS WITH COMPLETE DATA. C DO 10 I=1,LEVS IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) GO TO 15 10 CONTINUE C C NONE FOUND, SO... C RETURN 15 CONTINUE I1 = I 16 CONTINUE DO 20 I=I1+1,LEVS IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) GO TO 25 20 CONTINUE C C NO SECOND LEVEL FOUND, SO... C RETURN 25 CONTINUE C C IF THERE ARE ANY SIGNIFICANT LEVELS BETWEEN, C CALCULATE TSTAR. C I2 = I IF(I2-I1.GT.1) THEN C C CHECK FOR INTERVENING MISSING SIGNIFICANT LEVELS. C DO 27 I=I1+1,I2-1 IF(T(I).GT.VMAX(2).OR.P(I).LE.0.) GO TO 55 27 CONTINUE SUM0 = Z(I2) - Z(I1) - 0.5 * ROG * & (T(I1) * ALOG(P(I1)/P(I1+1)) & +T(I2) * ALOG(P(I2-1)/P(I2))) DO 50 J=I1+1,I2-1 SUM = SUM0 DO 30 I=I1,I2-1 SUM = SUM - T0 * ROG * ALOG(P(I)/P(I+1)) 30 CONTINUE DO 40 I=I1+1,I2-1 IF(I.NE.J) THEN SUM = SUM - 0.5 * ROG * T(I) * & (ALOG(P(I-1)/P(I)) + ALOG(P(I)/P(I+1))) ENDIF 40 CONTINUE IF((P(J).NE.P(J-1)).AND.(P(J).NE.P(J+1))) THEN TSTR = SUM / (0.5 * ROG * (ALOG(P(J-1)/P(J)) & + ALOG(P(J)/P(J+1)))) ELSE TSTR = 0. ENDIF C CONVERT TSTAR TO INCREMENT. LEV = INDX(J) TSTARC(J) = TSTR - T(J) 50 CONTINUE 55 CONTINUE ENDIF I1 = I2 GO TO 16 END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TSTCOR RECOMPUTE OBSERVED INCREMENT. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: RECOMPUTE THE OBSERVED INCREEMNT C AND ALL RESIDUALS, BASED UPON TENTATIVE CORRECTIONS, C FOR THE GIVEN TEMPLATE OF DATA. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TSTCOR(IV, IS, IP, IHSC1, IHSC2, IINC2, IINC3, C IHOI2, IHOI3, IVOI2, IVOI3, ITMP2, ITMP3) C INPUT ARGUMENT LIST: C IV - VARIABLE: 1=HEIGHT, 2=TEMPERATURE C IS - STATION INDEX C IP - =0, PRINT C C C OUTPUT ARGUMENT LIST: C IHSC() - INDICATOR FOR HYDROSTATIC RESIDUAL, LAYER() C IINC() - INDICATOR FOR INCREMENT, LAYER() C IHOI() - INDICATOR FOR HORIZONTAL CHECK, LAYER() C IVOI() - INDICATOR FOR VERTICAL CHECK, LAYER() C ITMP() - INDICATOR FOR TEMPORAL CHECK, LAYER() C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ SUBROUTINE TSTCOR(IV,IS,IP,IHSC1,IHSC2,IHSC3,IINC2,IINC3, & IHOI2,IHOI3,IVOI2,IVOI3,ITMP2,ITMP3) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) COMMON /MSGS/ VMAX(2),VMSG(2) DIMENSION DMAX(21,2),TINC(21,2),TSTD(21,2),TWTS(4,21,2) DIMENSION WTS(4),CHSTD(4,2),L(4),CINC(4),X(3),XC(3),CORR(4) CHARACTER*11 CVAR(2) DATA CVAR /'HEIGHT ','TEMPERATURE'/ IF(IV.EQ.1) THEN L(1) = LZ1 L(2) = L2 L(3) = LZ3 L(4) = LZ4 ELSEIF(IV.EQ.2) THEN L(1) = LT1 L(2) = L2 L(3) = LT3 L(4) = LT4 ELSE RETURN ENDIF C C NEW OBSERVED INCREMENTS. C DO I=1,4 CORR(I) = 0. ENDDO IF(IV.EQ.1) THEN CORR(2) = ZZCOR(2) CORR(3) = ZZCOR(3) IF(L(1).LE.NPLVL) THEN CALL INCR1(COINC(1,IV), ZZC(1), GES(L(1),IV,IS),IV) ENDIF IF(L(2).LE.NPLVL) THEN CALL INCR1(COINC(2,IV), ZZC(2), GES(L(2),IV,IS),IV) ENDIF IF(L(3).LE.NPLVL) THEN CALL INCR1(COINC(3,IV), ZZC(3), GES(L(3),IV,IS),IV) ENDIF IF(L(4).LE.NPLVL) THEN CALL INCR1(COINC(4,IV), ZZC(4), GES(L(4),IV,IS),IV) ENDIF ELSE CORR(2) = TTCOR(2) CORR(3) = TTCOR(3) IF(L(1).LE.NPLVL) THEN CALL INCR1(COINC(1,IV), TTC(1), GES(L(1),IV,IS),IV) ENDIF IF(L(2).LE.NPLVL) THEN CALL INCR1(COINC(2,IV), TTC(2), GES(L(2),IV,IS),IV) ENDIF IF(L(3).LE.NPLVL) THEN CALL INCR1(COINC(3,IV), TTC(3), GES(L(3),IV,IS),IV) ENDIF IF(L(4).LE.NPLVL) THEN CALL INCR1(COINC(4,IV), TTC(4), GES(L(4),IV,IS),IV) ENDIF ENDIF C C CALCULATE VERTICAL DIFFERENCES OF THE INCREMENTS. C CALL VDIF(CDO2(IV), COINC(1,IV), COINC(2,IV), COINC(3,IV), & L(1), L(2), L(3), VMAX(IV), VMSG(IV)) CALL VDIF(CDO3(IV), COINC(2,IV), COINC(3,IV), COINC(4,IV), & L(2), L(3), L(4), VMAX(IV), VMSG(IV)) C C CALCULATE REVISED HYDROSTATIC RESIDUALS. C CALL HSC1 DO 50 KK=1,3 K = L(KK+1) IF(K.NE.99) THEN IF(BSUM(K,IS).NE.0. & .AND. ABS(BSUM(K,IS)) .LT. VMAX(1)) THEN IF(ABS(HYRES(K,IS)) .LT. VMAX(1)) THEN X(KK) = HYRES(K,IS) / CBSUM(KK) ENDIF IF(ABS(CHYRES(KK)) .LT. VMAX(1)) THEN XC(KK) = CHYRES(KK) / CBSUM(KK) ENDIF ENDIF ENDIF 50 CONTINUE C C RUN BASELINE CHECK FOR LOWEST LEVEL. C IF(L(2).EQ.LEV1(IS)) THEN CALL BASLN1(IS) ELSE CBRES = VMSG(1) ENDIF C PERFORM THE HORIZONTAL CHECK FOR THE FOUR LEVELS C ------------------------------------------------ DO 20 L0=1,4 L1 = L(L0) IF(L1.LT.1) L1 = 1 IF(L1.GT.NPLVL) L1 = NPLVL DMAX(L1,IV) = HOIRES(L1,IV)*CCON CALL SEARCH(21,2,L1,IV,IS,IS,IDH,OINC,DMAX) CALL QCOI(21,2,L1,IV,IS,IS,IDH,OINC,TINC,TSTD,TWTS) CHRES(L0,IV) = TINC(L1,IV) + CORR(L0) CHSTD(L0,IV) = TSTD(L1,IV) DO 100 J=1,4 WTS(J) = TWTS(J,L1,IV) JJ = IDH(J,L1,IV,IS) IF(JJ.NE.0 .AND. JJ.NE.99) THEN CINC(J) = OINC(L1,IV,JJ) ELSE CINC(J) = 0. ENDIF 100 CONTINUE 20 CONTINUE C C CALCULATE VERTICAL DIFFERENCES OF THE HORIZONTAL RESIDUALS. C CALL VDIF(CDH2(IV), CHRES(1,IV), CHRES(2,IV), CHRES(3,IV), & L(1), L(2), L(3), VMAX(IV), VMSG(IV)) CALL VDIF(CDH3(IV), CHRES(2,IV), CHRES(3,IV), CHRES(4,IV), & L(2), L(3), L(4), VMAX(IV), VMSG(IV)) C C CALCULATE VERTICAL CHECK RESIDUALS (COMPLETE PROFILE). C CALL VRTCK1(IV,L) C C COMPUTE CORRECTED TEMPORAL RESIDUAL. C IF(TRES(L2,IV,IS).LT.VMAX(IV)) THEN IF(IV.EQ.1) THEN CTRES(2,IV) = TRES(L2,IV,IS) + ZZCOR(2) ELSEIF(IV.EQ.2) THEN CTRES(2,IV) = TRES(L2,IV,IS) + TTCOR(2) ELSE CTRES(2,IV) = VMSG(1) ENDIF ELSE CTRES(2,IV) = VMSG(1) ENDIF C IF(L(1).LE.NPLVL) THEN CTRES(1,IV) = TRES(L(1),IV,IS) ELSE CTRES(1,IV) = VMSG(1) ENDIF C IF(L(3).LE.NPLVL) THEN CTRES(3,IV) = TRES(L(3),IV,IS) ELSE CTRES(3,IV) = VMSG(1) ENDIF C IF(L(4).LE.NPLVL) THEN CTRES(4,IV) = TRES(L(4),IV,IS) ELSE CTRES(4,IV) = VMSG(1) ENDIF C C C CALCULATE THE VERTICAL DIFFERENCES OF CORRECTED C TEMPORAL RESIDUALS. C CALL VDIF(CDT2(IV),CTRES(1,IV),CTRES(2,IV),CTRES(3,IV), & L(1),L(2),L(3),VMAX(IV),VMSG(IV)) CALL VDIF(CDT3(IV),CTRES(2,IV),CTRES(3,IV),CTRES(4,IV), & L(2),L(3),L(4),VMAX(IV),VMSG(IV)) C C CALCULATE ERROR FLAGS AFTER CORRECTIONS (LEVELS 2 & 3). C FIRST, OBSERVED INCREMENT FLAGS. C IF(COINC(2,IV).GT.VMAX(IV)) THEN IINC2 = 0 ELSE FCT = EXFACT(COINC(2,IV),XINC(L(2),IV),1.,2.,1.5) IINC2 = 2.*ABS(COINC(2,IV))/(FCT*XINC(L(2),IV)) ENDIF IF(CDO2(IV).GT.VMAX(IV).OR.IV.NE.1) THEN IINC2D = 0 ELSE FCT = EXFACT(COINC(2,IV),XINC(L(2),IV),1.,2.,1.5) IINC2D = 2.*ABS(CDO2(IV))/(FCT*XINC(L(2),IV)) ENDIF IINC2 = MIN(IINC2,IINC2D,2) IINC2D = MIN(IINC2D,2) C IF(COINC(3,IV).GT.VMAX(IV)) THEN IINC3 = 0 ELSE FCT = EXFACT(COINC(3,IV),XINC(L(3),IV),1.,2.,1.5) IINC3 = 2.*ABS(COINC(3,IV))/(FCT*XINC(L(3),IV)) ENDIF IF(CDO3(IV).GT.VMAX(IV).OR.IV.NE.1) THEN IINC3D = 0 ELSE FCT = EXFACT(COINC(3,IV),XINC(L(3),IV),1.,2.,1.5) IINC3D = 2.*ABS(CDO3(IV))/(FCT*XINC(L(3),IV)) ENDIF IINC3 = MIN(IINC3,IINC3D,2) IINC3D = MIN(IINC3D,2) C C HORIZONTAL CHECK FLAGS. C IF(CHRES(2,IV).GT.VMAX(IV)) THEN IHOI2 = 0 ELSE FCT = EXFACT(CHRES(2,IV),HOIRES(L(2),IV),1.,2.,1.5) IHOI2 = 2.*ABS(CHRES(2,IV))/(FCT*HOIRES(L(2),IV)) ENDIF IF(CDH2(IV).GT.VMAX(IV).OR.IV.NE.1) THEN IHOI2D = 0 ELSE FCT = EXFACT(CHRES(2,IV),HOIRES(L(2),IV),1.,2.,1.5) IHOI2D = 2.*ABS(CDH2(IV))/(FCT*HOIRES(L(2),IV)) ENDIF IHOI2 = MIN(IHOI2,IHOI2D,2) IHOI2D = MIN(IHOI2D,2) C IF(CHRES(3,IV).GT.VMAX(IV)) THEN IHOI3 = 0 ELSE FCT = EXFACT(CHRES(3,IV),HOIRES(L(3),IV),1.,2.,1.5) IHOI3 = 2.*ABS(CHRES(3,IV))/(FCT*HOIRES(L(3),IV)) ENDIF IF(CDH3(IV).GT.VMAX(IV).OR.IV.NE.1) THEN IHOI3D = 0 ELSE FCT = EXFACT(CHRES(3,IV),HOIRES(L(3),IV),1.,2.,1.5) IHOI3D = 2.*ABS(CDH3(IV))/(FCT*HOIRES(L(3),IV)) ENDIF IHOI3 = MIN(IHOI3,IHOI3D,2) IHOI3D = MIN(IHOI3D,2) C C VERTICAL CHECK FLAGS. C IF(ABS(CVRES(1,IV)).GT.VMAX(IV)) THEN IVOI2 = 0 ELSE IVOI2 = 2.*ABS(CVRES(1,IV))/VOIRES(L(2),IV) ENDIF IVOI2 = MIN(IVOI2,2) IF(ABS(CVRES(2,IV)).GT.VMAX(IV)) THEN IVOI3 = 0 ELSE IVOI3 = 2.*ABS(CVRES(2,IV))/VOIRES(L(3),IV) ENDIF IVOI3 = MIN(IVOI3,2) C C HYDROSTATIC FLAGS (LAYERS 1,2 AND 3.) C IF(ABS(CHYRES(1)).GT.VMAX(1)) THEN IHSC1 = 0 ELSE FCT = EXFACT(CHYRES(1),HSCRES(L(2)),1.,2.,1.5) IHSC1 = 2.*ABS(CHYRES(1))/(FCT*HSCRES(L(2))) ENDIF IHSC1 = MIN(IHSC1,2) IF(ABS(CHYRES(2)).GT.VMAX(1)) THEN IHSC2 = 0 ELSE FCT = EXFACT(CHYRES(2),HSCRES(L(3)),1.,2.,1.5) IHSC2 = 2.*ABS(CHYRES(2))/(FCT*HSCRES(L(3))) ENDIF IHSC2 = MIN(IHSC2,2) IF(ABS(CHYRES(3)).GT.VMAX(1)) THEN IHSC3 = 0 ELSE FCT = EXFACT(CHYRES(3),HSCRES(L(4)),1.,2.,1.5) IHSC3 = 2.*ABS(CHYRES(3))/(FCT*HSCRES(L(4))) ENDIF IHSC3 = MIN(IHSC3,2) C C TEMPORAL FLAG (LEVEL 2). C IF(CTRES(2,IV).GT.VMAX(IV) & .OR.L(2).LT.1.OR.L(2).GT.NPLVL) THEN ITMP2 = 0 ELSE ITMP2 = 2.*ABS(CTRES(2,IV))/TMPSTD(L(2),IV) ENDIF IF(CDT2(IV).GT.VMAX(IV).OR.IV.NE.1) THEN ITMP2D = 0 ELSE ITMP2D = 2.*ABS(CDT2(IV))/TMPSTD(L(2),IV) ENDIF ITMP2 = MIN(ITMP2,ITMP2D,2) ITMP2D = MIN(ITMP2D,2) C C TEMPORAL FLAG (LEVEL 3). C IF(CTRES(3,IV).GT.VMAX(IV) & .OR.L(2).LT.1.OR.L(2).GT.NPLVL.OR.L(3).GT.NPLVL) THEN ITMP3 = 0 ELSE ITMP3 = 2.*ABS(CTRES(3,IV))/TMPSTD(L(3),IV) ENDIF IF(CDT3(IV).GT.VMAX(IV).OR.IV.NE.1.OR.L(3).GT.NPLVL) THEN ITMP3D = 0 ELSE ITMP3D = 2.*ABS(CDT3(IV))/TMPSTD(L(3),IV) ENDIF ITMP3 = MIN(ITMP3,ITMP3D,2) ITMP3D = MIN(ITMP3D,2) C WRITE ALL DIAGNOSTIC QUANTITIES TO UNIT 64. LL1 = L(1) LL2 = L(2) LL3 = L(3) LL4 = L(4) IF(IV.EQ.1) THEN WRITE(64,600) IS, CID(IS)(1:6), CVAR(IV) WRITE(64,601) IF(LL1.NE.99) WRITE(64,602) LL1,OBS(LL1,IV,IS),ZZCOR(1),ZZC(1), & OINC(LL1,IV,IS),COINC(1,IV) WRITE(64,603) L2,OBS(L2,IV,IS),ZZCOR(2),ZZC(2), & OINC(L2,IV,IS),COINC(2,IV),XINC(L2,IV),IINC2,DOZ2, & CDO2(IV),IINC2D IF(LL3.NE.99) WRITE(64,603) LL3,OBS(LL3,IV,IS),ZZCOR(3),ZZC(3), & OINC(LL3,IV,IS),COINC(3,IV),XINC(LL3,IV),IINC3,DOZ3, & CDO3(IV),IINC3D IF(LL4.NE.99) WRITE(64,602) LL4,OBS(LL4,IV,IS),ZZCOR(4),ZZC(4), & OINC(LL4,IV,IS),COINC(4,IV) WRITE(64,604) IF(LL1.NE.99) WRITE(64,605) LL1,HINC(LL1,IV,IS),CHRES(1,IV), & (IDH(J,LL1,IV,IS),J=1,4),(TWTS(J,LL1,IV),J=1,4) WRITE(64,606) L2 ,HINC(L2,IV,IS) ,CHRES(2,IV), & HOIRES(L2,IV),IHOI2, & (IDH(J,L2,IV,IS),J=1,4),(TWTS(J,L2,IV),J=1,4), & DHZ2,CDH2(IV),IHOI2D IF(LL3.NE.99) WRITE(64,606) LL3,HINC(LL3,IV,IS),CHRES(3,IV), & HOIRES(LL3,IV),IHOI3, & (IDH(J,LL3,IV,IS),J=1,4),(TWTS(J,LL3,IV),J=1,4), & DHZ3,CDH3(IV),IHOI3D IF(LL4.NE.99) WRITE(64,605) LL4,HINC(LL4,IV,IS),CHRES(4,IV), & (IDH(J,LL4,IV,IS),J=1,4),(TWTS(J,LL4,IV),J=1,4) WRITE(64,607) IF(LL1.NE.99) WRITE(64,608) LL1,VINC(LL1,IV,IS), & TRES(LL1,IV,IS) WRITE(64,609) L2,VINC(L2,IV,IS),CVRES(1,IV), & VOIRES(L2,IV),IVOI2,TRES(L2,IV,IS),CTRES(2,IV), & TMPSTD(L2,IV),ITMP2,DTZ2,CDT2(IV),ITMP2D IF(LL3.NE.99) WRITE(64,609) LL3,VINC(LL3,IV,IS),CVRES(2,IV), & VOIRES(LL3,IV),IVOI3,TRES(LL3,IV,IS),CTRES(3,IV), & TMPSTD(LL3,IV),ITMP3,DTZ3,CDT3(IV),ITMP3D IF(LL4.NE.99) WRITE(64,608) LL4,VINC(LL4,IV,IS),TRES(LL4,IV,IS) ELSEIF(IV.EQ.2) THEN WRITE(64,600) IS, CID(IS)(1:6), CVAR(IV) WRITE(64,601) IF(LL1.NE.99) WRITE(64,602) LL1,OBS(LL1,IV,IS),TTCOR(1),TTC(1), & OINC(LL1,IV,IS),COINC(1,IV) WRITE(64,603) L2,OBS(L2,IV,IS),TTCOR(2),TTC(2), & OINC(L2,IV,IS),COINC(2,IV),XINC(L2,IV),IINC2,DOT2, & CDO2(IV),IINC2D IF(LL3.NE.99) WRITE(64,603) LL3,OBS(LL3,IV,IS),TTCOR(3),TTC(3), & OINC(LL3,IV,IS),COINC(3,IV),XINC(LL3,IV),IINC3,DOT3, & CDO3(IV),IINC3D IF(LL4.NE.99) WRITE(64,602) LL4,OBS(LL4,IV,IS),TTCOR(4),TTC(4), & OINC(LL4,IV,IS),COINC(4,IV) WRITE(64,604) IF(LL1.NE.99) WRITE(64,605) LL1,HINC(LL1,IV,IS),CHRES(1,IV), & (IDH(J,LL1,IV,IS),J=1,4),(TWTS(J,LL1,IV),J=1,4) WRITE(64,606) L2 ,HINC(L2,IV,IS) ,CHRES(2,IV), & HOIRES(L2,IV),IHOI2, & (IDH(J,L2,IV,IS),J=1,4),(TWTS(J,L2,IV),J=1,4), & DHT2,CDH2(IV) IF(LL3.NE.99) WRITE(64,606) LL3,HINC(LL3,IV,IS),CHRES(3,IV), & HOIRES(LL3,IV),IHOI3, & (IDH(J,LL3,IV,IS),J=1,4),(TWTS(J,LL3,IV),J=1,4), & DHT3,CDH3(IV) IF(LL4.NE.99) WRITE(64,605) LL4,HINC(LL4,IV,IS),CHRES(4,IV), & (IDH(J,LL4,IV,IS),J=1,4),(TWTS(J,LL4,IV),J=1,4) WRITE(64,607) IF(LL1.NE.99) WRITE(64,608) LL1,VINC(LL1,IV,IS),TRES(LL1,IV,IS) WRITE(64,609) L2,VINC(L2,IV,IS),CVRES(1,IV), & VOIRES(L2,IV),IVOI2,TRES(L2,IV,IS),CTRES(2,IV), & TMPSTD(L2,IV),ITMP2,DTT2,CDT2(IV),ITMP2D IF(LL3.NE.99) WRITE(64,609) LL3,VINC(LL3,IV,IS),CVRES(2,IV), & VOIRES(LL3,IV),IVOI3,TRES(LL3,IV,IS),CTRES(3,IV), & TMPSTD(LL3,IV),ITMP3,DTT3,CDT3(IV),ITMP3D IF(LL4.NE.99) WRITE(64,608) LL4,VINC(LL4,IV,IS),TRES(LL4,IV,IS) ENDIF WRITE(64,610) IF(LL1.NE.99) WRITE(64,611) LL1,HYRES(LL2,IS),X(1),CHYRES(1), & XC(1),HSCRES(LL1),IHSC1,CBSUM(1) IF(LL3.NE.99) WRITE(64,611) LL2,HYRES(LL3,IS),X(2),CHYRES(2), & XC(2),HSCRES(LL2),IHSC2,CBSUM(2) IF(LL3.NE.99 .AND. LL4.NE.99) WRITE(64,611) LL3,HYRES(LL4,IS), & X(3),CHYRES(3),XC(3),HSCRES(LL3),IHSC3,CBSUM(3) WRITE(64,612) CBRES 600 FORMAT('0TSTCOR--IS: ',I4,' STATION: ',A6, & ' -- ',A11,' ERROR') 601 FORMAT(' LEVEL VALUE CORR C-VALUE INCR C-INCR', & ' XINC IINC INCRD C-INCRD IINCD') 602 FORMAT(1X,I3,2X,5F8.0) 603 FORMAT(1X,I3,2X,6F8.0,I5,2F8.0,I6) 604 FORMAT(' LEVEL HRES C-HRES HOIRES IHOI IDENTS', & ' WT1 WT2 WT3 WT4 HOR-D', & ' CHOR-D IHOID') 605 FORMAT(1X,I3,2X,2F8.0,14X,4I4,4F8.3) 606 FORMAT(1X,I3,2X,3F8.0,I5,1X,4I4,4F8.3,2F8.0,I4) 608 FORMAT(1X,I3,2X,F8.0,21X,F8.0) 607 FORMAT(' LEVEL VRES CVRES VOIRES IVOI', & ' TRES CTRES TMPSTD ITMP TRES-D CTRES-D ITMPD') 609 FORMAT(1X,I3,2X,3F8.0,I5,3F8.0,I5,2F8.0,I5) 610 FORMAT(' LEVEL HYRES HYRES-T CHYRES CHYRES-T', & ' HSCRES IHSC CBSUM') 611 FORMAT(1X,I3,2X,3F8.1,F9.1,F8.1,I5,F8.3) 612 FORMAT(' CBRES: ',F8.1) RETURN END C*************************************************************** SUBROUTINE TYPE0(IS,KK,IV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE0 CHECK FOR TYPE 0 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 0 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-20 W. COLLINS ADD TEMPORAL CHECK RESULT TO DECISION. C C USAGE: CALL TYPE0(IS, KK, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C KK - DECISION INDICES C IV2 - INDICATE VARIABLE WITH PROBLEM C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C MARK DEFINITELY BAD VALUES AT L2. C INTEGER KK(3,3) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL C HEIGHT IV = 1 INERT = NERT(L2,IV,IS,ISCAN) CALL UNPACK(NERR(L2,IV,IS,ISCAN),IHSC2,IINC2, . IHOI2,IVOI2,IBAS,IIPL,IHPL) IF( KK(2,1).NE.1 . .AND. ( (IINC2+IHOI2+IVOI2+INERT.GE.4 ) . .OR. (IGES.NE.0.AND.INERT.EQ.2 ))) THEN IF(IGES.EQ.0) THEN IF(L2.LT.NLEV-1) THEN KK(2,1) = 4 ELSE KK(2,1) = 3 ENDIF ELSE KK(2,1) = 3 ENDIF IF(IV2.EQ.0) THEN IV2 = 1 ELSEIF(IV2.EQ.2) THEN IV2 = 3 ENDIF ENDIF C TEMPERATURE IV = 2 INERT = NERT(L2,IV,IS,ISCAN) CALL UNPACK(NERR(L2,IV,IS,ISCAN),IHSC2,IINC2, . IHOI2,IVOI2,IBAS,IIPL,IHPL) IF(LT1.GE.1 .AND. LT1.LE.NPLVL) THEN INERT1 = NERT(LT1,IV,IS,ISCAN) CALL UNPACK(NERR(LT1,IV,IS,ISCAN),IHSC1,IINC1, . IHOI1,IVOI1,IBAS,IIPL,IHPL) ELSE INERT1=0 IINC1=0 IHOI1=0 IVOI1=0 ENDIF IF(LT3.GE.1 .AND. LT3.LE.NPLVL) THEN INERT3 = NERT(LT3,IV,IS,ISCAN) CALL UNPACK(NERR(LT3,IV,IS,ISCAN),IHSC3,IINC3, . IHOI3,IVOI3,IBAS,IIPL,IHPL) ELSE INERT3=0 IINC3=0 IHOI3=0 IVOI3=0 ENDIF NONZ = 0 IF(IINC2.GT.0) NONZ = NONZ + 1 IF(IHOI2.GT.0) NONZ = NONZ + 1 IF(IVOI2.GT.0) NONZ = NONZ + 1 IF(INERT.GT.0) NONZ = NONZ + 1 NONZ1 = 0 IF(IINC1.GT.0) NONZ1 = NONZ1 + 1 IF(IHOI1.GT.0) NONZ1 = NONZ1 + 1 IF(IVOI1.GT.0) NONZ1 = NONZ1 + 1 IF(INERT1.GT.0) NONZ1 = NONZ1 + 1 NONZ3 = 0 IF(IINC3.GT.0) NONZ3 = NONZ3 + 1 IF(IHOI3.GT.0) NONZ3 = NONZ3 + 1 IF(IVOI3.GT.0) NONZ3 = NONZ3 + 1 IF(INERT3.GT.0) NONZ3 = NONZ3 + 1 IF( ( L2.NE.LBB . .AND. ( (NONZ.GE.2.AND.NONZ1.GE.2) . .OR. (NONZ.GE.2.AND.NONZ3.GE.2))) . .OR. (IINC2+IHOI2+IVOI2+INERT.GE.4 ) . .OR. (IGES.NE.0.AND.INERT.EQ.2 )) THEN IF(KK(2,2).NE.1) THEN IF(L2.NE.LBT) THEN KK(2,2) = 4 ELSE KK(2,2) = 3 ENDIF IF(IV2.EQ.0) THEN IV2 = 2 ELSEIF(IV2.EQ.1) THEN IV2 = 3 ENDIF ENDIF ELSEIF(L2.EQ.LBB.AND.IIPL+IHPL.EQ.4) THEN IV2 = 4 ENDIF RETURN END C*************************************************************** SUBROUTINE TYPE1(IS,K2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE1 CHECK FOR TYPE 1 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 1 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE1(IS, K2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2 - DECISION INDEX C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) COMMON /MSGS/ VMAX(2),VMSG(2) DATA C1 /2.231/, C2 /2.789/, CT1 /2.877/, CT2 /3.596/ YY(CON,R,C,RMAX) = CON * ((R+C)/RMAX) & * (RMAX/AMAX1(1.0,ABS(R)))**0.3 WRITE(64,500) IS, ID(IS) 500 FORMAT('0TYPE1--IS:',I4,' ID:',I8) C IF(IC2.EQ.11.AND.L2.GT.NLEV) RETURN IV = 1 C C GET APPROPRIATE ZZCOR FOR ERROR TYPE. C IBOUND = 0 IF(IC2.EQ.5.OR.ICH3.EQ.13.OR.ICH3.EQ.14) THEN ZZCOR(2) = ZZCOR(2) - HYS(1) IBB = 1 IBOUND = 1 ELSEIF(IC2.EQ.4.OR.ICH2.EQ.13.OR.ICH2.EQ.14) THEN ZZCOR(2) = ZZCOR(2) + HYS(2) IBB = 2 IBOUND = 1 ELSE IBB = 2 ENDIF C C FIND SIMPLE CORRECTION. C IF(L2.LE.4) THEN ZZCOR(2) = ANINT(ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ZCMIN1 = ZCLIM1 ELSE ZZCOR(2) = 10.*ANINT(0.1*ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ZCMIN1 = ZCLIM2 ENDIF ZZC(2) = ZZ(2) + ZZCOR(2) CALL PBLOCK(1) ITST = 0 SUMB = 0. SUMA = 0. MO = 0 YBO = VMSG(1) YAO = VMSG(1) MH = 0 YBH = VMSG(1) YAH = VMSG(1) MV = 0 YBV = VMSG(1) YAV = VMSG(1) MT = 0 YBT = VMSG(1) YAT = VMSG(1) RATIO = 0. C C CHECK MAGNITUDE. C ZCMIN2 = 4.*DTALL* BB(IBB) ZCMIN0 = AMIN1(ZCMIN1,ZCMIN2) IF(ABS(ZZCOR(2)).LT.ZCMIN0) GO TO 20 C C CHECK FOR TYPE1 ERROR PATTERN AND TEST CORRECTION. C C C INCREMENTS. C IF(DOZ2.LT.VMAX(IV).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99) & .AND.(ICZ1.EQ.0.OR.ICZ1.EQ.99).AND.LZ1.NE.99) THEN ITST = ITST + 1 MO = 1 YBO = YY(C1,DOZ2,0. ,XINC(L2,IV)) YAO = YY(C2,DOZ2,ZZCOR(2),XINC(L2,IV)) SUMB = SUMB + ABS(YBO) SUMA = SUMA + ABS(YAO) ELSEIF(OINCZ(2).LT.VMAX(IV)) THEN ITST = ITST + 1 MO = 1 YBO = YY(C1,OINCZ(2),0. ,XINC(L2,IV)) YAO = YY(C2,OINCZ(2),ZZCOR(2),XINC(L2,IV)) SUMB = SUMB + ABS(YBO) SUMA = SUMA + ABS(YAO) ENDIF C C HORIZONTAL. C IF(DHZ2.LT.VMAX(IV).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99) & .AND.(ICZ1.EQ.0.OR.ICZ1.EQ.99).AND.LZ1.NE.99) THEN ITST = ITST + 1 MH = 1 YBH = YY(C1,DHZ2,0. ,HOIRES(L2,IV)) YAH = YY(C2,DHZ2,ZZCOR(2),HOIRES(L2,IV)) SUMB = SUMB + ABS(YBH) SUMA = SUMA + ABS(YAH) ELSEIF(HRESZ(2).LT.VMAX(IV)) THEN ITST = ITST + 1 MH = 1 YBH = YY(C1,HRESZ(2),0. ,HOIRES(L2,IV)) YAH = YY(C2,HRESZ(2),ZZCOR(2),HOIRES(L2,IV)) SUMB = SUMB + ABS(YBH) SUMA = SUMA + ABS(YAH) ENDIF C C VERTICAL. C IF(VRESZ(2).LT.VMAX(IV).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99) & .AND.(ICZ1.EQ.0.OR.ICZ1.EQ.99)) THEN ITST = ITST + 1 MV = 1 YBV = YY(C1,VRESZ(2),0. ,VOIRES(L2,IV)) YAV = YY(C2,VRESZ(2),ZZCOR(2),VOIRES(L2,IV)) SUMB = SUMB + ABS(YBV) SUMA = SUMA + ABS(YAV) ENDIF C C TEMPORAL. C IF(DTZ2.LT.VMAX(IV).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99) & .AND.(ICZ1.EQ.0.OR.ICZ1.EQ.99).AND.LZ1.NE.99) THEN ITST = ITST + 1 MT = 1 YBT = YY(CT1,DTZ2,0. ,TMPSTD(L2,IV)) YAT = YY(CT2,DTZ2,ZZCOR(2),TMPSTD(L2,IV)) SUMB = SUMB + ABS(YBT) SUMA = SUMA + ABS(YAT) ELSEIF(TRESZ(2).LT.VMAX(IV)) THEN ITST = ITST + 1 MT = 1 YBT = YY(CT1,TRESZ(2),0. ,TMPSTD(L2,IV)) YAT = YY(CT2,TRESZ(2),ZZCOR(2),TMPSTD(L2,IV)) SUMB = SUMB + ABS(YBT) SUMA = SUMA + ABS(YAT) ENDIF IF(SUMA.NE.0) THEN RATIO = SUMB/SUMA ELSE RATIO = 10. ENDIF SUMT = ITST C C IF L2 = LBB, CHECK AGREEMENT WITH Z1COR. C IF((L2.EQ.LBB.AND.LBB.EQ.LBZ & .AND.Z1COR(IS).LT.VMAX(1) & .AND.ZZCOR(2).LT.VMAX(1) & .AND.ABS(Z1COR(IS)-ZZCOR(2)).GT.0.4*XINC(L2,1)) & .OR.(L2.EQ.LBB.AND.LBB.EQ.(LBZ+1) & .AND.Z1COR(IS).LT.VMAX(1) & .AND.ZZCOR(2).LT.VMAX(1) & .AND.ABS(Z2COR(IS)-ZZCOR(2)).GT.0.4*XINC(L2,1))) GO TO 20 C C NOW TEST CORRECTION... C IF((ITST.EQ.0.AND.IBOUND.EQ.0) & .OR.(ITST.GE.1.AND.SUMB.GT.SUMT & .AND.(SUMA.LT.SUMT.OR.(RATIO.GT.3.0 & .AND.SUMA.LT.1.5*SUMT)))) THEN C C GOOD HEIGHT CORRECTION--MAKE IT. C C 10 CONTINUE K2 = 1 COINC(2,IV) = OINC(L2,IV,IS) + ZZCOR(2) CHRES(2,IV) = HINC(L2,IV,IS) + ZZCOR(2) CVRES(2,IV) = VINC(L2,IV,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) IF(LH3.LE.NPLVL) THEN CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,ZZCOR(2),AA RETURN ENDIF IF(ITST.GE.1.AND.SUMB.GT.SUMT.AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 ZZC(2) = ZZ(2) ZZCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,ZZCOR(2),AA RETURN ENDIF IF(ITST.GE.1.AND.SUMB.GT.0.5*SUMT) THEN C C MARK DATA TO BE FLAGGED A DOUBTFUL. C K2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,ZZCOR(2),AA RETURN ENDIF C IF(ITST.GE.1) THEN IF(ITST.LT.1) GOTO 30 C C HEIGHT DECIDED TO BE GOOD. C 20 CONTINUE K2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,ZZCOR(2),AA 501 FORMAT(' MO:',I2,' YBO:',F10.2,' YAO:',F10.2,' MH:',I2, & ' YBH:',F10.2,' YAH:',F10.2,' MV:',I2,' YBV:',F10.2, & ' YAV:',F10.2,' YBT:',F10.2,' YAT:',F10.2,/, & ' ITST:',I2,' SUMB:',F10.2,' SUMA:',F10.2,' K2:',I2, & ' ZZCOR(2):',F8.0,' AA:',F10.2) RETURN C ENDIF C C NOT SUFFICIENT INFORMATION TO MAKE A DECISION. C 30 CONTINUE K2 = 5 ZZC(2) = ZZ(2) ZZCOR(2) = 0. C ENDIF RETURN END C****************************************************************** SUBROUTINE TYPE10(IS,K2,K3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE10 CHECK FOR TYPE 10 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 10 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE10(IS, K2, K3) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2,K3 - DECISION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN IF(L2.EQ.99.OR.LZ3.EQ.99) RETURN C C MAKE CORRECTION IF AT LEAST 2 TESTS ARE AVAILABLE C AND THEIR RESIDUALS ARE SMALL. TEST LEVEL L2. C ALSO REQUIRE THE HYDROSTATIC RESIDUALS TO BE SMALL C AND CORRECTION TO BE OF SUFFICIENT SIZE. C C IF(IGES.NE.0) GO TO 5 IF(ABS(TTCOR(2)).LT.TCMIN) GO TO 10 C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(2,IS,0,IHSC1,IHSC2,IHSC3,IINC2,IX1, & IHOI2,IX2,IVOI2,IX3,ITMPT2,ITMPT3) ISUM = IINC2 + IHOI2 + IVOI2 + ITMPT2 C---------------------------------------- IF(ISUM.LT.2.AND.IHSC1.LT.2.AND.IHSC2.LT.2) GOTO 5 GOTO 99 C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C 5 CONTINUE K2 = 1 GOTO 100 99 CONTINUE IF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K2 = 3 TTC(2) = TT(2) TTCOR(2) = 0. GOTO 100 ENDIF IF((ISUM.GE.4.OR.IHSC1.EQ.2.OR.IHSC2.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 TTC(2) = TT(2) TTCOR(2) = 0. GOTO 100 ENDIF C C DATA MAY BE OK. DONT CORRECT. C 10 K2 = 2 TTC(2) = TT(2) TTCOR(2) = 0. 100 CONTINUE C---------------------------------------- C C NOW TEST FOR CORRECTIONS AT LEVEL LZ3. C C IF(IGES.NE.0) GO TO 15 C IF(ABS(ZZCOR(3)).LT.4.*DTALL*BB(2)) GO TO 20 IF(ABS(ZZCOR(3)).LT.4.*DTALL*BB(2)) THEN K3 = 2 ZZC(3) = ZZ(3) ZZCOR(3) = 0. RETURN ENDIF C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(1,IS,0,IHSC1,IHSC2,IHSC3,IX1,IINC3, & IX2,IHOI3,IX3,IVOI3,ITMPZ2,ITMPZ3) ISUM = IINC3 + IHOI3 + IVOI3 + ITMPZ3 IF(ISUM.LT.2.AND.IHSC2.LT.2.AND.IHSC3.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C 15 CONTINUE K3 = 1 ELSEIF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC3.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K3 = 3 ZZC(3) = ZZ(3) ZZCOR(3) = 0. ELSEIF((ISUM.GE.4.OR.IHSC2.EQ.2.OR.IHSC3.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K3 = 4 ZZC(3) = ZZ(3) ZZCOR(3) = 0. ELSE C C DATA MAY BE OK. DONT CORRECT. C 20 K3 = 2 ZZC(3) = ZZ(3) ZZCOR(3) = 0. ENDIF RETURN END C****************************************************************** SUBROUTINE TYPE2(IS,K2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE2 CHECK FOR TYPE 2 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 2 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE2(IS, K2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2 - DECISION INDEX C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) COMMON /MSGS/ VMAX(2),VMSG(2) DATA ALAPS /-.010737/, DTDIF /5./, AL0 /-.00976/ DATA C1 /2.231/, C2 /2.789/, CT1 /2.877/, CT2 /3.596/ YY(CON,R,C,RMAX) = CON * ((R+C)/RMAX) & * (RMAX/AMAX1(1.0,ABS(R)))**0.3 WRITE(64,500) IS, ID(IS) 500 FORMAT('0TYPE2--IS:',I4,' ID:',I8) C IF(IC2.EQ.22.AND.L2.GT.NLEV) RETURN C IV = 2 C C GET THE APPROPRIATE TTCOR FOR THE ERROR TYPE. C IF IC2.EQ.2 TTCOR(2) IS TAKEN FROM CORECT. C OTHERWISE... C IBOUND = 0 IF(IC2.EQ.5.OR.ICH3.EQ.13.OR.ICH3.EQ.14) THEN TTCOR(2) = TTCOR(2) + HYS(1)/BB(1) IBOUND = 1 ELSEIF(IC2.EQ.4.OR.ICH2.EQ.13.OR.ICH2.EQ.14) THEN TTCOR(2) = TTCOR(2) + HYS(2)/BB(2) IBOUND = 1 ENDIF CALL PBLOCK(1) ICTYP = IC2 TCOLD = TT(2) C C ALLOW FOR 10 PERCENT ERROR IN LAPSE RATE DUE TO C RANGE OF ALLOWABLE TEMPERATURES. C ALAPS = -(G/CP) * 1.10 C ORIGINAL LAPSE RATES, "PRODUCT". C IF(ZZ(2).NE.ZZ(1)) THEN ALPSM0 = (TT(2)-TT(1))/(ZZ(2)-ZZ(1)) ELSE ALPSM0 = 0. ENDIF IF(ZZ(3).NE.ZZ(2)) THEN ALPSP0 = (TT(3)-TT(2))/(ZZ(3)-ZZ(2)) ELSE ALPSP0 = 0. ENDIF PR0 = (TT(3)-TT(2))*(TT(2)-TT(2)) C C LAPSES BASED UPON ASSUMPTION OF SIGN ERROR... C IF(ZZ(3).NE.ZZ(2)) THEN ALAPSP = (TT(3)+TT(2))/(ZZ(3)-ZZ(2)) ELSE ALAPSP = 0. ENDIF IF(ZZ(2).NE.ZZ(1)) THEN ALAPSM = (-TT(2)-TT(1))/(ZZ(2)-ZZ(1)) ELSE ALAPSM = 0. ENDIF DIFM = ABS(ALAPSM-AL0) DIFM0 = ABS(ALPSM0-AL0) DIFP = ABS(ALAPSP-AL0) DIFP0 = ABS(ALPSP0-AL0) IF(ABS(2.*TT(2)+TTCOR(2)).LT.DTDIF & .AND.(ALAPSM.GE.ALAPS.OR.DIFM.LT.DIFM0) & .AND.(ALAPSP.GE.ALAPS.OR.DIFP.LT.DIFP0)) THEN TTCOR(2) = -2. * TT(2) TTC(2) = -TT(2) ELSE C ROUND THE CORRECTION TO NEAREST TENTH DEGREE TTCOR(2) = .1 * ANINT(10.*TTCOR(2)) C ROUND THE TEMPERATURE TO NEAREST TENTH DEGREE C (THIS SHOULD BE UNNECESSARY) TTC(2) = .1 * ANINT(10.*(TT(2)+TTCOR(2))) C C FIND SIMPLE CORRECTION. C ICORT = 10.*TTCOR(2) ICCT = 10.*TT(2) TCORT = ICORT TCT = ICCT CALL SIMPLE(TCORT,TCT,ALLT,NT) TTCOR(2) = 0.1*TCORT TTC(2) = 0.1*(TCT+TCORT) ENDIF C C CHECK FOR TYPE2 ERROR PATTERN AND TEST CORRECTION. C ITST = 0 SUMB = 0. SUMA = 0. MO = 0 YBO = VMSG(1) YAO = VMSG(1) MH = 0 YBH = VMSG(1) YAH = VMSG(1) MV = 0 YBV = VMSG(1) YAV = VMSG(1) MT = 0 YBT = VMSG(1) YAT = VMSG(1) RATIO = 0. C IF(IGES.NE.0) GO TO 10 IF(L2.GT.NPLVL) GO TO 10 IF(ABS(TTCOR(2)).LT.TCMIN) GO TO 20 C C INCREMENTS. C IF(OINCT(2).LT.VMAX(IV)) THEN ITST = ITST + 1 MO = 1 YBO = YY(C1,OINCT(2),0. ,XINC(L2,IV)) YAO = YY(C2,OINCT(2),TTCOR(2),XINC(L2,IV)) SUMB = SUMB + ABS(YBO) SUMA = SUMA + ABS(YAO) ENDIF C C HORIZONTAL. C IF(HREST(2).LT.VMAX(IV)) THEN ITST = ITST + 1 MH = 1 YBH = YY(C1,HREST(2),0. ,HOIRES(L2,IV)) YAH = YY(C2,HREST(2),TTCOR(2),HOIRES(L2,IV)) SUMB = SUMB + ABS(YBH) SUMA = SUMA + ABS(YAH) ENDIF C C VERTICAL. C IF(VREST(2).LT.VMAX(IV).AND.(ICT3.EQ.0.OR.ICT3.EQ.99) & .AND.(ICT1.EQ.0.OR.ICT1.EQ.99)) THEN ITST = ITST + 1 MV = 1 YBV = YY(C1,VREST(2),0. ,VOIRES(L2,IV)) YAV = YY(C2,VREST(2),TTCOR(2),VOIRES(L2,IV)) SUMB = SUMB + ABS(YBV) SUMA = SUMA + ABS(YAV) ENDIF C C TEMPORAL. C IF(TREST(2).LT.VMAX(IV).AND.(ICT3.EQ.0.OR.ICT3.EQ.99) & .AND.(ICT1.EQ.0.OR.ICT1.EQ.99)) THEN ITST = ITST + 1 MT = 1 YBT = YY(CT1,TREST(2),0. ,TMPSTD(L2,IV)) YAT = YY(CT2,TREST(2),TTCOR(2),TMPSTD(L2,IV)) SUMB = SUMB + ABS(YBT) SUMA = SUMA + ABS(YAT) ENDIF IF(SUMA.NE.0.) THEN RATIO = SUMB/SUMA ELSE RATIO = 10. ENDIF SUMT = ITST IF((ITST.EQ.0.AND.IBOUND.EQ.0) & .OR.(ITST.GE.1.AND.SUMB.GT.SUMT & .AND.(SUMA.LT.SUMT.OR.(RATIO.GT.3.0 & .AND.SUMA.LT.1.5*SUMT)))) GOTO 10 GOTO 11 C C GOOD TEMPERATURE CORRECTION--MAKE IT. C (SHOULD RESULTING LAPSE RATES BE CHECKED?) C 10 CONTINUE K2 = 1 COINC(2,IV) = OINC(L2,IV,IS) + TTCOR(2) CHRES(2,IV) = HINC(L2,IV,IS) + TTCOR(2) CVRES(2,IV) = VINC(L2,IV,IS) + TTCOR(2) CHYRES(1) = HYRES(L2,IS) - BB(1) * TTCOR(2) IF(LH3 .LE. NPLVL) THEN CHYRES(2) = HYRES(LH3,IS) - BB(2) * TTCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,TTCOR(2),AA RETURN 11 CONTINUE IF(ITST.GE.1.AND.SUMB.GT.SUMT.AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 TTC(2) = TT(2) TTCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,TTCOR(2),AA RETURN ENDIF IF(ITST.GE.1.AND.SUMB.GT.0.5*SUMT) THEN C C MARK DATA TO BE FLAGGED AS DOUBTFUL. C K2 = 3 TTC(2) = TT(2) TTCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,TTCOR(2),AA RETURN ENDIF IF(ITST.GE.1) GOTO 20 C C TEMPERATURE DECIDED TO BE GOOD. C GOTO 30 20 K2 = 2 TTC(2) = TT(2) TTCOR(2) = 0. WRITE(64,501) MO,YBO,YAO,MH,YBH,YAH,MV,YBV,YAV, & YBT,YAT,ITST,SUMB,SUMA,K2,TTCOR(2),AA 501 FORMAT(' MO:',I2,' YBO:',F10.2,' YAO:',F10.2,' MH:',I2, & ' YBH:',F10.2,' YAH:',F10.2,' MV:',I2,' YBV:',F10.2, & ' YAV:',F10.2,' YBT:',F10.2,' YAT:',F10.2,/, & ' ITST:',I2,' SUMB:',F10.2,' SUMA:',F10.2,' K2:',I2, & ' TTCOR(2):',F8.1,' AA:',F10.2) RETURN 30 CONTINUE C C THERE IS NOT SUFFICIENT INFORMATION TO MAKE A DECISION. C K2 = 5 TTC(2) = TT(2) TTCOR(2) = 0. RETURN END C***************************************************************** SUBROUTINE TYPE3(IS,KZ,KT,IV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE3 CHECK FOR TYPE 3 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 3 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE3(IS, KZ, KT, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C KZ,KT - DECISION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) COMMON /MSGS/ VMAX(2),VMSG(2) WRITE(64,500) IS, ID(IS) 500 FORMAT('0TYPE3--IS:',I4,' ID:',I8) C IF(L2.GT.NLEV.OR.IGES.NE.0) RETURN C C TEST CORRECTIONS. C IF( ((L2.EQ.LBB.OR.L2.EQ.LBB+1) & .AND. (ICH1.EQ.0.AND.ICH3.EQ.0.AND.IBSL.EQ.0)) & .OR. ((L2.GT.LBB+1) .AND. (BB(1)+BB(2).GT.5.0) & .AND. (ICH1.EQ.0.AND.ICH3.EQ.0)) ) THEN C C FOR ZERO ADJACENT ERROR TYPES, GET CORRECTIONS FROM C HYDROSTATIC RESIDUALS. C ZZCOR(2) = (BB(1)*HYS(2) - BB(2)*HYS(1))/(BB(1)+BB(2)) IF(L2.LE.4) ZZCOR(2) = ANINT(ZZCOR(2)) IF(L2.GT.4) ZZCOR(2) = 10.*ANINT(ZZCOR(2)/10.) TTCOR(2) = (HYS(1)+HYS(2))/(BB(1)+BB(2)) TTCOR(2) = 0.1 * ANINT(10.*TTCOR(2)) WRITE(64,503) IS,ID(IS),ZZCOR(2),TTCOR(2),L2,LBB, & ICH1,ICH3,IBSL 503 FORMAT(' TYPE3A--IS:',I4,' ID:',I8,' ZZCOR(2):',F8.0, & ' TTCOR(2):',F8.1,' L2:',I4,' LBB:',I4,' ICH1:',I4, & ' ICH3:',I4,' IBSL:',I4) ICONT = 0 IF((OINCZ(2).LT.VMAX(1).AND.OINCT(2).LT.VMAX(2)) & .OR.(HRESZ(2).LT.VMAX(1).AND.HREST(2).LT.VMAX(2)) & .OR.(VRESZ(2).LT.VMAX(1).AND.VREST(2).LT.VMAX(2)) & .OR.(TRESZ(2).LT.VMAX(1).AND.TREST(2).LT.VMAX(2))) ICONT = 1 IF(ICONT.EQ.0) GO TO 110 ELSE C C OTHERWISE, GET TEST CORRECTIONS FROM AVERAGE OF INCREMENT C AND RESIDUALS. C IF(DOZ2.LT.VMAX(1).AND.ICZ3.EQ.0.AND.ICZ1.EQ.0) THEN ZA = DOZ2 ELSEIF(OINCZ(2).LT.VMAX(1)) THEN ZA = OINCZ(2) ELSE ZA = VMSG(1) ENDIF IF(DHZ2.LT.VMAX(1).AND.ICZ3.EQ.0.AND.ICZ1.EQ.0) THEN ZB = DHZ2 ELSEIF(HRESZ(2).LT.VMAX(1)) THEN ZB = HRESZ(2) ELSE ZB = VMSG(1) ENDIF IF(VRESZ(2).LT.VMAX(1).AND.ICZ3.EQ.0.AND.ICZ1.EQ.0) THEN ZC = VRESZ(2) ELSE ZC = VMSG(1) ENDIF IF(DTZ2.LT.VMAX(1).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99)) THEN ZD = DTZ2 ELSEIF(TRESZ(2).LT.VMAX(1)) THEN ZD = TRESZ(2) ELSE ZD = VMSG(1) ENDIF IF(OINCT(2).LT.VMAX(2)) THEN TA = OINCT(2) ELSE TA = VMSG(2) ENDIF IF(HREST(2).LT.VMAX(2)) THEN TB = HREST(2) ELSE TB = VMSG(2) ENDIF IF(VREST(2).LT.VMAX(2).AND.ICT3.EQ.0.AND.ICT1.EQ.0) THEN TC = VREST(2) ELSE TC = VMSG(2) ENDIF IF(DTT2.LT.VMAX(1).AND.(ICT3.EQ.0.OR.ICT3.EQ.99)) THEN TD = DTT2 ELSEIF(TREST(2).LT.VMAX(1)) THEN TD = TREST(2) ELSE TD = VMSG(2) ENDIF ALZ = XINC(L2,1)*ECON2 ALT = XINC(L2,2)*ECON2 ITSTZ = 0 ITSTT = 0 SUMZ = 0. SUMT = 0. C FORM AVERAGE OF RESIDUALS AS SUGGESTED CORRECTION. C SHOULD THERE BE A REQUIREMENT FOR A MINIMUM SIZE C FOR THE RESIDUALS? C IF(ZA.LT.VMAX(1).AND.ZB.LT.VMAX(1) & .AND.ABS(ZA-ZB).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZB) ENDIF IF(ZA.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZA-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZC) ENDIF IF(ZB.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZB-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZC) ENDIF IF(ZA.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZA-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZD) ENDIF IF(ZB.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZB-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZD) ENDIF IF(ZC.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZC-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZC+ZD) ENDIF IF(TA.LT.VMAX(2).AND.TB.LT.VMAX(2) & .AND.ABS(TA-TB).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TB) ENDIF IF(TA.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TA-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TC) ENDIF IF(TB.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TB-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TC) ENDIF IF(TA.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TA-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TD) ENDIF IF(TB.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TB-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TD) ENDIF IF(TC.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TC-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TC+TD) ENDIF IF(ITSTZ.GT.0.AND.ITSTT.GT.0) THEN C C SUGGESTED CORRECTIONS: C ZZCOR(2) = -SUMZ/ITSTZ TTCOR(2) = -SUMT/ITSTT ZZC(2) = ZZ(2) + ZZCOR(2) TTC(2) = TT(2) + TTCOR(2) WRITE(64,501) IS, ID(IS), ZZCOR(2), TTCOR(2) 501 FORMAT(' TYPE3B--IS:',I4,' ID:',I8,' ZZCOR(2):',F8.0, & ' TTCOR(2):',F8.1) ELSE GO TO 110 ENDIF ENDIF C C FIND SIMPLE CORRECTIONS. C IF(L2.LE.4) THEN CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ELSE CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ENDIF ZZC(2) = ZZ(2) + ZZCOR(2) CALL SIMPLE(TTCOR(2),TT(2),ALLT,NT) TTC(2) = TT(2) + TTCOR(2) WRITE(64,502) IS, ID(IS), ZZCOR(2), TTCOR(2) 502 FORMAT(' AFTER SIMPLE--IS:',I4,' ID:',I8,' ZZCOR(2):',F8.0, & ' TTCOR(2):',F8.1) CALL PBLOCK(1) C C TEST CORRECTIONS. C CALL TSTCOR(1,IS,0,IHSC1,IHSC2,IHSC3,IINCZ2,IINCZ3, & IHOIZ2,IHOIZ3,IVOIZ2,IVOIZ3,ITMPZ2,ITMPZ3) CALL TSTCOR(2,IS,0,IHSC1,IHSC2,IHSC3,IINCT2,IINCT3, & IHOIT2,IHOIT3,IVOIT2,IVOIT3,ITMPT2,ITMPT3) IF(ICH1.NE.0.OR.ICH3.NE.0) THEN IVOIZ2 = 0 IVOIT2 = 0 ENDIF C C TEST TO SEE IF CORRECTIONS ARE ACCEPTABLE. C IHSC = 0 IF(ICH1.EQ.0.AND.ICH3.EQ.0 & .AND.(IHSC1.EQ.2.OR.IHSC2.EQ.2)) IHSC = 1 ISUMZ = IINCZ2 + IHOIZ2 + IVOIZ2 + ITMPZ2 ISUMT = IINCT2 + IHOIT2 + IVOIT2 + ITMPT2 IF(L2.LE.4) THEN ZCMIN0 = ZCLIM1 ELSE ZCMIN0 = ZCLIM2 ENDIF IF(ISUMZ.LT.2.AND.ABS(ZZCOR(2)).GE.ZCMIN0 & .AND.ISUMT.LT.2.AND.ABS(TTCOR(2)).GE.TCMIN & .AND.IHSC.EQ.0) THEN C C MAKE BOTH CORRECTIONS. C KZ = 1 KT = 1 IV2 = 3 COINC(2,1) = OINC(L2,1,IS) + ZZCOR(2) CHRES(2,1) = HINC(L2,1,IS) + ZZCOR(2) CVRES(2,1) = VINC(L2,1,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) COINC(2,2) = OINC(L2,2,IS) + TTCOR(2) CHRES(2,2) = HINC(L2,2,IS) + TTCOR(2) CVRES(2,2) = VINC(L2,2,IS) + TTCOR(2) CHYRES(1) = HYRES(L2,IS) + BB(1) * TTCOR(2) CHYRES(2) = HYRES(LH3,IS) + BB(2) * TTCOR(2) RETURN ELSEIF(ISUMZ.LT.2.AND.ABS(ZZCOR(2)).GE.ZCMIN0 & .AND.IHSC.EQ.0) THEN C C MAKE HEIGHT CORRECTION ONLY. C KZ = 1 KT = 2 IV2 = 1 TTC(2) = TT(2) TTCOR(2) = 0. COINC(2,1) = OINC(L2,1,IS) + ZZCOR(2) CHRES(2,1) = HINC(L2,1,IS) + ZZCOR(2) CVRES(2,1) = VINC(L2,1,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) RETURN ELSEIF(ISUMT.LT.2.AND.ABS(TTCOR(2)).GE.TCMIN & .AND.IHSC.EQ.0) THEN C C MAKE TEMPERATURE CORRECTION ONLY. C KT = 1 KZ = 2 IV2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. COINC(2,2) = OINC(L2,2,IS) + TTCOR(2) CHRES(2,2) = HINC(L2,2,IS) + TTCOR(2) CVRES(2,2) = VINC(L2,2,IS) + TTCOR(2) CHYRES(1) = HYRES(L2,IS) - BB(1) * TTCOR(2) CHYRES(2) = HYRES(LH3,IS) - BB(2) * TTCOR(2) RETURN ELSE C C MAKE NO CORRECTION. C 100 CONTINUE KZ = 3 KT = 3 IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. RETURN ENDIF C C ONLY HYDROSTATIC CHECK USEFUL. MAKE NO CORRECTION. C 110 CONTINUE KZ = 5 KT = 5 IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. WRITE(64,504) IS,ID(IS),L2,ICONT,ZA,ZB,ZC,ZD,TA,TB,TC,TD 504 FORMAT(' TYPE3C--IS:',I4,' ID:',I8,' L2:',I3,' ICONT:',I2,/, . ' ZA,ZB,ZC,ZD:',4F7.0,' TA,TB,TC,TD:',4F7.1) RETURN END C***************************************************************** SUBROUTINE TYPE4(IS,KK,IV2,IV3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE4 CHECK FOR TYPE 4 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 4 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE4(IS, KK, IV2, IV3) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C KK - DECISION INDICES C IV2,IV3 - INDICATE VARIABLES WITH PROBLEM C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ INTEGER KK(3,3) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN COMMON /MSGS/ VMAX(2),VMSG(2) WRITE(64,500) IS, ID(IS), L2 500 FORMAT('0TYPE4--IS:',I4,' ID:',I8,' L2:',I3) IF(L2.LT.1.OR.L2.GT.NPLVL) RETURN C C CHECK FOR TYPE 1 ERROR PATTERN. C ZZCOR(2) = 0. TTCOR(2) = 0. CALL TYPE1(IS,KK(2,1)) IF(KK(2,1).EQ.1) THEN IV2 = 1 TTCOR(2) = 0. TTC(2) = TT(2) COINC(2,IV2) = OINC(L2,IV2,IS) + ZZCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + ZZCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + ZZCOR(2) IF(HYRES(L2,IS).LT.VMAX(1)) THEN CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) ELSE CHYRES(1) = VMSG(1) ENDIF IF(LH3.LE.NPLVL) THEN IF(HYRES(LH3,IS).LT.VMAX(1)) THEN CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF ELSE CHYRES(2) = VMSG(1) ENDIF RETURN ENDIF C C CHECK FOR TYPE 2 ERROR PATTERN. C CALL TYPE2(IS,KK(2,2)) IF(KK(2,2).GT.2.AND.IV2.EQ.0) THEN IV2 = 2 ENDIF IF(KK(2,2).EQ.1) THEN IV2 = 2 ZZCOR(2) = 0. ZZC(2) = ZZ(2) COINC(2,IV2) = OINC(L2,IV2,IS) + TTCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + TTCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + TTCOR(2) IF(HYRES(L2,IS).LT.VMAX(1)) THEN CHYRES(1) = HYRES(L2,IS) - BB(1) * TTCOR(2) ELSE CHYRES(1) = VMSG(1) ENDIF IF(LH3.LE.NPLVL) THEN IF(HYRES(LH3,IS).LT.VMAX(1)) THEN CHYRES(2) = HYRES(LH3,IS) - BB(2) * TTCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF ELSE CHYRES(2) = VMSG(1) ENDIF RETURN ENDIF C C CHECK FOR TYPE 3 ERROR PATTERN. C COLLECT INCREMENTS/RESIDUALS/RESIDUAL DIFFERENCES C TO AVERAGE FOR CORRECTION TEST. C IF(DOZ2.LT.VMAX(1).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99)) THEN ZA = DOZ2 ELSEIF(OINCZ(2).LT.VMAX(1)) THEN ZA = OINCZ(2) ELSE ZA = VMSG(1) ENDIF IF(DHZ2.LT.VMAX(1).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99)) THEN ZB = DHZ2 ELSEIF(HRESZ(2).LT.VMAX(1)) THEN ZB = HRESZ(2) ELSE ZB = VMSG(1) ENDIF IF(VRESZ(2).LT.VMAX(1).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99)) THEN ZC = VRESZ(2) ELSE ZC = VMSG(1) ENDIF IF(DTZ2.LT.VMAX(1).AND.(ICZ3.EQ.0.OR.ICZ3.EQ.99)) THEN ZD = DTZ2 ELSEIF(TRESZ(2).LT.VMAX(1)) THEN ZD = TRESZ(2) ELSE ZD = VMSG(1) ENDIF IF(OINCT(2).LT.VMAX(2)) THEN TA = OINCT(2) ELSE TA = VMSG(2) ENDIF IF(HREST(2).LT.VMAX(2)) THEN TB = HREST(2) ELSE TB = VMSG(2) ENDIF IF(VREST(2).LT.VMAX(2).AND.(ICT3.EQ.0.OR.ICT3.EQ.99)) THEN TC = VREST(2) ELSE TC = VMSG(2) ENDIF IF(DTT2.LT.VMAX(1).AND.(ICT3.EQ.0.OR.ICT3.EQ.99)) THEN TD = DTT2 ELSEIF(TREST(2).LT.VMAX(1)) THEN TD = TREST(2) ELSE TD = VMSG(1) ENDIF ALZ = XINC(L2,1)*ECON2 ALT = XINC(L2,2)*ECON2 ITSTZ = 0 ITSTT = 0 SUMZ = 0. SUMT = 0. C C FORM AVERAGE OF RESIDUALS AS SUGGESTED CORRECTION. C AT LEAST 2 N0N-MISSING VALUES ARE REQUIRED. C SHOULD THERE BE A REQUIREMENT FOR A MINIMUM SIZE C FOR THE RESIDUALS? C IF(ZA.LT.VMAX(1).AND.ZB.LT.VMAX(1) & .AND.ABS(ZA-ZB).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZB) ENDIF IF(ZA.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZA-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZC) ENDIF IF(ZB.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZB-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZC) ENDIF IF(ZA.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZA-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZD) ENDIF IF(ZB.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZB-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZD) ENDIF IF(ZC.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZC-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZC+ZD) ENDIF IF(TA.LT.VMAX(2).AND.TB.LT.VMAX(2) & .AND.ABS(TA-TB).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TB) ENDIF IF(TA.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TA-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TC) ENDIF IF(TB.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TB-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TC) ENDIF IF(TA.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TA-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TD) ENDIF IF(TB.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TB-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TD) ENDIF IF(TC.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TC-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TC+TD) ENDIF IF(ITSTZ.GT.0.AND.ITSTT.GT.0) THEN C C TEST CORRECTIONS. C ZZCOR(2) = -SUMZ/ITSTZ TTCOR(2) = -SUMT/ITSTT ZZC(2) = ZZ(2) + ZZCOR(2) TTC(2) = TT(2) + TTCOR(2) C WRITE(64,502) IS,ID(IS),ZZCOR(2),TTCOR(2) C 502 FORMAT(' TYPE43--BEFORE MINIMIZATION--IS:',I4, C & ' ID:',I8,' ZZCOR(2):',F8.0,' TTCOR(2):',F8.1) C C MINIMIZE CHANGE TO ZZC, TTC WHICH GIVES S = 0. C FIRST, DETERMINE NEW HYDROSTATIC RESIDUALS. C C COMPUTE NEW HYDROSTATIC RESIDUALS BASED UPON C TYPE 3 CORRECTIONS. C C IF(IC2.NE.13.AND.IC2.NE.14) THEN C CALL HSC1 C C IF(ABS(CHYRES(2)).LT.VMAX(1)) THEN C ZZCOR(2) = ZZCOR(2) + 0.5 * CHYRES(2) C ZZC(2) = ZZC(2) + 0.5 * CHYRES(2) C IF(CBSUM(2).NE.0.) THEN C TTCOR(2) = TTCOR(2) + 0.5 * CHYRES(2)/CBSUM(2) C TTC(2) = TTC(2) + 0.5 * CHYRES(2)/CBSUM(2) C ENDIF C ENDIF C ENDIF C C FIND SIMPLE CORRECTIONS. C IF(L2.LE.4) THEN CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ZCMIN1 = ZCLIM1 ELSE CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ZCMIN1 = ZCLIM2 ENDIF CALL SIMPLE(TTCOR(2),TT(2),ALLT,NT) WRITE(64,501) IS,ID(IS),CHYRES(2),CBSUM(2),ZZCOR(2),ZZC(2), & TTCOR(2), TTC(2) 501 FORMAT(' TYPE43--IS:',I4,' ID:',I8, & ' CHYRES(2):',F8.1,' CBSUM(2):', & F8.3,' ZZCOR(2):',F8.0,' ZZC(2):',F8.0,' TTCOR(2):', & F8.1,' TTC(2):',F8.1) ZZC(2) = ZZ(2) + ZZCOR(2) TTC(2) = TT(2) + TTCOR(2) C C TEST TYPE 3 CORRECTIONS. C IF(CBSUM(2).LT.VMAX(1)) THEN CBS = CBSUM(2) ELSE CBS = 5. ENDIF ZCMIN2 = ZCMIN * CBS ZCMIN0 = AMIN1(ZCMIN1,ZCMIN2) IF(ABS(ZZCOR(2)).GT.ZCMIN0) THEN CALL TSTCOR(1,IS,0,IHSC1,IHSC2,IHSC3,IINCZ2,IINCZ3, & IHOIZ2,IHOIZ3,IVOIZ2,IVOIZ3,ITMPZ2,ITMPZ3) ELSE ZZCOR(2) = 0. GO TO 30 ENDIF IF(ABS(TTCOR(2)).GT.TCMIN) THEN CALL TSTCOR(2,IS,0,IHSC1,IHSC2,IHSC3,IINCT2,IINCT3, & IHOIT2,IHOIT3,IVOIT2,IVOIT3,ITMPT2,ITMPT3) ELSE TTCOR(2) = 0. GO TO 30 ENDIF C C TEST TO SEE IF CORRECTIONS ARE ACCEPTABLE. C ISUMZ = IINCZ2 + IHOIZ2 + IVOIZ2 + ITMPZ2 ISUMT = IINCT2 + IHOIT2 + IVOIT2 + ITMPT2 IF(ISUMZ.LT.2.AND.ISUMT.LT.2 & .AND.(IHSC1.LT.2.OR.IC2.EQ.13.OR.IC2.EQ.14) & .AND.IHSC2.LT.2) THEN C C GOOD TYPE 3 CORRECTIONS--MAKE THEM. C KK(2,1) = 1 KK(2,2) = 1 IV2 = 3 COINC(2,1) = OINC(L2,1,IS) + ZZCOR(2) CHRES(2,1) = HINC(L2,1,IS) + ZZCOR(2) CVRES(2,1) = VINC(L2,1,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) IF(LH3.NE.99) CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) COINC(2,2) = OINC(L2,2,IS) + TTCOR(2) CHRES(2,2) = HINC(L2,2,IS) + TTCOR(2) CVRES(2,2) = VINC(L2,2,IS) + TTCOR(2) C CHYRES(1) = HYRES(L2,IS) - BB(1) * TTCOR(2) C CHYRES(2) = HYRES(LH3,IS) - BB(2) * TTCOR(2) RETURN ENDIF C C DONT MAKE TYPE 3 CORRECTIONS. C 30 CONTINUE IF(IC2.EQ.13 .OR. IC2.EQ.14) THEN KK(2,1) = 2 KK(2,2) = 2 ELSE KK(2,1) = 3 KK(2,2) = 3 ENDIF IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. RETURN ELSE C C DONT MAKE TYPE 3 CORRECTIONS. C KK(2,1) = 5 KK(2,2) = 5 IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. ENDIF RETURN END C************************************************************ SUBROUTINE TYPE5(IS,KK,IV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE5 CHECK FOR TYPE 5 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 5 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE5(IS, KK, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C KK - DECISION INDICES C IV2 - INDICATE VARIABLE WITH PROBLEM C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ INTEGER KK(3,3) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN COMMON /MSGS/ VMAX(2),VMSG(2) WRITE(64,500) IS, ID(IS), L2 500 FORMAT('0TYPE5--IS:',I4,' ID:',I8,' L2:',I3) C IF(L2.GT.NLEV.OR.IGES.NE.0) RETURN C C CHECK FOR TYPE 1 ERROR PATTERN. C ZZCOR(2) = 0. TTCOR(2) = 0. CALL TYPE1(IS,KK(2,1)) IF(KK(2,1).GT.2) IV2 = 1 IF(KK(2,1).EQ.1) THEN IV2 = 1 TTCOR(2) = 0. TTC(2) = TT(2) COINC(2,IV2) = OINC(L2,IV2,IS) + ZZCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + ZZCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + ZZCOR(2) IF(HYRES(L2,IS).LT.VMAX(1)) THEN CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) ELSE CHYRES(1) = VMSG(1) ENDIF IF(LH3.LE.NPLVL) THEN IF(HYRES(LH3,IS).LT.VMAX(1)) THEN CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF ELSE CHYRES(2) = VMSG(1) ENDIF RETURN ENDIF C C CHECK FOR TYPE 2 ERROR PATTERN. C CALL TYPE2(IS,KK(2,2)) IF(KK(2,2).GT.2.AND.IV2.EQ.1) IV2 = 3 IF(KK(2,2).GT.2.AND.IV2.EQ.0) IV2 = 2 IF(KK(2,2).EQ.1) THEN IV2 = 2 ZZCOR(2) = 0. ZZC(2) = ZZ(2) COINC(2,IV2) = OINC(L2,IV2,IS) + TTCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + TTCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + TTCOR(2) IF(HYRES(L2,IS).LT.VMAX(1)) THEN CHYRES(1) = HYRES(L2,IS) - BB(1) * TTCOR(2) ELSE CHYRES(1) = VMSG(1) ENDIF IF(LH3 .LE. NPLVL) THEN IF(HYRES(LH3,IS).LT.VMAX(1)) THEN CHYRES(2) = HYRES(LH3,IS) - BB(2) * TTCOR(2) ELSE CHYRES(2) = VMSG(1) ENDIF ELSE CHYRES(2) = VMSG(1) ENDIF RETURN ENDIF C C CHECK FOR TYPE 3 ERROR PATTERN. C IF(DOZ2.LT.VMAX(1).AND.ICZ1.EQ.0) THEN ZA = DOZ2 ELSEIF(OINCZ(2).LT.VMAX(1)) THEN ZA = OINCZ(2) ELSE ZA = VMSG(1) ENDIF IF(DHZ2.LT.VMAX(1).AND.ICZ1.EQ.0) THEN ZB = DHZ2 ELSEIF(HRESZ(2).LT.VMAX(1)) THEN ZB = HRESZ(2) ELSE ZB = VMSG(1) ENDIF IF(VRESZ(2).LT.VMAX(1).AND.ICZ1.EQ.0) THEN ZC = VRESZ(2) ELSE ZC = VMSG(1) ENDIF IF(DTZ2.LT.VMAX(1).AND.(ICZ1.EQ.0.OR.ICZ1.EQ.99)) THEN ZD = DTZ2 ELSEIF(TRESZ(2).LT.VMAX(1)) THEN ZD = TRESZ(2) ELSE ZD = VMSG(1) ENDIF IF(OINCT(2).LT.VMAX(2)) THEN TA = OINCT(2) ELSE TA = VMSG(2) ENDIF IF(HREST(2).LT.VMAX(2)) THEN TB = HREST(2) ELSE TB = VMSG(2) ENDIF IF(VREST(2).LT.VMAX(2).AND.ICT1.EQ.0) THEN TC = VREST(2) ELSE TC = VMSG(2) ENDIF IF(DTT2.LT.VMAX(1).AND.(ICT3.EQ.0.OR.ICT3.EQ.99)) THEN TD = DTT2 ELSEIF(TREST(2).LT.VMAX(1)) THEN TD = TREST(2) ELSE TD = VMSG(1) ENDIF ALZ = ECON2*XINC(L2,1) ALT = ECON2*XINC(L2,2) ITSTZ = 0 ITSTT = 0 SUMZ = 0. SUMT = 0. C C FORM AVERAGE OF RESIDUALS AS SUGGESTED CORRECTION. C SHOULD THERE BE A REQUIREMENT FOR A MINIMUM SIZE C FOR THE RESIDUALS? C IF(ZA.LT.VMAX(1).AND.ZB.LT.VMAX(1) & .AND.ABS(ZA-ZB).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZB) ENDIF IF(ZA.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZA-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZC) ENDIF IF(ZB.LT.VMAX(1).AND.ZC.LT.VMAX(1) & .AND.ABS(ZB-ZC).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZC) ENDIF IF(ZA.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZA-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZA+ZD) ENDIF IF(ZB.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZB-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZB+ZD) ENDIF IF(ZC.LT.VMAX(1).AND.ZD.LT.VMAX(1) & .AND.ABS(ZC-ZD).LT.ALZ) THEN ITSTZ = ITSTZ + 1 SUMZ = SUMZ + 0.5 * (ZC+ZD) ENDIF IF(TA.LT.VMAX(2).AND.TB.LT.VMAX(2) & .AND.ABS(TA-TB).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TB) ENDIF IF(TA.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TA-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TC) ENDIF IF(TB.LT.VMAX(2).AND.TC.LT.VMAX(2) & .AND.ABS(TB-TC).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TC) ENDIF IF(TA.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TA-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TA+TD) ENDIF IF(TB.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TB-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TB+TD) ENDIF IF(TC.LT.VMAX(2).AND.TD.LT.VMAX(2) & .AND.ABS(TC-TD).LT.ALT) THEN ITSTT = ITSTT + 1 SUMT = SUMT + 0.5 * (TC+TD) ENDIF IF(ITSTZ.GT.0.AND.ITSTT.GT.0) THEN C C TEST TYPE 3 CORRECTIONS. C ZZCOR(2) = -SUMZ/ITSTZ TTCOR(2) = -SUMT/ITSTT ZZC(2) = ZZ(2) + ZZCOR(2) TTC(2) = TT(2) + TTCOR(2) WRITE(64,502) IS,ID(IS),ZZCOR(2),TTCOR(2) 502 FORMAT(' TYPE53--BEFORE MINIMIZATION--IS:',I4,' ID:',I8, & ' ZZCOR(2):',F8.0,' TTCOR(2):',F8.1) C MINIMIZE CHANGE TO ZZC, TTC WHICH GIVES S = 0. C FIRST, DETERMINE NEW HYDROSTATIC RESIDUALS. C C COMPUTE NEW HYDROSTATIC RESIDUALS, BASED UPON C TYPE CORRECTION. IF(ICZ1.NE.13.AND.ICZ1.NE.14) THEN CALL HSC1 IF(ABS(CHYRES(1)).LT.VMAX(1)) THEN ZZCOR(2) = ZZCOR(2) - 0.5 * CHYRES(1) ZZC(2) = ZZC(2) - 0.5 * CHYRES(1) IF(CBSUM(1).NE.0.) THEN TTCOR(2) = TTCOR(2) + 0.5 * CHYRES(1)/CBSUM(1) TTC(2) = TTC(2) + 0.5 * CHYRES(1)/CBSUM(1) ENDIF ENDIF ENDIF C C FIND SIMPLE CORRECTIONS. C IF(L2.LE.4) THEN CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ZCMIN1 = ZCLIM1 ELSE CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ZCMIN1 = ZCLIM2 ENDIF ZZC(2) = ZZ(2) + ZZCOR(2) CALL SIMPLE(TTCOR(2),TT(2),ALLT,NT) TTC(2) = TT(2) + TTCOR(2) WRITE(64,501) IS,ID(IS),CHYRES(2),CBSUM(2),ZZCOR(2),ZZC(2), & TTCOR(2), TTC(2) 501 FORMAT(' TYPE53--IS:',I4,' ID:',I8, & ' CHYRES(2):',F8.1,' CBSUM(2):', & F8.3,' ZZCOR(2):',F8.0,' ZZC(2):',F8.0,' TTCOR(2):', & F8.1,' TTC(2):',F8.1) C C TEST CORRECTIONS. C IF(CBSUM(1).LT.VMAX(1)) THEN CBS = CBSUM(1) ELSE CBS = 5. ENDIF ZCMIN2 = ZCMIN * CBS ZCMIN0 = AMIN1(ZCMIN1,ZCMIN2) IF(ABS(ZZCOR(2)).GT.ZCMIN0) THEN CALL TSTCOR(1,IS,0,IHSC1,IHSC2,IHSC3,IINCZ2,IINCZ3, & IHOIZ2,IHOIZ3,IVOIZ2,IVOIZ3,ITMPZ2,ITMPZ3) ELSE ZZCOR(2) = 0. GO TO 30 ENDIF IF(ABS(TTCOR(2)).GT.TCMIN) THEN CALL TSTCOR(2,IS,0,IHSC1,IHSC2,IHSC3,IINCT2,IINCT3, & IHOIT2,IHOIT3,IVOIT2,IVOIT3,ITMPT2,ITMPT3) ELSE TTCOR(2) = 0. GO TO 30 ENDIF C C TEST TO SEE IF CORRECTIONS ARE ACCEPTABLE. C ISUMZ = IINCZ2 + IHOIZ2 + IVOIZ2 + ITMPZ2 ISUMT = IINCT2 + IHOIT2 + IVOIT2 + ITMPT2 IF(ISUMZ.LT.2.AND.ISUMT.LT.2 & .AND.IHSC1.LT.2. & .AND.(IHSC2.LT.2.OR.ICZ3.EQ.13.OR.ICZ3.EQ.14 & .OR.ICZ3.EQ.4)) THEN C C GOOD TYPE 3 CORRECTIONS--MAKE THEM. C KK(2,1) = 1 KK(2,2) = 1 IV2 = 3 RETURN ENDIF C C DONT MAKE CORRECTIONS. C 30 CONTINUE IF(ICZ1.EQ.13 .OR. ICZ1.EQ.14) THEN KK(2,1) = 2 KK(2,2) = 2 ELSE KK(2,1) = 3 KK(2,2) = 3 ENDIF IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. ELSE C C DONT MAKE CORRECTIONS. C KK(2,1) = 5 KK(2,2) = 5 IV2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. TTC(2) = TT(2) TTCOR(2) = 0. RETURN ENDIF RETURN END C***************************************************************** SUBROUTINE TYPE6(IS,K2,K3,IV2,IV3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE6 CHECK FOR TYPE 6 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 6 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE6(IS, K2, K3, IV2, IV3) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2,K3 - DECISION INDICES C IV2,IV3 - INDICATE VARIABLES WITH PROBLEM C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) WRITE(64,500) IS, ID(IS) 500 FORMAT('0TYPE6--IS:',I4,' ID:',I8) C IF(L2.GT.NLEV.OR.IGES.NE.0) RETURN IF(L2.EQ.NLEV) THEN CALL TYPE1(IS,K2) IF(K2.GT.2) IV2 = 1 IF(K2.EQ.1) THEN IV2 = 1 TTCOR(2) = 0. TTC(2) = TT(2) COINC(2,IV2) = OINC(L2,IV2,IS) + ZZCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + ZZCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) CHYRES(2) = HYRES(LH3,IS) - ZZCOR(2) RETURN ENDIF ENDIF C C PROVISIONAL CORRECTION = -(HYDROSTATIC RESIDUAL) C ZZCOR(2) = -HYS(1) C C FIND SIMPLE CORRECTION. C IF(L2.LE.4) THEN ZZCOR(2) = ANINT(ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ELSE ZZCOR(2) = 10.*ANINT(0.1*ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ENDIF CALL PBLOCK(1) C C NOTE! SUSPICION OF TYPE6 IS DEEMED SUFFICIENT C FOR MAGNITUDE CRITERION. C C LOOK FOR TYPE 6 PATTERN. C IV2 = 1 IF(OINCZ(2).LT.VMAX(1)) THEN OINC1 = OINCZ(2) + ZZCOR(2) ELSE OINC1 = VMSG(1) ENDIF IF(OINCZ(2).LT.VMAX(1).AND.OINCZ(1).LT.VMAX(1) & .AND.HYS(1).LT.VMAX(1)) THEN DINC1 = OINCZ(2) - OINCZ(1) + ZZCOR(2) ELSE DINC1 = VMSG(1) ENDIF IF(OINCZ(3).LT.VMAX(1).AND.OINCZ(2).LT.VMAX(1)) THEN DINC2 = OINCZ(3) - OINCZ(2) ELSE DINC2 = VMSG(1) ENDIF IF(HRESZ(2).LT.VMAX(1).AND.HRESZ(1).LT.VMAX(1) & .AND.HYS(1).LT.VMAX(1)) THEN DHOR1 = HRESZ(2) - HRESZ(1) + ZZCOR(2) ELSE DHOR1 = VMSG(1) ENDIF IF(HRESZ(3).LT.VMAX(1).AND.HRESZ(2).LT.VMAX(1)) THEN DHOR2 = HRESZ(3) - HRESZ(2) ELSE DHOR2 = VMSG(1) ENDIF IF(TRESZ(2).LT.VMAX(1).AND.TRESZ(1).LT.VMAX(1) & .AND.HYS(1).LT.VMAX(1)) THEN DTMP1 = TRESZ(2) - TRESZ(1) + ZZCOR(2) ELSE DTMP1 = VMSG(1) ENDIF IF(TRESZ(3).LT.VMAX(1).AND.TRESZ(2).LT.VMAX(2)) THEN DTMP2 = TRESZ(3) - TRESZ(2) ELSE DTMP2 = VMSG(1) ENDIF C C REQUIRE ALL TO BE SMALL. C WRITE(64,501) DINC1,DINC2,DHOR1,DHOR2,DTMP1,DTMP2 501 FORMAT(' DINC:',2F8.0,' DHOR:',2F8.0,' DTMP:',2F8.0) IF(IGES.EQ.0.AND. & (ABS(DINC1).GT.0.25*XINC(L2,1) & .OR.ABS(DINC2).GT.0.25*XINC(L2,1) & .OR.ABS(DHOR1).GT.0.25*XINC(L2,1) & .OR.ABS(DHOR2).GT.0.25*XINC(L2,1) & .OR.(DTMP1.LT.VMAX(1).AND.ABS(DTMP1).GT.0.25*XINC(L2,1)) & .OR.(DTMP2.LT.VMAX(1).AND.ABS(DTMP2).GT.0.25*XINC(L2,1))) & .OR.IGES.NE.0.AND. & (ABS(DTMP1).GT.0.25*XINC(L2,1) & .OR.ABS(DTMP2).GT.0.25*XINC(L2,1))) THEN IV2 = 1 K2 = 5 ZZCOR(2) = 0. RETURN ENDIF C C CHECK CORRECTION WITH TSTCOR. C FIRST, SET UP QUANTITIES AS NECESSARY. C ZZCOR(3) = ZZCOR(2) + ZZCOR(3) ZZCOR(4) = ZZCOR(2) + ZZCOR(4) ZZC(2) = ZZC(2) + ZZCOR(2) ZZC(3) = ZZC(3) + ZZCOR(2) ZZC(4) = ZZC(4) + ZZCOR(2) CALL TSTCOR(IV2,IS,0,IHSC1,IHSC2,IHSC3,IINC2,IINC3, & IHOI2,IHOI3,IVOI2,IVOI3,ITMPZ2,ITMPZ3) C C SEE IF CORRECTIONS ARE CONFIRMED. C ISUM = IINC2 + IHOI2 + IVOI2 + ITMPZ2 IF(ISUM.LT.2.AND.IHSC1.LT.2) THEN C C ACCEPT CORRECTIONS. C K2 = 1 IV2 = 1 IV3 = 1 K3 = 1 COINC(2,IV2) = OINC(L2,IV2,IS) + ZZCOR(2) CHRES(2,IV2) = HINC(L2,IV2,IS) + ZZCOR(2) CVRES(2,IV2) = VINC(L2,IV2,IS) + ZZCOR(2) CHYRES(1) = HYRES(L2,IS) + ZZCOR(2) CHYRES(2) = HYRES(LH3,IS) RETURN ELSE C C DONT ACCEPT CORRECTIONS. C K2 = 5 IV2 = 1 ZZCOR(3) = ZZCOR(3) - ZZCOR(2) ZZCOR(4) = ZZCOR(4) - ZZCOR(2) ZZCOR(2) = 0. ZZC(2) = ZZ(2) ZZC(3) = ZZ(3) ZZC(4) = ZZ(4) ENDIF RETURN END C***************************************************************** SUBROUTINE TYPE7(IS,K2,K3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE7 CHECK FOR TYPE 7 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 7 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE7(IS, KK, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2,K3 - DECISION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN IF(L2.EQ.99.OR.LZ3.EQ.99) RETURN IV = 1 C IF(IGES.NE.0) GO TO 5 IF(ABS(ZZCOR(2)).LT.4.*DTALL*BB(1)) THEN K2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. GOTO 14 ENDIF C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(IV,IS,0,IHSC1,IHSC2,IHSC3,IINC2,IINC3, & IHOI2,IHOI3,IVOI2,IVOI3,ITMPZ2,ITMPZ3) C C MAKE CORRECTION IF AT LEAST 2 TEST ARE AVAILABLE C AND THEIR RESIDUALS ARE SMALL. TEST LEVEL L2. C ISUM = IINC2 + IHOI2 + IVOI2 + ITMPZ2 IF(ISUM.LT.2.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 5 CONTINUE K2 = 1 ELSEIF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ELSEIF((ISUM.GE.4.OR.IHSC1.EQ.2.OR.IHSC2.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ELSE C C DATA MAY BE OK. DONT CORRECT. C 10 K2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ENDIF 14 CONTINUE C NOW TEST FOR CORRECTIONS AT LEVEL LZ3. C C IF(IGES.NE.0) GO TO 15 IF(ABS(ZZCOR(3)).LT.4.*DTALL*BB(2)) GO TO 20 ISUM = IINC3 + IHOI3 + IVOI3 + ITMPZ3 IF(ISUM.LT.2.AND.IHSC2.LT.2.AND.IHSC3.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 15 CONTINUE K3 = 1 RETURN ENDIF IF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC3.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K3 = 3 ZZC(3) = ZZ(3) ZZCOR(3) = 0. RETURN ENDIF IF((ISUM.GE.4.OR.IHSC2.EQ.2.OR.IHSC3.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K3 = 4 ZZC(3) = ZZ(3) ZZCOR(3) = 0. RETURN ENDIF C C DATA MAY BE OK. DONT CORRECT. C 20 K3 = 2 ZZC(3) = ZZ(3) ZZCOR(3) = 0. RETURN END C****************************************************************** SUBROUTINE TYPE8(IS,K2,K3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE8 CHECK FOR TYPE 8 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 8 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE8(IS, KK, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2,K3 - DECISION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C IF(L2.EQ.99.OR.LZ3.EQ.99) RETURN IV = 2 C IF(IGES.NE.0) GO TO 5 IF(ABS(TTCOR(2)).LT.TCMIN) THEN K2 = 2 TTC(2) = TT(2) TTCOR(2) = 0. GOTO 12 ENDIF C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(IV,IS,0,IHSC1,IHSC2,IHSC3,IINC2,IINC3, & IHOI2,IHOI3,IVOI2,IVOI3,ITMPT2,ITMPT3) C C MAKE CORRECTION IF AT LEAST 2 TESTS ARE AVAILABLE C AND THEIR RESIDUALS ARE SMALL. TEST LEVEL L2. C ISUM = IINC2 + IHOI2 + IVOI2 + ITMPT2 IF(ISUM.LT.2.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 5 CONTINUE K2 = 1 ELSEIF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K2 = 3 TTC(2) = TT(2) TTCOR(2) = 0. ELSEIF((ISUM.GE.4.OR.IHSC1.EQ.2.OR.IHSC2.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 TTC(2) = TT(2) TTCOR(2) = 0. ELSE C C DATA MAY BE OK. DONT CORRECT. C K2 = 2 TTC(2) = TT(2) TTCOR(2) = 0. ENDIF 12 CONTINUE C C NOW TEST FOR CORRECTIONS AT LEVEL LZ3. C C IF(IGES.NE.0) GOTO 15 IF(ABS(TTCOR(3)).LT.TCMIN) GO TO 20 ISUM = IINC3 + IHOI3 + IVOI3 + ITMPT3 IF(ISUM.LT.2.AND.IHSC2.LT.2.AND.IHSC3.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 15 CONTINUE K3 = 1 RETURN ENDIF IF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC3.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K3 = 3 TTC(3) = TT(3) TTCOR(3) = 0. RETURN ENDIF IF((ISUM.GE.4.OR.IHSC2.EQ.2.OR.IHSC3.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K3 = 4 TTC(3) = TT(3) TTCOR(3) = 0. RETURN ENDIF C C DATA MAY BE OK. DONT CORRECT. C 20 K3 = 2 TTC(3) = TT(3) TTCOR(3) = 0. RETURN END C******************************************************************* SUBROUTINE TYPE9(IS,K2,K3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPE9 CHECK FOR TYPE 9 ERROR. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR TYPE 9 HYDROSTATIC ERROR. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-11 W. COLLINS TEMPORAL CHECK ADDED C C USAGE: CALL TYPE9(IS, KK, IV2) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C K2,K3 - DECISION INDICES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN C IF(L2.EQ.99.OR.LZ3.EQ.99) RETURN C IF(IGES.NE.0) GO TO 5 C C MAKE CORRECTION IF AT LEAST 2 TEST ARE AVAILABLE C AND THEIR RESIDUALS ARE SMALL. TEST LEVEL L2. C IF(ABS(ZZCOR(2)).LT.4.*DTALL*BB(1)) THEN K2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. GOTO 12 ENDIF C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(1,IS,0,IHSC1,IHSC2,IHSC3,IINC2,IX1, & IHOI2,IX2,IVOI2,IX3,ITMPT2,ITMPT3) ISUM = IINC2 + IHOI2 + IVOI2 + ITMPT2 IF(ISUM.LT.2.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 5 CONTINUE K2 = 1 ELSEIF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC2.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K2 = 3 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ELSEIF((ISUM.GE.4.OR.IHSC1.EQ.2.OR.IHSC2.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K2 = 4 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ELSE C C DATA MAY BE OK. DONT CORRECT. C 10 K2 = 2 ZZC(2) = ZZ(2) ZZCOR(2) = 0. ENDIF 12 CONTINUE C C NOW TEST FOR CORRECTIONS AT LEVEL LZ3. C C IF(IGES.NE.0) GO TO 15 IF(ABS(TTCOR(3)).LT.TCMIN) GO TO 20 C C RECOMPUTE INCREMENT/RESIDUALS. C CALL TSTCOR(2,IS,0,IHSC1,IHSC2,IHSC3,IX1,IINC3, & IX2,IHOI3,IX3,IVOI3,ITMPZ2,ITMPZ3) ISUM = IINC3 + IHOI3 + IVOI3 + ITMPZ3 IF(ISUM.LT.2.AND.IHSC2.LT.2.AND.IHSC3.LT.2) THEN C C MAKE CORRECTION (PUT CORRECTIONS IN LIST TO BE MADE.) C C 15 CONTINUE K3 = 1 RETURN ENDIF IF(ISUM.LT.4.AND.IHSC1.LT.2.AND.IHSC3.LT.2) THEN C C FLAG DATA AS DOUBTFUL. C K3 = 3 TTC(3) = TT(3) TTCOR(3) = 0. RETURN ENDIF IF((ISUM.GE.4.OR.IHSC2.EQ.2.OR.IHSC3.EQ.2) & .AND.ISCAN.GT.1) THEN C C MARK DATA AS DEFINITELY BAD. C K3 = 4 TTC(3) = TT(3) TTCOR(3) = 0. RETURN ENDIF C C DATA MAY BE OK. DONT CORRECT. C 20 K3 = 2 TTC(3) = TT(3) TTCOR(3) = 0. RETURN END C*************************************************************** SUBROUTINE TYPEB(IS,KK,IV2,IV3,IHSC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TYPEB CONSIDER BASELINE ERRORS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CHECK FOR CORRECTABLE BASELINE ERRORS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-05-07 W. COLLINS IMPROVEMENTS TO CORRECTIONS C ADDITION OF TYPE 102 C C USAGE: CALL TYPEB(IS, KK, IV2, IV3, IHSC) C INPUT ARGUMENT LIST: C IS - STATION INDEX C C OUTPUT ARGUMENT LIST: C KK - DECISION INDICES C IV2,IV3 - INDICATE VARIABLES WITH PROBLEM C IHSC - HYDROSTATIC ERROR CODE C = 100, PS COMMUNICATION ERROR C = 101, ERROR TO LOWEST HEIGHT C = 106, PS MEASUREMENT ERROR C = 116, Z1 COMPUTATION ERROR C C OUTPUT FILES: C FT64F001 - PRINT FILE, DETAILED DIAGNOSTICS C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ INTEGER KK(3,3) COMMON /CONSTS/ R, G, T0, A(20), B(20), SS(20) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) C-CRA COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), C-CRA. IDH(4,21,2,899), WTH(4,21,2,899), C-CRA. HINCPS(899), IDHPS(4,899), WTHPS(4,899) COMMON /HCK /HINC(21,2,899), HSTD(21,2,899), . WTH(4,21,2,899),HINCPS(899), WTHPS(4,899) COMMON /HCKI/IDH(4,21,2,899),IDHPS(4,899) C-CRA COMMON /HYCK/ HYRES(21,899), SBIG(21,899), BSUM(20,899), C-CRA& ISL(21,899), ISU(21,899), KMAX(899), BRES(899), LEV2(899), C-CRA& PSCOR(899),LEV1(899),Z1COR(899),Z2COR(899), REDUC(899) COMMON /HYCK / HYRES(21,899), SBIG(21,899), BSUM(20,899), & BRES(899),PSCOR(899),Z1COR(899),Z2COR(899), & REDUC(899) COMMON /HYCKI/ ISL(21,899), ISU(21,899), KMAX(899), LEV2(899), & LEV1(899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) COMMON /MSGS/ VMAX(2),VMSG(2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /LIMSC/ ZCLIM1, ZCLIM2, TCLIM, ZCMIN, TCMIN COMMON /ALL/ ALLZ(5), ALLZL(31), ALLT(51) C-CRA COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), C-CRA& ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), C-CRA& OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, C-CRA& DHZ3, DOT2, DOT3, DHT2, DHT3, ICZ1, IC2, ICZ3, C-CRA& ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, C-CRA& ZH(4),TH(4),HYS(3),BB(3),LH1,LH3,LH4,ICH1,ICH2,ICH3, C-CRA& PSC,PSCORR,LBZ,LBT,LBB,IBSL,TRESZ(4),TREST(4),DTZ2,DTZ3, C-CRA& DTT2,DTT3 COMMON/CDMA/ ZZ(4), TT(4), TTCOR(4), ZZCOR(4), & ZZC(4), TTC(4), OINCZ(4), HRESZ(4), VRESZ(4), & OINCT(4), HREST(4), VREST(4), DOZ2, DOZ3, DHZ2, & DHZ3, DOT2, DOT3, DHT2, DHT3, & ZH(4),TH(4),HYS(3),BB(3), & PSC,PSCORR,TRESZ(4),TREST(4),DTZ2,DTZ3, & DTT2,DTT3 COMMON /CDMAI/ ICZ1, IC2, ICZ3, & ICZ4, ICT1, ICT3, ICT4,LZ1,L2,LZ3,LZ4,LT1,LT3,LT4, & LH1,LH3,LH4,ICH1,ICH2,ICH3, & LBZ,LBT,LBB,IBSL C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) IF(IGES.NE.0) RETURN C C CHECK FOR CORRECTABLE BASELINE ERRORS. C CALL UNPACK(NERR(L2,1,IS,ISCAN),IHSC,IINC,IHOI, & IVOI,IBAS,IIPL,IHPL) ITPS = NERTPS(IS,ISCAN) LB1 = LBZ LB2 = LH3 IF(LB1.GT.NLEV.OR.LB2.GT.NLEV) RETURN C************************** C C CALCULATE RELEVANT QUANTITIES... C IF(HYS(2).GT.VMAX(1)) THEN IHYS2 = 0 ELSE IHYS2 = 2.*ABS(HYS(2)) / HSCRES(LB1) IHYS2 = MIN(IHYS2,2) ENDIF IF(HYS(3).GT.VMAX(1)) THEN IHYS3 = 0 ELSE IHYS3 = 2.*ABS(HYS(3)) / HSCRES(LB2) IHYS3 = MIN(IHYS3,2) ENDIF IF(DOZ2.GT.VMAX(1)) THEN IZ1D = 0 ELSE IZ1D = 11.*ABS(DOZ2) / XINC(LB1,1) IZ1D = MIN(IZ1D,2) ENDIF IF(PSCOR(IS).GT.VMAX(1)) THEN IPSC = 0 ELSE IPSC = 2.*ABS(PSCOR(IS)) / PSRES IPSC = MIN(IPSC,2) ENDIF IF(OINC(LB1,1,IS).GT.VMAX(1)) THEN IZ1I = 0 ELSE IZ1I = 5.*ABS(OINC(LB1,1,IS)) / XINC(LB1,1) IZ1I = MIN(IZ1I,2) ENDIF IF(OINC(LB1,1,IS).GT.VMAX(1) & .OR.OINC(LB2,1,IS).GT.VMAX(1)) THEN IDZ1I = 0 ELSE IDZ1I = 11.*ABS(OINC(LB1,1,IS) - OINC(LB2,1,IS)) & / (XINC(LB1,1)+XINC(LB2,1)) IDZ1I = MIN(IDZ1I,2) ENDIF IF(DOZ2.GT.VMAX(1).OR.BRES(IS).GT.VMAX(1)) THEN RZ1D = 0. ELSEIF(BRES(IS).NE.0.) THEN RZ1D = ABS(DOZ2 / BRES(IS)) ELSE RZ1D = 0. ENDIF IF(OINCPS(IS).GT.VMAX(2).OR.PSCOR(IS).GT.VMAX(1)) THEN IIDPL = 0 ELSE IIDPL = 2.*ABS((OINCPS(IS) + PSCOR(IS)) / PSRES) IIDPL = MIN(IIDPL,2) ENDIF IF(HINCPS(IS).GT.VMAX(2).OR.PSCOR(IS).GT.VMAX(1)) THEN IDHPL = 0 ELSE IDHPL = 2.*ABS((HINCPS(IS) + PSCOR(IS)) / PSRES) IDHPL = MIN(IIDPL,2) ENDIF IF(OINC(LB1,1,IS).GT.VMAX(1) & .OR.BRES(IS).GT.VMAX(1)) THEN IEZ1I = 0 ELSE IEZ1I = 4.*ABS(OINC(LB1,1,IS) + BRES(IS)) & / (XINC(LB1,1)+XINC(LB2,1)) IEZ1I = MIN(IEZ1I,2) ENDIF IF(Z1COR(IS).GT.VMAX(1).OR.DOZ2.GT.VMAX(1)) THEN IEZ1C = 0 ELSE IEZ1C = 11.*ABS(Z1COR(IS)+DOZ2) / XINC(LB1,1) IEZ1C = MIN(IEZ1C,2) ENDIF IF(Z1COR(IS).NE.DOZ2) THEN RATIO = ABS((Z1COR(IS)+DOZ2)/(Z1COR(IS)-DOZ2)) ELSE RATIO = 0. ENDIF FNZ = 1.2E-4*SELV(IS) + .02 FNZ = AMAX1(FNZ,.08) C C PRINT THOSE OF THESE QUANTITIES THAT ARE USED. C IF(IBAS.EQ.2.OR.IIPL.EQ.2.OR.IHPL.EQ.2.OR.ITPS.EQ.2 & .OR.IZ1I.EQ.2) THEN WRITE(64,500) IS,ID(IS),L2,IBAS,IIPL,IHPL, & ITPS,IHYS2,IHYS3,RATIO 500 FORMAT('0TYPEB--IS:',I5,' ID:',I8,' L2:',I5, & ' IBAS:',I3,' IIPL:',I3,' IHPL:',I3, & ' ITPS:',I3,' IHYS2:',I3,' IHYS3:',I3,' RATIO:',F7.2) WRITE(64,501) IIDPL, IDHPL, IPSC, IZ1I, IDZ1I, IEZ1I, & IZ1D, RZ1D, IEZ1C 501 FORMAT(' IIDPL:',I4,' IDHPL:',I4,' IPSC:',I4,' IZ1I:', & I4,' IDZ1I:',I4,' IEZ1I:',I4,' IZ1D:',I4,' RZ1D:', & F8.2,' IEZ1C:',I4) ENDIF C************************** C C PERFORM TEST FOR VARIOUS POSSIBLE ERROR TYPES. C IF(IBAS.EQ.0) THEN C C TEST FOR PS MEASUREMENT ERROR. (COULD BE 1ST GUESS ERROR.) C TYPE 106 C IP = 0 PSCR = 0. IF(OINCPS(IS).LT.VMAX(2)) THEN IP = IP + 1 PSCR = PSCR - OINCPS(IS) ENDIF IF(HINCPS(IS).LT.VMAX(2)) THEN IP = IP + 1 PSCR = PSCR - HINCPS(IS) ENDIF IF(IP.GT.0) THEN PSCORR = PSCR / IP ELSE PSCORR = 0. ENDIF IF(((ABS(OINCPS(IS)).GT.PSRES.AND.OINCPS(IS).LT.VMAX(2)) .OR. & ( ABS(TPSRES(IS)).GT.PSRES.AND.TPSRES(IS).LT.VMAX(1)) .OR. & ( ABS(HINCPS(IS)).GT.PSRES.AND.HINCPS(IS).LT.VMAX(2))) & .AND. IZ1I.EQ.2 .AND. IZ1D.LT.2 .AND. IDZ1I.LT.2 & .AND. IHSC.EQ.0. AND. IPSC.LT.1 .AND. IHYS2.LT.2 & .AND. ABS(OINC(L2,1,IS)+8.*PSCORR).LT.6.*ZCMIN & .AND. IHYS3.LT.2 .AND. PS(IS).GT.0.) THEN PSCORR = 0. IF(ABS(PS(IS)).GT.VMAX(1) & .OR.ABS(TT(2)).GT.VMAX(2)) THEN C ZZCOR(2) = 8. * PSCORR ZZCOR(2) = 0. ELSE C ZZCOR(2) = (R/G)*(TT(2)+T0)*ALOG((PS(IS)+PSCORR) C & / PS(IS)) ZZCOR(2) = 0. ENDIF IV2 = 5 IV3 = 1 KK(2,1) = 1 KK(2,3) = 1 IHSC = 106 WRITE(64,500) IS,ID(IS),L2,IBAS,IIPL,IHPL,ITPS, & IHYS2,IHYS3,RATIO WRITE(64,501) IIDPL, IDHPL, IPSC, IZ1I, IDZ1I, IEZ1I, & IZ1D, RZ1D, IEZ1C WRITE(64,502) IHSC, PSCORR, ZZCOR(2) 502 FORMAT(' IHSC:',I3,' PSCORR:',F9.2,' ZZCOR(2):',F8.1) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) RETURN ELSE GO TO 70 ENDIF 70 CONTINUE ELSEIF(IBAS.EQ.2) THEN C************************** C C LARGE BASELINE RESIDUAL-- C TEST FOR PS COMMUNICATION ERROR. C TYPE 100 C IF((( OINCPS(IS).LT.VMAX(2).AND.ABS(OINCPS(IS)).GT.6.) & .OR.(TPSRES(IS).LT.VMAX(1).AND.ABS(TPSRES(IS)).GT.6.) & .OR.(HINCPS(IS).LT.VMAX(2).AND.ABS(HINCPS(IS)).GT.6.)) & .AND.IIDPL.LT.2 .AND. IDHPL.LT.2 .AND. RZ1D.LT.0.4) THEN IP = 0 PSCR = 0. IF(OINCPS(IS).LT.VMAX(2)) THEN IP = IP + 1 PSCR = PSCR - OINCPS(IS) ENDIF IF(HINCPS(IS).LT.VMAX(2)) THEN IP = IP + 1 PSCR = PSCR - HINCPS(IS) ENDIF IF(PSCOR(IS).LT.VMAX(1)) THEN IP = IP + 1 PSCR = PSCR + PSCOR(IS) ENDIF IF(TPSRES(IS).LT.VMAX(1)) THEN IP = IP + 1 PSCR = PSCR + TPSRES(IS) ENDIF IF(IP.GT.0) THEN PSCORR = PSCR / IP ELSE PSCORR = 0. GO TO 80 ENDIF IV2 = 4 IV3 = 0 KK(2,3) = 1 IHSC = 100 WRITE(64,503) IHSC, PSCORR 503 FORMAT(' IHSC:',I3,' PSCORR:',F9.2) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) RETURN C************************** C C TEST FOR ERROR TO LOWEST HEIGHT. C TYPE 101 C 80 CONTINUE ELSEIF(RATIO.LT.FNZ .AND. IHSC.EQ.0 & .AND. TT(2).GT.VMAX(2) .AND. IZ1I.EQ.2) THEN IP = 0 ZZCR = 0. IF(ABS(DOZ2).LT.VMAX(1)) THEN IP = IP + 1 ZZCR = ZZCR - DOZ2 ENDIF IF(ABS(Z1COR(IS)).LT.VMAX(1)) THEN IP = IP + 1 ZZCR = ZZCR + Z1COR(IS) ENDIF IF(IP.GT.0) THEN ZZCOR(2) = ZZCR / IP C C FIND SIMPLE CORRECTION. C IF(L2.LE.4) THEN ZZCOR(2) = ANINT(ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZL,NZL) ELSE ZZCOR(2) = 10.*ANINT(0.1*ZZCOR(2)) CALL SIMPLE(ZZCOR(2),ZZ(2),ALLZ,NZ) ENDIF ELSE ZZCOR(2) = 0. GO TO 90 ENDIF IV2 = 1 IV3 = 0 KK(2,1) = 1 IHSC = 101 WRITE(64,504) IHSC, ZZCOR(2) 504 FORMAT(' IHSC:',I3,' ZZCOR(2):',F8.1) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) RETURN C************************** C C TEST FOR Z1 COMPUTATION ERROR C TYPE 116 C 90 CONTINUE ELSEIF( IIPL.EQ.0 .AND. IHPL.EQ.0 .AND. ITPS.EQ.0 & .AND. IHSC.EQ.0 .AND. IDZ1I.EQ.0 .AND. IEZ1I.EQ.0 & .AND.IZ1I.EQ.2) THEN IP = 0 ZZCOR(2) = BRES(IS) IV2 = 1 IV3 = 1 KK(2,1) = 1 IHSC = 116 WRITE(64,504) IHSC, ZZCOR(2) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) RETURN ENDIF ENDIF C************************** C C TEST FOR OTHER ERRORS LEADING TO LARGE BASELINE C RESIDUAL OR OTHER INCREMENTS. C TYPE 102 C 100 CONTINUE PSCORR = 0. IF(IBAS.EQ.2.AND.IHSC.EQ.0) THEN IV2 = 1 IV3 = 0 KK(2,1) = 5 KK(2,3) = 5 IHSC = 102 WRITE(64,502) IHSC, PSCORR, ZZCOR(2) WRITE(64,505) IS,IBAS,ITPS,IHSC,OINCPS(IS),HINCPS(IS), & PSRES,VMAX(1),VMAX(2) 505 FORMAT(' TYPEB--IS:',I5,' IBAS:',I5,' ITPS:',I5,' IHSC:',I5, & ' OINCPS(IS): ',E12.5,' HINCPS(IS): ',E12.5,' PSRES:', & F8.1,' VMAX: ',2F8.1) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) ELSEIF(((ABS(OINCPS(IS)).GT.1.5*PSRES.AND.OINCPS(IS).LT.VMAX(2)) & .OR.(ABS(HINCPS(IS)).GT.1.5*PSRES.AND.HINCPS(IS).LT.VMAX(2)) & .OR.ITPS.EQ.2) & .AND.IHSC.EQ.0) THEN IV2 = 4 IV3 = 0 KK(2,1) = 5 KK(2,3) = 5 IHSC = 102 WRITE(64,502) IHSC, PSCORR, ZZCOR(2) WRITE(64,505) IS,IBAS,ITPS,IHSC,OINCPS(IS),HINCPS(IS), & PSRES,VMAX(1),VMAX(2) CALL PACK(NERR(L2,1,IS,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) ENDIF RETURN END C**************************************************************** SUBROUTINE UNPACK(IPACK,IHSC,IINC,IHOI,IVOI,IBAS,IIPL,IHPL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPACK INPACK ERROR VALUE. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: UNPACK ERROR VALUE INTO ITS PARTS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C 92-01-31 W. COLLINS CHANGE TO ARGUMENT ORDER, FUNCTION. C C USAGE: CALL UNPACK(IPACK, IHSC, IINC, IHOI, IVOI, IBAS, IIPL, IHPL) C INPUT ARGUMENT LIST: C IPACK - PACKED ERROR C C OUTPUT ARGUMENT LIST: C IHSC - HYDROSTATIC ERROR TYPE C IINC - INCREMENT CODE C IHOI - HORIZONTAL RESIDUAL CODE C IVOI - VERTICAL RESIDUAL CODE C IBAS - BASELINE RESIDUAL CODE C IIPL - PS INCREMENT CODE C IHPL - MSL PRESSURE RESIDUAL CODE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C UNPACK ERROR FLAGS FROM IPACK INTO IHSC,... C IP = IPACK IF(IP.NE.0) THEN IHPL = MOD(IP,10) IP = (IP-IHPL)/10 ELSE GO TO 1 ENDIF IF(IP.NE.0) THEN IIPL = MOD(IP,10) IP = (IP-IIPL)/10 ELSE GO TO 2 ENDIF IF(IP.NE.0) THEN IBAS = MOD(IP,10) IP = (IP-IBAS)/10 ELSE GO TO 3 ENDIF IF(IP.NE.0) THEN IVOI = MOD(IP,10) IP = (IP-IVOI)/10 ELSE GO TO 4 ENDIF IF(IP.NE.0) THEN IHOI = MOD(IP,10) IP = (IP-IHOI)/10 ELSE GO TO 5 ENDIF IF(IP.NE.0) THEN IINC = MOD(IP,10) IP = (IP-IINC)/10 ELSE GO TO 6 ENDIF IF(IP.NE.0) THEN IHSC = IP ELSE GO TO 7 ENDIF RETURN 1 IHPL = 0 2 IIPL = 0 3 IBAS = 0 4 IVOI = 0 5 IHOI = 0 6 IINC = 0 7 IHSC = 0 RETURN END C**************************************************************** SUBROUTINE UNPCK2(IPACK,IV,L,IS,ID) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: UNPACK INPACK ERROR VALUE. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: UNPACK ERROR VALUE INTO ITS PARTS. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL UNPCK2(IPACK, IV, L, IS, ID) C INPUT ARGUMENT LIST: C IPACK - PACKED ERROR C C OUTPUT ARGUMENT LIST: C IV - VARIABLE (1-Z, 2-T, 4-P) C L - LEVEL C IS - SCAN NO. C ID - DECISION C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C UNPACK ERROR FLAGS FROM IPACK INTO IINC,... C IP = IPACK IF(IP.NE.0) THEN ID = MOD(IP,100) IP = (IP-ID)/100 ELSE GO TO 1 ENDIF IF(IP.NE.0) THEN IS = MOD(IP,100) IP = (IP-IS)/100 ELSE GO TO 2 ENDIF IF(IP.NE.0) THEN L = MOD(IP,100) IP = (IP-L)/100 ELSE GO TO 3 ENDIF IF(IP.NE.0) THEN IV = MOD(IP,100) ELSE GO TO 4 ENDIF RETURN 1 ID = 0 2 IS = 0 3 L = 0 4 IV = 0 RETURN END C**************************************************************** SUBROUTINE VDIF(DIF, V1, V2, V3, L1, L2, L3, VMAX, VMSG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VDIF CALCULATE DIFFERENCE FROM NEIGHBORS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: CALCULATE DIFFERENCE BETWEEN VALUE AND NON-MISSING C NEIGHBORS. ALSO TAKE INTO ACCOUNT THE FACT THAT THE C VALUE ITSELF MAY BE MISSING. C DO NOT USE NEIGHBORS THAT ARE MORE THAN TWO LEVELS AWAY. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL VDIF(DIF, V1, V2, V3, L1, L2, L3, VMAX, VMSG) C INPUT ARGUMENT LIST: C V1 - VARIABLE AT LEVEL BELOW C V2 - VARIABLE AT LEVEL C V3 - VARIABLE AT LEVEL ABOVE C L1,L2,L3 - LEVEL INDICES, BELOW, AT, ABOVE C VMAX - MAXIMUM VALUE OF V USED C VMSG - MISSING VALUE C C OUTPUT ARGUMENT LIST: C DIF - DIFFERENCE C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ NV1 = 0 NV2 = 0 NV3 = 0 IF(ABS(V1).LT.VMAX.AND.(L2-L1).LE.2) NV1 = 1 IF(ABS(V2).LT.VMAX) NV2 = 1 IF(ABS(V3).LT.VMAX.AND.(L3-L2).LE.2) NV3 = 1 IF(NV1.EQ.1.AND.NV2.EQ.1.AND.NV3.EQ.1) THEN DIF = V2 - 0.5*(V1+V3) ELSEIF(NV1.EQ.1.AND.NV2.EQ.1) THEN DIF = V2 - V1 ELSEIF(NV2.EQ.1.AND.NV3.EQ.1) THEN DIF = V2 - V3 ELSEIF(NV2.EQ.1) THEN DIF = V2 ELSE DIF = VMSG ENDIF IF(DIF.EQ.0.) DIF = .0001 RETURN END C*************************************************************** SUBROUTINE VERTCK(IA,IV) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VERTCK PERFORM VERTICAL STATISTICAL CHECK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM VERTICAL STATISTICAL CHECK. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL VERTCK(IA, IV) C INPUT ARGUMENT LIST: C IA - STATION INDEX C IV - VARIABLE INDEX C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PERFORM VERTICAL STATISTICAL CHECK OF DATA. C RETURN ANALYSIS INCREMENT IN VINC. C REAL VDEV(21), CC(2) INTEGER IDEV(21) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,899), IR, C-CRA& NERT(21,2,899,2), DHOUR(899), NERTPS(899,2) COMMON /ERROR/ DHOUR(899) COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,899), IR, & NERT(21,2,899,2), NERTPS(899,2) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /MSGS/ VMAX(2),VMSG(2) DATA GAMA /0.5/, POW /1.2/ C C NEW CORRELATION FORM C DATA CC /1.1,8./ COR(P1,P2,CCC) = 1./(1.+CCC*(ABS(ALOG(P1/P2)))**POW) PGAM = 1. + GAMA PGAMS = PGAM**2 C C INITIALIZE ARRAY VALUES. C DO 5 L=1,NPLVL VDEV(L) = 0. VINC(L,IV,IA) = VMSG(IV) WTV(1,L,IV,IA) = 0. WTV(2,L,IV,IA) = 0. 5 CONTINUE IF(IGES.NE.0) GO TO 25 C C PUT NON-MISSING DEVIATIONS INTO LOCAL ARRAY. C II = 0 DO 10 I=1,NPLVL IF(OINC(I,IV,IA).LT.VMAX(IV)) THEN II = II + 1 VDEV(II) = OINC(I,IV,IA) IDEV(II) = I ENDIF 10 CONTINUE LEVS = II LEVSM = LEVS - 1 IF(LEVS.LT.2) RETURN CCC = CC(IV) C C SOLVE FOR RESIDUALS. BOTTOM FIRST. C IF(ABS(VDEV(2)).LT.VMAX(IV)) THEN PR1 = IPLVL(IDEV(1)) PR2 = IPLVL(IDEV(2)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(1) VINC(ID,IV,IA) = -H1*VDEV(2) + OINC(ID,IV,IA) WTV(2,ID,IV,IA) = H1 ENDIF C C NOW TOP. C IF(ABS(VDEV(LEVS-1)).LT.VMAX(IV)) THEN PR1 = IPLVL(IDEV(LEVS)) PR2 = IPLVL(IDEV(LEVS-1)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(LEVS) VINC(ID,IV,IA) = -H1*VDEV(LEVS-1) + OINC(ID,IV,IA) WTV(1,ID,IV,IA) = H1 ENDIF IF(LEVS.LT.3) RETURN C C NOW OTHER LEVELS. C DO 20 I=2,LEVSM IADJ = 0 IDEVM = IDEV(I-1) IDEV0 = IDEV(I) IDEVP = IDEV(I+1) IF(IDEV0-IDEVM.LE.2) IADJ = IADJ + 1 IF(IDEVP-IDEV0.LE.2) IADJ = IADJ + 2 IF(IADJ.EQ.0) THEN C C NO CLOSE DATA. C GO TO 20 ELSEIF((IADJ.EQ.1.AND.ABS(VDEV(I-1)).LT.VMAX(IV)) & .OR.(IADJ.EQ.3.AND.ABS(VDEV(I+1)).GE.VMAX(IV))) THEN C C ONLY CLOSE NON-LARGE DATA BELOW. C PR1 = IPLVL(IDEV(I)) PR2 = IPLVL(IDEV(I-1)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(I) VINC(ID,IV,IA) = -H1 * VDEV(I-1) + OINC(ID,IV,IA) WTV(1,ID,IV,IA) = H1 ELSEIF((IADJ.EQ.2.AND.ABS(VDEV(I+1)).LT.VMAX(IV)) & .OR.(IADJ.EQ.3.AND.ABS(VDEV(I-1)).GE.VMAX(IV))) THEN C C ONLY CLOSE NON-LARGE DATA ABOVE. C PR1 = IPLVL(IDEV(I)) PR2 = IPLVL(IDEV(I+1)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(I) VINC(ID,IV,IA) = -H1 * VDEV(I+1) + OINC(ID,IV,IA) WTV(2,ID,IV,IA) = H1 ELSEIF(IADJ.EQ.3 & .AND.ABS(VDEV(I-1)).LT.VMAX(IV) & .AND.ABS(VDEV(I+1)).LT.VMAX(IV)) THEN PR0 = IPLVL(IDEV(I)) PR1 = IPLVL(IDEV(I-1)) PR2 = IPLVL(IDEV(I+1)) C01 = COR(PR0,PR1,CCC) C02 = COR(PR0,PR2,CCC) C12 = COR(PR1,PR2,CCC) H1 = (PGAM*C01 - C02*C12) / (PGAMS - C12**2) H2 = (PGAM*C02 - C01*C12) / (PGAMS - C12**2) ID = IDEV(I) VINC(ID,IV,IA) = -H1*VDEV(I-1) - H2*VDEV(I+1) & + OINC(ID,IV,IA) WTV(1,ID,IV,IA) = H1 WTV(2,ID,IV,IA) = H2 ENDIF 20 CONTINUE C C VERTICAL CHECK FLAGS. C 25 CONTINUE DO 30 L=1,NPLVL CALL UNPACK(NERR(L,IV,IA,ISCAN),IHSC,IINC,IHOI, & IVOI,IBAS,IIPL,IHPL) IF(ABS(VINC(L,IV,IA)).GT.VMAX(IV)) THEN IVOI = 0 ELSE IVOI = 2.0 * ABS(VINC(L,IV,IA))/VOIRES(L,IV) ENDIF IVOI = MIN(IVOI,2) CALL PACK(NERR(L,IV,IA,ISCAN),IINC,IHSC,IHOI, & IVOI,IBAS,IIPL,IHPL) 30 CONTINUE RETURN END C*************************************************************** SUBROUTINE VOI C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VOI PERFORM VERTICAL STATISTICAL CHECK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM VERTICAL STATISTICAL CHECK. C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL VOI C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PERFORM VERTICAL CHECK. C C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DO 20 IV=1,2 DO 10 N=1,NOBS CALL VERTCK(N,IV) 10 CONTINUE 20 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VRES CALCULATE VERTICAL INTERPOLATION RESIDUALS C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 93-12-01 C C ABSTRACT: CALCULATE VERTICAL RESIDUALS FROM FULL VALUES. C USE CLOSEST NEIGHBORS FOR VA AND CLOSEST MANDATORY C LEVEL NEIGHBORS FOR VM. C C PROGRAM HISTORY LOG: C 93-12-01 W. COLLINS C C USAGE: CALL VRES(PC,XPC,TC,ZC, C INDX,ITYP,MC,MB,MA,NB,NA,VM,VA) C C INPUT ARGUMENT LIST: C PC - COMBINED PRESSURES (HPA) C XPC - NATURAL LOGARITHM OF COLLECTED PRESSURES (NON-DIMEN) C ZC - COMBINED HEIGHTS (M) C TC - COMBINED TEMPERATURES (C) C MC - NUMBER OF COMBINED LEVELS C INDX - INDEX IN ORIGINAL ARRAYS FROM WHICH DATA COME C ITYP - TYPE OF DATA C = 0 SIGNIFICANT LEVEL DATA C = 1 SURFACE DATA C = 2 MANDATORY LEVEL DATA WITH Z, T NON-MISSING C = 3 MANDATORY LEVEL DATA WITH ONLY T NON-MISSING C = 4 MANDATORY LEVEL DATA WITH ONLY Z NON-MISSING C = 5 MANDATORY LEVEL DATA WITH Z, T MISSING C MB - NEXT LEVEL WITH ITYP = 2 OR 3 BELOW (MAND WITH T) C MA - NEXT LEVEL WITH ITYP = 2 OR 3 ABOVE (MAND WITH T) C NB - NEXT LEVEL WITH ITYP < 4 BELOW (EITHER WITH T) C NA - NEXT LEVEL WITH ITYP < 4 ABOVE (EITHER WITH T) C C OUTPUT ARGUMENT LIST: C VM - VERTICAL RESIDUALS USING MANDATORY LEVEL C TEMPERATURES C VA - VERTICAL RESIDUALS USING MANDATORY LEVEL C AND SIGNIFICANT LEVEL TEMPERATURES C C ATTRIBUTES: C LANGUAGE: VS FORTRAN, VERSION 2 C MACHINE: , CRAY, CRAY C C$$$ SUBROUTINE VRES(PC,XPC,TC,ZC,INDX,ITYP,MC,MB,MA,NB,NA,VMC,VAC) REAL PC(*), TC(*), ZC(*), XPC(*), VMC(*), VAC(*) INTEGER INDX(*), ITYP(*), MC, MA(*), MB(*), & NA(*), NB(*) LOGICAL ISOKMAND, ISOKSIG COMMON /MSGS/ VMAX(2),VMSG(2) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DATA DIFMAXXPC /.55/, DIFMAXPC /10./ C WRITE(6,500) 500 FORMAT(' VRES--CALLED') DO I=1,MC VMC(I) = VMSG(2) VAC(I) = VMSG(2) ENDDO DO I=1,MC K = INDX(I) IF(ITYP(I).EQ.0) THEN I1 = MB(I) I2 = MA(I) I3 = NB(I) I4 = NA(I) ISOKMAND = .TRUE. ISOKSIG = .TRUE. IF(I1.NE.0 .AND. I2.NE.0 .AND. I1.NE.I2) THEN IF((XPC(I1)-XPC(I2)).GT.DIFMAXXPC .AND. & PC(I1)-PC(I2).GT.DIFMAXPC) ISOKMAND = .FALSE. IF(XPC(I1).EQ.XPC(I2)) ISOKMAND = .FALSE. IF(XPC(I1).EQ.0. .OR. XPC(I2).EQ.0.) ISOKMAND = .FALSE. IF(ISOKMAND) THEN W1 = (XPC(I) - XPC(I1))/(XPC(I2) - XPC(I1)) W2 = 1.-W1 VMC(I) = TC(I) - W1*TC(I2) - W2*TC(I1) ENDIF ENDIF IF(I3.NE.0 .AND. I4.NE.0 .AND. I3.NE.I4) THEN IF(XPC(I3)-XPC(I4).GT.DIFMAXXPC .AND. & PC(I3)-PC(I4).GT.DIFMAXPC) ISOKSIG = .FALSE. IF(XPC(I3).EQ.XPC(I4)) ISOKSIG = .FALSE. IF(XPC(I3).EQ.0. .OR. XPC(I4).EQ.0.) ISOKSIG = .FALSE. IF(ISOKSIG) THEN W3 = (XPC(I) - XPC(I3))/(XPC(I4) - XPC(I3)) W4 = 1.-W3 VAC(I) = TC(I) - W3*TC(I4) - W4*TC(I3) ENDIF ENDIF ENDIF ENDDO RETURN END C***************************************************************** SUBROUTINE VRTCK1(IV, L) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VRTCK1 PERFORM PARTIAL VERTICAL CHECK. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 91-07-23 C C ABSTRACT: PERFORM VERTICAL STATISTICAL CHECK AT L(2), L(3). C C PROGRAM HISTORY LOG: C 91-07-23 W. COLLINS C C USAGE: CALL VRTCK1(IV, L) C INPUT ARGUMENT LIST: C IV - VARIABLE INDEX C L - LEVEL INDEX C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: , CRAY C C$$$ C C PERFORM VERTICAL STATISTICAL CHECK OF DATA AT LEVELS L(2),L(3). C RETURN ANALYSIS RESIDUAL IN CVRES. C INTEGER IDEV(4), L(4) REAL VDEV(4), CC(2) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) COMMON /VCK/ VINC(21,2,899), WTV(2,21,2,899) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /LEVEL / IPLVL(21), PMAND(21), PLOG(21) COMMON /LEVEL / PMAND(21), PLOG(21) COMMON /LEVELI/ IPLVL(21) COMMON /LIMS/ HSCRES(99), XINC(21,2), HOIRES(21,2), & VOIRES(21,2),BASRES,PSRES,TMPSTD(21,2),TFACT(21,2) COMMON /TCOR/ COINC(4,2), CHRES(4,5), CVRES(2,5), & CBRES, CHYRES(3), CDO2(2), CDO3(2), CDH2(2), & CDH3(2), CZSC, CPSC, CZ2C, CZ1C, CBSUM(3), & CTRES(4,5), CDT2(2), CDT3(2) COMMON /MSGS/ VMAX(2),VMSG(2) DATA GAMA /0.5/ C C NEW CORRELATION FORM C DATA CC /1.1,8./ COR(P1,P2,CCC) = 1./(1.+CCC*(ABS(ALOG(P1/P2)))**POW) POW = 1.2 PGAM = 1. + GAMA PGAMS = PGAM**2 C C INITIALIZE VALUES. C CVRES(1,IV) = VMSG(IV) CVRES(2,IV) = VMSG(IV) DO 5 LEV=1,4 VDEV(LEV) = 0. IDEV(LEV) = 0 5 CONTINUE C C PUT NON-MISSING DEVIATIONS INTO LOCAL ARRAY. C II = 0 DO 10 I=1,4 IF(ABS(COINC(I,IV)).LT.VMAX(IV)) THEN II = II+1 VDEV(II) = COINC(I,IV) IDEV(II) = L(I) ENDIF 10 CONTINUE LEVS = II LEVSM = LEVS - 1 IF(LEVS.LT.2) RETURN CCC = CC(IV) C C SOLVE FOR RESIDUALS AT THE TWO INTERMEDIATE LEVELS. C DO 20 I=2,3 IADJ = 0 IDEVM = IDEV(I-1) IDEV0 = IDEV(I) IDEVP = IDEV(I+1) IF( IDEVM.EQ.IDEV0 & .OR.IDEV0.EQ.IDEVP & .OR.IDEVM.EQ.IDEVP & .OR.IDEV0.LE.0) GO TO 20 IF(IDEVM.GT.0.AND.IDEV0-IDEVM.LE.2) IADJ = IADJ + 1 IF(IDEVP.GT.0.AND.IDEVP-IDEV0.LE.2) IADJ = IADJ + 2 IF(IADJ.EQ.0) THEN C C NO CLOSE DATA. C GO TO 20 ELSEIF((IADJ.EQ.1.AND.ABS(VDEV(I-1)).LT.VMAX(IV)) & .OR.(IADJ.EQ.3.AND.ABS(VDEV(I+1)).GE.VMAX(IV))) THEN C C ONLY CLOSE NON-LARGE DATA BELOW. C PR1 = IPLVL(IDEV(I)) PR2 = IPLVL(IDEV(I-1)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(I) CVRES(I-1,IV) = -H1 * VDEV(I-1) + COINC(I,IV) ELSEIF((IADJ.EQ.2.AND.ABS(VDEV(I+1)).LT.VMAX(IV)) & .OR.(IADJ.EQ.3.AND.ABS(VDEV(I-1)).GE.VMAX(IV))) THEN C C ONLY CLOSE NON-LARGE DATA ABOVE. C PR1 = IPLVL(IDEV(I)) PR2 = IPLVL(IDEV(I+1)) H1 = COR(PR1,PR2,CCC)/PGAM ID = IDEV(I) CVRES(I-1,IV) = -H1 * VDEV(I+1) + COINC(I,IV) ELSEIF(IADJ.EQ.3 & .AND.ABS(VDEV(I-1)).LT.VMAX(IV) & .AND.ABS(VDEV(I+1)).LT.VMAX(IV)) THEN PR0 = IPLVL(IDEV(I)) PR1 = IPLVL(IDEV(I-1)) PR2 = IPLVL(IDEV(I+1)) C01 = COR(PR0,PR1,CCC) C02 = COR(PR0,PR2,CCC) C12 = COR(PR1,PR2,CCC) H1 = (PGAM*C01 - C02*C12) / (PGAMS - C12**2) H2 = (PGAM*C02 - C01*C12) / (PGAMS - C12**2) ID = IDEV(I) CVRES(I-1,IV) = -H1*VDEV(I-1) - H2*VDEV(I+1) + COINC(I,IV) ENDIF 20 CONTINUE RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: VSOLVE C PRGMMR: WOOLLEN ORG: NMC22 DATE: 90-11-06 C C ABSTRACT: CHOLESKY TYPE SOLUTION FOR ARRAYS OF POSITIVE DEFINITE C SYMMETRIC MATRIXES. C C PROGRAM HISTORY LOG: C 90-11-06 J. WOOLLEN C C USAGE: C INPUT ARGUMENTS: C A - ARRAY OF SYMMETRIC MATRIXES C B - ARRAY OF RIGHT HAND SIDE VECTORS C NDIM - ARRAY OF MATRIX RANKS C BAD - BAD MATRIX INDICATOR C NFT - NUMBER OF RIGHT HAND SIDES PER MATRIX C NS - NUMBER OF MATRIXES TO SOLVE C MAXDIM - LARGEST RANK MATRIX IN STACK C C OUTPUT ARGUMENTS: C B - CONTAINS THE SOLUTIONS UPON RETURN C C SUBPROGRAMS CALLED: NONE C C EXIT STATES: NONE C C REMARKS: TRIANGULAR REPRESENTATION LISTS ELEMENTS TOWARDS THE C DIAGONAL. ALGORITHM FROM H.CARUS. C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN C MACHINE: CRAY C C$$$ C----------------------------------------------------------------------- SUBROUTINE VSOLVE (A,B,NDIM,BAD,NFT,NS,MAXDIM) DIMENSION A(1000,10),B(1000,4,1),NDIM(1000),BAD(1000) LOGICAL BAD DIMENSION T(1000) DATA CNUM/1.E-15/ C---------------------------------------------------------------------- IX (I,J) = I*(I-1)/2 + J C---------------------------------------------------------------------- N = MAXDIM DO 1 M=1,NS 1 BAD(M) = .FALSE. C DECOMPOSE THE MATRIXES C ---------------------- DO 10 I=1,N DO 10 J=1,I DO 2 M=1,NS 2 T(M) = A(M,IX(I,J)) DO 3 K=1,J-1 DO 3 M=1,NS 3 T(M) = T(M) - A(M,IX(I,K)) * A(M,IX(J,K)) IF(I.GT.J) THEN DO 4 M=1,NS 4 A(M,IX(I,J)) = T(M) * A(M,IX(J,J)) ELSE DO 5 M=1,NS IF(T(M).LT.CNUM .AND. NDIM(M).GE.I) BAD(M) = .TRUE. IF(T(M).LE.0) T(M) = 1. 5 CONTINUE DO 6 M=1,NS 6 A(M,IX(I,I)) = 1./SQRT(T(M)) ENDIF 10 CONTINUE C SOLVE FOR ALL RIGHT HAND SIDES C ------------------------------ DO 40 NF=1,NFT C FORWARD SUBSTITUTION C -------------------- DO 20 I=1,N DO 11 M=1,NS 11 T(M) = B(M,I,NF) DO 12 J=1,I-1 DO 12 M=1,NS 12 T(M) = T(M) - A(M,IX(I,J)) * B(M,J,NF) DO 20 M=1,NS 20 B(M,I,NF) = T(M) * A(M,IX(I,I)) C BACKWARD SUBSTITUTION C --------------------- DO 30 I=N,1,-1 DO 21 M=1,NS 21 T(M) = B(M,I,NF) IF(I.NE.N) THEN DO 22 J=I+1,N DO 22 M=1,NS 22 T(M) = T(M) - A(M,IX(J,I)) * B(M,J,NF) ENDIF DO 30 M=1,NS 30 B(M,I,NF) = T(M) * A(M,IX(I,I)) 40 CONTINUE RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: VTPENV CALCULATE VIRTUAL TEMPERATURE C PRGMMR: J. WOOLLEN ORG: W/NMC20 DATE: 94-MM-DD C C ABSTRACT: CALCULATE VIRTUAL TEMPERATURE. C C PROGRAM HISTORY LOG: C 94-MM-DD J. WOOLLEN C C USAGE: CALL VTPEVN(NFIN) C INPUT ARGUMENT LIST: C NFIN - INPUT FILE NUMBER C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: CRAY C C$$$ SUBROUTINE VTPEVN(NFIN) C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), C-CRA. PQ (895),TQ (895),ZQ (895),IN (895), C-CRA. PR (895),TR (895),ZR (895) COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), . PQ (895),TQ (895),ZQ (895), . PR (895),TR (895),ZR (895) COMMON /EVNSNDI/IN (895) COMMON /MOISTR/ QOB(895),QQM(895),TDO(895),QO(895),QQ(895) DATA BMISS /10E10/ C----------------------------------------------------------------------- C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G) C----------------------------------------------------------------------- ES(T) = 6.1078*EXP((17.269*(T - 273.16))/((T - 273.16)+237.3)) QS(T,P) = (0.622*ES(T))/(P-(0.378*ES(T))) C----------------------------------------------------------------------- C CLEAR TEMPERATURE AND Q EVENTS C ------------------------------ C-CRA TO = BMISS C-CRA QO = BMISS DO IJ=1,895 TO(IJ) = BMISS QO(IJ) = BMISS ENDDO NEV = 0 C COMPUTE VIRTUAL TEMPERATURES USING EITHER OBSERVED OR FORECAST Q C ---------------------------------------------------------------- DO L=1,NLV IF(TDO(L).LT.BMISS .AND. TOB(L).LT.BMISS . .AND. POB(L).LT.BMISS . .AND. QQM(L).LE.3 ) THEN TD = TOB(L)-TDO(L)+273.16 P = POB(L) Q = QS(TD,P) TOB(L) = (TOB(L)+273.16) * (1.+.61*Q) - 273.16 QOB(L) = Q*1E6 TO(NEV+1) = TOB(L) TQ(NEV+1) = TQM(L) QO(NEV+1) = QOB(L) QQ(NEV+1) = QQM(L) TR(NEV+1) = 1 IN(NEV+1) = L NEV = NEV+1 ENDIF ENDDO RETURN END C******************************************************************* C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ZCORR DETERMINE HYDROSTATIC HEIGHT CORRECTION C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 89-06-16 C C ABSTRACT: DETERMINE HYDROSTATIC HEIGHT CORRECTION. C C PROGRAM HISTORY LOG: C 89-06-16 W. COLLINS C C USAGE: CALL ZCORR(ZC, ZCOR, J, ALLZL, NZL, ALLZ, NZ, C ICTYP, ITYP) C INPUT ARGUMENT LIST: C ZC - GEOPOTENTIAL HEIGHT (METERS) C ZCOR - HEIGHT CORRECTION (METERS) C J - MANDATORY LEVEL INDEX C ALLZL - ARRAY OF ALLOWABLE DEVIATIONS FROM ZCOR FOR C HEIGHTS BELOW 500MB (METERS) C ALLZ - ARRAY OF ALLOWABLE DEVIATIONS FROM ZCOR FOR C HEIGHTS AT AND ABOVE 500MB (METERS) C ITYP - CORRECTION TYPE C C OUTPUT ARGUMENT LIST: C ZC - CORRECTED GEOPOTENTIAL HEIGHT (METERS) C ZCOR - HEIGHT CORRECTION APPLIED (METERS) C ICTYP - CORRECTION TYPE C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: , CRAY C C$$$ SUBROUTINE ZCORR(ZC,ZCOR,J,ALLZL,NZL,ALLZ,NZ, & ICTYP,ITYP) DIMENSION ALLZL(NZL), ALLZ(NZ) C C ROUND TO NEAREST 10 METERS ABOVE 700MB. C ROUND TO NEAREST METER BELOW 500MB. C ICTYP = ITYP IF(J.LE.4) THEN ZCOR = ANINT(ZCOR) CALL SIMPLE(ZCOR,ZC,ALLZL,NZL) ELSE ZCOR = 10.*ANINT(ZCOR/10.) CALL SIMPLE(ZCOR,ZC,ALLZ,NZ) ENDIF ZC = ZC + ZCOR RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: PREP SET UP VARIABLES FOR RADIATION CORRECTION C PRGMMR: J. WOOLLEN ORG: GSC DATE: 94-02-27 C C ABSTRACT: DOES PRELIMINARY WORK PRIOR TO APPLYING RADIOSONDE HEIGHT C AND TEMPERATURE CORRECTIONS DUE TO INTERSONDE DIFFERENCES (MAINLY C RADIATIVE EFFECTS ON THE INSTRUMENT). THE JULIAN DAY AND TRUE C SOLAR NOON ARE DETERMINED FOR THIS DAY OF THE YEAR. BASED ON THE C DATE OF THE DATA (FROM THE BUFR MESSAGE) THE PROPER VALUE FOR THE C VARIABLE "IRCTBL" IS DETERMINED (THIS WILL LATER POINT TO PROPER C SET OF CORRECTION TABLES). C C PROGRAM HISTORY LOG: C 94-02-27 J. WOOLLEN -- COPIED FROM ORIGINAL PARTS OF ORIGINAL C RADNCORR PROGRAM, AND CONVERTED FOR USE WITH BUFR C C USAGE: CALL PREP(IDATE) C INPUT ARGUMENT LIST: C IDATE - 4-WORD INTEGER (YY,MM,DD,HH) DATE/TIME C C INPUT FILES: C FT04F001 - NAMELIST CONTAINING VARIABLES READ INTO SUBROUTINE C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE "RADEVN". C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE PREP(IDATE) C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL C-CRA COMMON /SUNNY / JDAYR,DAYSY,TSNOON COMMON /SUNNY / DAYSY,TSNOON COMMON /SUNNYI/ JDAYR NAMELIST/KDTA/IRCTBL NAMELIST/LDTA/LEVRAD,LWCORR DIMENSION IDATE(4),JDATE(5) LOGICAL HGTTBL C----------------------------------------------------------------------- C----------------------------------------------------------------------- C*********************************************************************** C COMPUTE: JDAYR = DAY'S JULIAN DAY OF YEAR C DAYSY = TOTAL NUMBER OF DAYS IN YEAR C DANGL = ? C TSNOON = TRUE SOLAR NOON FOR TODAY'S DATE (HRS GMT) C*********************************************************************** CALL W3FS13(IDATE(1),IDATE(2),IDATE(3),JDAYR) DAYSY = 365. IF(MOD(IDATE(1),4).EQ.0) DAYSY = 366. DANGL = 6.2831853 * (REAL(JDAYR) - 79.)/DAYSY SDGL = SIN(DANGL) CDGL = COS(DANGL) TSNOON = -.030*SDGL-.120*CDGL+.330*SDGL*CDGL+.0016*SDGL**2-.0008 C--------------------------------------------------------- C IDTTS1 IS NO. OF MIN. FROM 00Z 01/01/78 TO 12Z 07/30/86 C IDTTS2 IS NO. OF MIN. FROM 00Z 01/01/78 TO 12Z 01/22/92 C IDTTS3 IS NO. OF MIN. FROM 00Z 01/01/78 TO 12Z 12/17/91 C IDTTS4 IS NO. OF MIN. FROM 00Z 01/01/78 TO 06Z 03/18/92 C IDTTS5 IS NO. OF MIN. FROM 00Z 01/01/78 TO 00Z 10/01/93 C IDT IS NO. OF MIN. FROM 00Z 01/01/78 TO THE YY/MM/DD C--------------------------------------------------------- IDTTS1 = 4510800 IDTTS2 = 7393680 IDTTS3 = 7341840 IDTTS4 = 7473960 IDTTS5 = 8282880 C FIGURE OUT WHAT DATE THIS IS C ---------------------------- JDATE(1) = IDATE(1) JDATE(2) = IDATE(2) JDATE(3) = IDATE(3) JDATE(4) = IDATE(4) JDATE(5) = 0 CALL W3FS21(JDATE,IDT) C HEIGHT CORRECTIONS ARE NOT OBTAINED FROM TABLES AFTER 10/1/93 C ------------------------------------------------------------- HGTTBL = (IDT.LT.IDTTS5) C THE DEFAULT VALUE FOR IRCTBL DEPENDS ON THE DATE OF THE DATA C ------------------------------------------------------------ IF(IDT.LT.IDTTS1) THEN IRCTBL = 1 ELSE IF(IDT.LT.IDTTS2) THEN IRCTBL = 2 ELSE IRCTBL = 3 END IF READ(4,KDTA,END=1) C THE DEF. VALUES FOR LWCORR AND LEVRAD DEPEND UPON THE VALUE OF IRCTBL C --------------------------------------------------------------------- 1 LWCORR = 1 LEVRAD = 11 IF(IRCTBL.GE.2) LEVRAD = 1 READ(4,LDTA,END=2) C FOR IRCTBL = 3, LWCORR IS NOT APPLICABLE SO IT IS ALWAYS SET TO ZERO C --------------------------------------------------------------------- 2 IF(IRCTBL.EQ.3) LWCORR = 0 C PRINT THE PARAMETERS AND EXIT C ----------------------------- WRITE(6,KDTA) WRITE(6,LDTA) IF(IRCTBL.EQ.1) PRINT 200 IF(IRCTBL.EQ.2) PRINT 201 IF(IRCTBL.EQ.3) PRINT 202 IF(LEVRAD.LE.0) PRINT 203 RETURN C FORMAT STATEMENTS C ----------------- 200 FORMAT(//,13X,'CORRECTIONS ARE BASED ON STUDY BY MCINTURFF AND ', . 'FINGER (1968) -- OPERATIONAL ONLY PRIOR TO 12Z 07/30/86') 201 FORMAT(//,9X,'CORRECTIONS ARE BASED ON STUDY BY MCINTURFF ET AL.', . ' (1979) -- OPERATIONAL 12Z 07/30/86 TO 12Z 01/22/92') 202 FORMAT(//,5X,'CORRECTIONS ARE BASED ON STUDY BY SCHMIDLIN(1990) ', . 'AND P JULIAN (NMC ON 374) -- OPERATIONAL 12Z 01/22/92',//) 203 FORMAT(10X,'===> SWITCH "LEVRAD" = 0 -- NO CORRECTIONS APPLIED',/) END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RADEVN PREPARES REPORT FOR RADIATION CORRECTIONS C PRGMMR: J. WOOLLEN ORG: GSC DATE: 94-02-27 C C ABSTRACT: PREPARES FOR RADIOSONDE HEIGHT AND TEMPERATURE CORRECTIONS C DUE TO INTERSONDE DIFFERENCES (MAINLY RADIATIVE EFFECTS ON THE C INSTRUMENT (SEE REMARKS FOR LEVELS). THE SOLAR HOUR ANGLE AND C SOLAR ELEVATION ANGLE ARE CALCULATED. THE PROPER SUBROUTINE C CONTAINING CORRECTION TABLES IS THEN CALLED. THE CORRECTIONS ARE C THEN APPLIED DIRECTLY TO THE MANDATORY LEVELS, AND (FOR THE C "NEWER" TABLES) THE TEMPERATURE CORRECTIONS ARE INTERPOLETED TO C THE SURFACE, SIGINIFICANT AND TROPOSPHERIC LEVELS. THIS SUBROUTINE C HANDLES ONE REPORT AT A TIME. C C PROGRAM HISTORY LOG: C 94-02-27 J. WOOLLEN -- COPIED FROM ORIGINAL "GETRAD" SUROUTINE C WHICH WAS PART OF RADNCORR PROGRAM, AND CONVERTED FOR USE WITH C BUFR C C USAGE: CALL RADEVN(IDATE) C INPUT AGRUMENT LIST: C IDATE - 4-WORD INTEGER (YY,MM,DD,HH) DATE/TIME C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CORRECTIONS ARE APPLIED AT AND ABOVE THE FOLLOWING LEVELS C BASED ON VARIABLE "IRCTBL": C IRCTBL = 1 -- 100 MB ; C IRCTBL = 2 -- 700 MB ; C IRCTBL = 3 -- 1000 MB ; C CALLED BY SUBROUTINE "DMA22". C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C CTREE PILNLNP CTREE MAN925 C$$$ SUBROUTINE RADEVN(IDATE) C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), C-CRA. PQ (895),TQ (895),ZQ (895),IN (895), C-CRA. PR (895),TR (895),ZR (895) COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), . PQ (895),TQ (895),ZQ (895), . PR (895),TR (895),ZR (895) COMMON /EVNSNDI/IN (895) C-CRA COMMON /RADCOM/ HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),JTYPE,OBSTM COMMON /RADCOM / HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),OBSTM COMMON /RADCOMI/ JTYPE C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL COMMON /PMAND / PRES(16) C-CRA COMMON /SUNNY / JDAYR,DAYSY,TSNOON COMMON /SUNNY / DAYSY,TSNOON COMMON /SUNNYI/ JDAYR C-CRA COMMON/COUNT /NTYPE(69),KTYPE(69),SIDNOR(2000),IICNT COMMON/COUNT /SIDNOR(2000) COMMON/COUNTI/NTYPE(69),KTYPE(69),IICNT CHARACTER*50 TEVN,ZEVN CHARACTER*8 SID,SIDNOR C-MK DIMENSION IDATE(4),INP(16) DIMENSION KPRES(21) LOGICAL INIT,NOSWC DATA KPRES /1000 , 925 , 850 , 700 , 500 , 400 , 300, . 250 , 200 , 150 , 100 , 70 , 50 , 30, . 20 , 10 , 7 , 5 , 3 , 2 , 1/ DATA TEVN /'TOB TQM TPC TRC '/ DATA ZEVN /'ZOB ZQM ZPC ZRC '/ DATA INIT /.TRUE./ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C FIRST TIME CALL PREP TO READ NAMELISTS AND SET PARAMETERS C --------------------------------------------------------- IF(INIT) THEN INIT = .FALSE. PRINT 321, IDATE 321 FORMAT(//23X,'WELCOME TO THE RADIOSONDE INTERSONDE (RADIATION) ', $ 'CORRECTION PART OF THE CQC PROGRAM'/53X,'LAST UPDATED 20 SEP ', $ '1994'///45X,'DATE FROM BUFR MESSAGES IS: ',4I3.2//) CALL PREP(IDATE) DO I=1,16 PRES(I) = KPRES(I) ENDDO ENDIF C INITIALIZE ALL UNCORRECTED HEIGHTS AND TEMPS AS MISSING C ------------------------------------------------------- KMIN = LEVRAD KMAX = 16 C-CRA DHT = 0 C-CRA DTP = 0 DO IJ=1,16 DHT(IJ) = 0 DTP(IJ) = 0 ENDDO NEV = 0 C-CRA TMP = BMISS C-CRA HGT = BMISS C-CRA TO = BMISS C-CRA ZO = BMISS C-CRA IN = BMISS DO IJ=1,16 TMP(IJ) = BMISS HGT(IJ) = BMISS ENDDO DO IJ=1,895 TO(IJ) = BMISS ZO(IJ) = BMISS IN(IJ) = BMISS ENDDO C FILL THE MANDATORY LEVEL EVENT AND CORRECTION ARRAYS FOR THIS REPORT C -------------------------------------------------------------------- DO L=1,NLV M = MAN925(POB(L)) IF(M.GT.0 .AND. M.LE.KMAX) THEN TMP(M) = TOB(L) HGT(M) = ZOB(L) INP(M) = L ENDIF ENDDO write(*,*) 'location fort.4 8888: ' ALON = MOD(720.+360.-XOB,360.) JTYPE = ITP CALL TAB(JTYPE) IF(IRCTBL.GE.2) THEN C COME HERE FOR IRCTBL=2 OR 3 CORRECTIONS (CURRENT AND PREVIOUS TABLES) C --------------------------------------------------------------------- ADDTIM = -0.2 ELSE C COME HERE FOR IRCTBL=1 CORRECTIONS (OLDEST TABLES) C -------------------------------------------------- ADDTIM = 0.5 C NEW CHECKS FOR THE NEW INSTRUMENT TYPES C VAISALA (IN/OUT OF FINLAND) IF(JTYPE.EQ.14 ) JTYPE = 4 C RUSSIAN RKZ AND UNKNOWN RUSSIAN IF(JTYPE.EQ.20.OR.JTYPE.EQ.21) JTYPE = 12 C NEW CHECKS FOR THE OLD INSTRUMENT TYPES C EXCLUDE CHINESE (WMO BLOCKS 50-59) FROM RUSSIAN TYPE IF(SID(1:1).EQ.'5' ) JTYPE = 19 ENDIF C COMP. ANGULAR FRACTION OF YR (AFY) & SINE OF SOLAR DECLINATION (SSOD) C --------------------------------------------------------------------- RLAT = .0174532925 * YOB C COMPUTE SOLAR HR ANGLE (SHA) & SOLAR ELEV ANGLES AT FIRST CORRECTED C LVL AND AT 10 MB LEVEL WHERE CORRECTION FOR LW RADIATION IS MADE C IRCTBL=3 --> 1ST CORR. LEVEL IS 1000 MB; AT 700 MB C BALLOON TIME IS RELEASE TIME - 0.2 HR C IRCTBL=2 --> 1ST CORR. LEVEL IS 700 MB; AT 700 MB C BALLOON TIME IS RELEASE TIME - 0.2 HR C IRCTBL=1 --> 1ST CORR. LEVEL IS 100 MB; AT 100 MB C BALLOON TIME IS RELEASE TIME + 0.5 HR C AT 10 MB BALLOON TIME IS RELEASE TIME + 1.3 HR C SOLAR ELEV. ANGLES STORED IN SUN(1) AND SUN(2), RESPECTIVELY C OBSTM IS THE OBSERVATION TIME RELATIVE TO 0000 GMT FOR DAY IN BUFR MSG C (E.G., = 6. FOR 0600 GMT; = -1. FOR 2300 GMT) C ---------------------------------------------------------------------- OBSTM = IDATE(4) + DHR DO I=1,2 BALTM = OBSTM + ADDTIM AFY = 6.2831853 * (REAL(JDAYR) - 1. + (BALTM/24.))/DAYSY SAFY = SIN(AFY) CAFY = COS(AFY) SSOD = .3978492 * SIN(4.88578 + AFY + (.033420 * SAFY) . - (.001388 * CAFY) + (.000696 * SAFY * CAFY) . + (.000028 * (SAFY**2 - CAFY**2))) SHA = .0174532925 * ((15. * (TSNOON + BALTM + 36.)) - ALON) SUN(I) = 57.29578 * ASIN((SSOD * SIN(RLAT)) + . (SQRT(1.0 - SSOD**2) * COS(RLAT) * COS(SHA))) ADDTIM = 1.3 ENDDO C CALL APPROPRIATE SUBROUTINE TO APPLY CORRECTIONS - SAVE DELTAS C -------------------------------------------------------------- IF(IRCTBL.EQ.1) CALL RADT1(NOSWC,IRET) IF(IRCTBL.EQ.2) CALL RADT2(NOSWC,IRET) IF(IRCTBL.EQ.3) CALL RADT3(IRET) IF(IRET.NE.0) THEN IICNT = IICNT + 1 IF(IICNT.LT.2001) SIDNOR(IICNT) = SID RETURN END IF IF(IRCTBL.LE.2.AND.NOSWC) KMIN = 16 C APPLY CORRECTIONS TO MANDATORY LEVELS C ------------------------------------- DO M=KMIN,KMAX IF(TMP(M).LT.BMISS) THEN CALL RSTATS . (2,TOB(INP(M))*10.,TMP(M)*10.,ALON*100.,YOB*100.,KPRES(M)) IF(DTP(M).NE.0) THEN NEV = NEV+1 TO(NEV) = TMP(M) TQ(NEV) = TQM(INP(M)) TR(NEV) = 1 IN(NEV) = INP(M) TOB(INP(M)) = TMP(M) ENDIF ENDIF IF(HGT(M).LT.BMISS) THEN CALL RSTATS(1,ZOB(INP(M)),HGT(M),ALON*100.,YOB*100.,KPRES(M)) IF(DHT(M).NE.0) THEN NEV = NEV+1 ZO(NEV) = HGT(M) ZQ(NEV) = ZQM(INP(M)) ZR(NEV) = 1 IN(NEV) = INP(M) ZOB(INP(M)) = HGT(M) ENDIF ENDIF ENDDO IF(IRCTBL.EQ.1) RETURN C INTERPOLATE CORRECTIONS TO SFC, SIG, TROP LVLS & MAND. LVLS ABOVE KMAX C ---------------------------------------------------------------------- DO L=1,NLV IF(MAN925(POB(L)).EQ.0 .OR. POB(L).LT.PRES(KMAX)) THEN TCOR = PILNLNP(POB(L),PRES,DTP,KMAX) ZCOR = PILNLNP(POB(L),PRES,DHT,KMAX) IF(TOB(L).LT.BMISS .AND. TCOR.NE.0) THEN IF(MAN925(POB(L)).GT.0) CALL RSTATS(2,TOB(L)*10., . (TOB(L)+TCOR)*10.,ALON*100.,YOB*100.,NINT(POB(L))) NEV = NEV+1 TO(NEV) = TOB(L) + TCOR TQ(NEV) = TQM(L) TR(NEV) = 1 IN(NEV) = L TOB(L) = TO(NEV) ENDIF IF(ZOB(L).LT.BMISS .AND. ZCOR.NE.0 .AND. L.NE.ISF) THEN IF(MAN925(POB(L)).GT.0) CALL RSTATS(1,ZOB(L),ZOB(L)+ZCOR, . ALON*100.,YOB*100.,NINT(POB(L))) NEV = NEV+1 ZO(NEV) = ZOB(L) + ZCOR ZQ(NEV) = ZQM(L) ZR(NEV) = 1 IN(NEV) = L ZOB(L) = ZO(NEV) ENDIF ENDIF ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RADT1 APPLIES OLDEST SET OF RADIATION CORRECTNS C PRGMMR: J. WOOLLEN ORG: GSC DATE: 94-02-27 C C ABSTRACT: THIS SUBROUTINE APPLIES RADIATION CORRECTIONS TO THE C OBSERVED RADIOSONDE HEIGHTS AND TEMPERATURES FOR ALL SIX C STRATOSPHERIC LEVELS: 100, 70, 50, 30, 20, AND 10 MB. DATA ARE C PASSED THROUGH COMMON /RADCOM/. THE CORRECTION OF RAOBS FOR SHORT- C WAVE RADIATIVE EFFECTS IS ACCOMPLISHED BY READING IN TABLES OF C NUMBERS WHICH ARE DEPENDENT ON THE INSTRUMENT TYPE. THE CORRECTION C OF RAOBS FOR LONG-WAVE RADIATION (AT 10 MB ONLY) IS BASED ON THE C 4'TH POWER OF THE 10 MB TEMPERATURE. CALLED FOR ONE REPORT C AT A TIME. C C PROGRAM HISTORY LOG: C 71-12-19 KEITH JOHNSON -- W/NMC?? C 73-09-13 PPC C 90-12-05 D. A. KEYSER -- CONVERTED TO VS FORTRAN(77) & RESTRUCTURED C 94-02-27 J. WOOLLEN -- CONVERTED FOR USE WITH BUFR C C USAGE: CALL RADT1(NOSWC,IRET) C OUTPUT ARGUMENT LIST: C NOSWC - LOGICAL INDICATING NO SHORT-WAVE CORRECTION APPLIED C IRET - RETURN CODE (0=CORRECTIONS,1=NO CORRECTIONS) C C REMARKS: THESE CORRECTIONS USE THE ORIGINAL NMC OFFICE NOTE 29 C INSTRUMENT TYPE CODES OBTAINED FROM THE NMC UPPER-AIR DICTIONARY. C CALLED BY SUBROUTINE "RADEVN". C C C KEY FOR INSTRUMENT TYPES USED HERE: C C JTYPE(ON29) CODE NAME (DICTIONARY) DESCRIPTION C C UNSPEC. T5N (INACTIVE) FRENCH METOX C 1 T1J U.S. NOAA / VIZ C 2 ** NO CORRECTION ** RESERVED C 3 T3L U.S. AN/AMT 4 C 4 T4M FINNISH VAISALA (IN FINLAND) C 5 ** NO CORRECTION ** FRENCH MESURAL (IN FRANCE) C 6 ** NO CORRECTION (INACTIVE) PORTUGAL (CANADIAN MODEL IV) C 7 ** NO CORRECTION ** W. GERMAN GRAW C 8 ** NO CORRECTION ** RESERVED C 9 T9R JAPANESE "CODE SENDING" C 10 TASLSH (INACTIVE) E. GERMAN FREIBERG C 11 TBS U.K. KEW C 12 TCT U.S.S.R A-22 C 13 ** NO CORRECTION ** RESERVED C 14 (CHGED. TO JTYPE= 4 INSTR) FINNISH VAISALA (IN/OUT FINLAND) C 15 (CHGED. TO JTYPE= 5 INSTR) FRENCH MESURAL (OUT OF FRANCE) C 16 ** NO CORRECTION ** AUSTRALIAN PHILLIPS C 17 ** NO CORRECTION (INACTIVE) AUSTRALIAN "DIAMOND HINMAN" C 18 ** NO CORRECTION ** CANADIAN "SANGAMO" C 19 ** NO CORRECTION ** CHINESE C 20 (CHGED. TO JTYPE=12 INSTR) U.S.S.R. RKZ C 21 (CHGED. TO JTYPE=12 INSTR) U.S.S.R. UNKNOWN (AVG. A-22&RKZ) C 22 ** NO CORRECTION ** INDIAN MET. SERVICE C 23 ** NO CORRECTION ** AUSTRIAN ELIN C 24 ** NO CORRECTION ** KOREAN JINYANG / VIZ C 25 ** NO CORRECTION ** SWISS METEOLABOR C 26 ** NO CORRECTION ** CZECH VINOHRADY C 27 ** NO CORRECTION ** U.S. MSS (SPACE DATA CORP.) C 28.. 97 ** NO CORRECTION ** RESERVED C C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE RADT1(NOSWC,IRET) C-CRA COMMON /RADCOM/ HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),JTYPE,OBSTM COMMON /RADCOM / HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),OBSTM COMMON /RADCOMI/ JTYPE C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL DIMENSION CUTOFF(6),SOLAR(6),PRES(6),DTS(6),DHS(6),ALP(5), . ANGLE(11),T1J(66),T3L(66),T4M(66),T5N(66),T9R(66), . TASLSH(66),TBS(66),TCT(66),H1J(11),H3L(11),H4M(11), . H5N(11),H9R(11),HASLSH(11),HBS(11),HCT(11), . TTAB(66,8),HTAB(11,8),ITYPTB(99) EQUIVALENCE (TTAB(1,1),T1J(1)),(TTAB(1,2),T3L(1)), . (TTAB(1,3),T4M(1)),(TTAB(1,4),T5N(1)), . (TTAB(1,5),T9R(1)),(TTAB(1,6),TASLSH(1)), . (TTAB(1,7),TBS(1)),(TTAB(1,8),TCT(1)) EQUIVALENCE (HTAB(1,1),H1J(1)),(HTAB(1,2),H3L(1)), . (HTAB(1,3),H4M(1)),(HTAB(1,4),H5N(1)), . (HTAB(1,5),H9R(1)),(HTAB(1,6),HASLSH(1)), . (HTAB(1,7),HBS(1)),(HTAB(1,8),HCT(1)) LOGICAL INIT,NOSWC C TEMPERATURE CORRECTIONS (*10 K) FOR S-W RADIATION EFFECTS C --------------------------------------------------------- C NOAA / VIZ DATA T1J / $ 0., 3., 6., 8., 9., 10., 10., 10., 9., 8., 5., $ 0., 4., 7., 9., 10., 11., 11., 11., 10., 9., 5., $ 0., 5., 8., 10., 12., 12., 13., 13., 11., 10., 6., $ 0., 7., 12., 14., 16., 16., 17., 16., 14., 11., 7., $ 0., 9., 16., 18., 20., 20., 20., 19., 16., 12., 8., $ 0., 15., 22., 25., 26., 27., 26., 25., 22., 18., 12./ C AN/AMT 4 NOAA/ VIZ MILITARY TYPE DATA T3L / $ 0., 2., 4., 5., 6., 7., 8., 8., 6., 2., 0., $ 0., 2., 4., 6., 7., 8., 9., 9., 7., 2., 0., $ 0., 2., 4., 7., 9., 10., 11., 10., 8., 3., 0., $ 0., 3., 6., 10., 12., 13., 14., 12., 10., 4., 0., $ 0., 6., 9., 12., 15., 16., 17., 15., 12., 4., 0., $ 0., 12., 15., 18., 20., 22., 22., 20., 16., 6., 0./ C VAISALA INSIDE FINLAND (ALSO USED FOR VAISALA OUT OF FINLAND) DATA T4M / $ 0., 2., 4., 6., 8., 10., 11., 11., 10., 8., 6., $ -3., 1., 3., 6., 8., 10., 11., 12., 10., 8., 6., $ -6., 0., 3., 6., 8., 10., 13., 12., 10., 8., 6., $ -10., -3., 2., 4., 8., 10., 13., 13., 11., 9., 7., $ -14., -6., 0., 4., 8., 10., 14., 13., 11., 9., 7., $ -23., -6., 0., 5., 9., 11., 14., 13., 12., 10., 8./ C FRENCH METOX (INACTIVE - CORRECTIONS NOT APPLIED) DATA T5N / $ 0., 0., 8., 12., 16., 20., 23., 26., 24., 17., 9., $ 0., 0., 13., 20., 25., 30., 35., 38., 38., 31., 17., $ 0., 0., 18., 27., 34., 41., 46., 51., 52., 46., 26., $ 0., 0., 27., 42., 54., 64., 70., 76., 76., 65., 30., $ 0., 0., 36., 57., 72., 82., 90., 96., 95., 83., 55., $ 0., 0., 56., 83.,105.,122.,132.,140.,140.,130.,116./ C JAPANESE DATA T9R / $ 0., 0., 12., 14., 14., 13., 11., 9., 7., 0., 0., $ 0., 0., 18., 21., 20., 17., 14., 11., 7., 0., 0., $ 0., 0., 24., 28., 26., 22., 18., 13., 6., 0., 0., $ 0., 0., 30., 36., 33., 29., 24., 18., 11., 0., 0., $ 0., 0., 33., 39., 36., 30., 23., 16., 5., 0., 0., $ 0., 0., 38., 47., 40., 30., 20., 7., -8., 0., 0./ C EAST GERMAN FREIBERG (INACTIVE - CORRECTIONS NOT APPLIED) DATA TASLSH / $ 0., 0., 8., 11., 14., 18., 20., 23., 0., 0., 0., $ 0., 0., 12., 15., 18., 22., 24., 26., 0., 0., 0., $ 0., 0., 16., 19., 22., 26., 28., 30., 0., 0., 0., $ 0., 0., 24., 34., 42., 48., 52., 54., 0., 0., 0., $ 0., 0., 30., 45., 55., 61., 65., 67., 0., 0., 0., $ 0., 0., 58., 68., 76., 80., 81., 82., 0., 0., 0./ C UNITED KINGDOM KEW (WPT HAD THIS INSTRUMENT AS PAKISTANI FAN-TYPE) DATA TBS / $ 0., 0., 6., 10., 10., 6., 6., 6., -4.,-12., 0., $ 0., 0., 6., 11., 10., 6., 8., 8., -1.,-11., 0., $ 0., 0., 6., 12., 10., 6., 10., 11., 2., -8., 0., $ 0., 0., 16., 20., 16., 10., 14., 14., -8.,-34., 0., $ 0., 15., 26., 28., 30., 24., 24., 22., 0.,-36., 0., $ 0., 40., 52., 54., 50., 44., 44., 46., 28., 7., 0./ C U.S.S.R. A-22 DATA TCT / $ -2., 2., 8., 9., 10., 10., 10., 10., 8., 0., 0., $ -1., 4., 10., 11., 13., 14., 15., 14., 12., 0., 0., $ -1., 6., 12., 14., 16., 18., 20., 19., 17., 0., 0., $ 2., 10., 14., 18., 20., 23., 25., 24., 22., 0., 0., $ 3., 14., 22., 25., 27., 29., 30., 28., 26., 0., 0., $ 9., 24., 32., 37., 40., 43., 44., 41., 39., 0., 0./ C HEIGHT CORRECTIONS (M) AT 100 MB FOR S-W RADIATION EFFECTS C ---------------------------------------------------------- DATA H1J / 0., 10.,20.,29.,35.,38.,39.,37., 30., 27.,25./ DATA H3L / -9., -2., 8.,17.,23.,25.,26.,25., 18., 0., 0./ DATA H4M / 0., 7.,17.,22.,27.,32.,36.,36., 34., 30.,27./ DATA H5N / 0., 0.,10.,22.,34.,44.,53.,60., 59., 48.,26./ DATA H9R / 0., 0.,38.,38.,38.,37.,36.,35., 34., 0., 0./ DATA HASLSH/ 0., 0.,19.,29.,38.,47.,56.,65., 0., 0., 0./ DATA HBS /-33.,-22.,-1.,11.,13., 5., 6.,10.,-12.,-47., 0./ DATA HCT /-14., 6.,22.,33.,38.,41.,42.,40., 38., 0., 0./ DATA INIT /.TRUE./ DATA BMISS /10E10/ DATA PRES /100.,70.,50.,30.,20.,10./ DATA ANGLE /0.,0.,10.,20.,30.,40.,50.,60.,70.,80.,90./ DATA CUTOFF /-5.54,-5.76,-6.02,-6.31,-6.55,-7.04/ DATA ITYPTB /1,0,2,3,0,0,0,0,5,6,7,8,0,86*0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C EACH TIME THROUGH, COMPUTE LOGS OF PRESSURE RATIOS C -------------------------------------------------- DO I=1,5 ALP(I) = 1.46 * ALOG(PRES(I)/PRES(I+1)) ENDDO C INTERPOLATE SOLAR ELEVATION ANGLES BETWEEN 100 MB AND 10 MB C (DUE TO DELTA TIME IN BALLOON REACHING MANDATORY LEVELS) C ----------------------------------------------------------- SUNBA = SUN(2)-SUN(1) SOLAR(1) = SUN(1) SOLAR(2) = SUN(1) + (0.15252 * SUNBA) SOLAR(3) = SUN(1) + (0.29520 * SUNBA) SOLAR(4) = SUN(1) + (0.51538 * SUNBA) SOLAR(5) = SUN(1) + (0.69250 * SUNBA) SOLAR(6) = SUN(2) C GET TABLE INDEX FROM INSTRUMENT TYPE C ------------------------------------ ITAB = 0 IF(JTYPE.GT.0 .AND. JTYPE.LT.100) ITAB = ITYPTB(JTYPE) NOSWC = (JTYPE.LT.1.OR.JTYPE.GE.14.OR.ITAB.LE.0) C IF LWCORR=1 AND NOSWC THEN NO CORRECTIONS ARE MADE C -------------------------------------------------- IF(LWCORR.LE.1.AND.NOSWC) THEN IRET = -1 RETURN ENDIF C APPLY SHORT- (AND POSS. LONG-) WAVE CORRECTIONS (LEVELS 11 TO 16) C ----------------------------------------------------------------- IF(NOSWC) THEN L = 6 ELSE L = 1 ENDIF DO I=L,6 ANGLE(1) = CUTOFF(I) DTS(I) = 0. DHS(I) = 0. DTL = 0. DHL = 0. IF(.NOT.NOSWC .AND. SOLAR(I).GE.CUTOFF(I)) THEN DO K=2,10 IF(SOLAR(I).LT.ANGLE(K)) GO TO 40 ENDDO K = 11 40 KK = K + (11 * (I - 1)) DSUN = (SOLAR(I) - ANGLE(K-1))/(ANGLE(K) - ANGLE(K-1)) C COMPUTE S-W TEMP CORRECTIONS FOR ALL LEVELS BETWEEN 100 & 10 MB C --------------------------------------------------------------- DTS(I) =DSUN*(TTAB(KK,ITAB)-TTAB(KK-1,ITAB))+TTAB(KK-1,ITAB) C COMPUTE S-W HEIGHT CORRECTIONS AT 100 MB & INTERP. TO HIGHER LEVELS C ------------------------------------------------------------------- IF(I.EQ.1) THEN DHS(1) =DSUN*(HTAB(K,ITAB)-HTAB(K-1,ITAB))+HTAB(K-1,ITAB) ELSE DHS(I) = DHS(I-1) + (ALP(I-1) * (DTS(I) + 10.*DTS(I-1))) ENDIF ENDIF C CORRECT DTS BY A FACTOR OF 10 C ----------------------------- DTS(I) = .1*DTS(I) IF(I.EQ.6 .AND. LWCORR.GT.0 .AND. TMP(16).LT.BMISS) THEN C FOR LWCORR.GT.0, COMPUTE L-W TEMP & HGHT CORRECTIONS (ONLY AT 10 MB) C -------------------------------------------------------------------- DTL = .0625*(TMP(16)-DTS(6)) + 5.09 DHL = (TMP(16)-DTS(6)) + 81.4 ENDIF C SAVE AND APPLY THE CORRECTIONS C ------------------------------ DHT(10+I) = DHL - DHS(I) DTP(10+I) = DTL - DTS(I) IF(HGT(10+I).LT.BMISS) HGT(10+I) = HGT(10+I) + DHT(10+I) IF(TMP(10+I).LT.BMISS) TMP(10+I) = TMP(10+I) + DTP(10+I) ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RADT2 APPLIES NEWER SET OF RADIATION CORRECTONS C PRGMMR: J. WOOLLEN ORG: GSC DATE: 94-02-27 C C ABSTRACT: THIS SUBROUTINE APPLIES RADIATION CORRECTIONS TO THE C OBSERVED RADIOSONDE HEIGHTS AND TEMPERATURES ON THE BOTTOM 16 C MANDATORY PRESSURE LEVELS. DATA ARE PASSED THROUGH COMMON C /RADCOM/. THE CORRECTION OF RAOBS FOR SHORT-WAVE RADIATIVE EFFECTS C IS ACCOMPLISHED BY READING IN TABLES OF NUMBERS WHICH ARE DEPENDENT C ON THE INSTRUMENT TYPE. THE CORRECTION OF RAOBS FOR LONG-WAVE C RADIATION (AT 10 MB ONLY) IS BASED ON THE 4'TH POWER OF THE 10 MB C TEMPERATURE. CALLED FOR ONE REPORT AT A TIME. C C PROGRAM HISTORY LOG: C UNKNOWN G. D. DIMEGO C 88-03-10 D. A. KEYSER -- PROCESSING OF 'LWCALL' SWITCH C 88-11-04 D. A. KEYSER -- ADDED CORRECTIONS FOR NEW NOAA VIZ-A, C VIZ-B, AND SPACE DATA CORP. C 89-03-10 D. A. KEYSER -- EXPANDED TABLES FOR SINGLE NIGHTTIME C CORR. & CORR. BELOW 700 MB, ADDED TABLE FOR SDC-89 SONDE BASED C ON VIZ CORR. + (VIZ - SDC) BIAS C 90-12-05 D. A. KEYSER -- CONVERTED TO VS FORTRAN(77) & RESTRUCTURED C 92-03-18 D. A. KEYSER -- ADDED CORRECTIONS AT 925 MB TO TABLES C 94-02-27 J. WOOLLEN -- CONVERTED FOR USE WITH BUFR C C USAGE: CALL RADT2(NOSWC,IRET) C OUTPUT ARGUMENT LIST: C NOSWC - LOGICAL INDICATING NO SHORT-WAVE CORRECTION APPLIED C IRET - RETURN CODE (0=CORRECTIONS,1=NO CORRECTIONS) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: THESE CORRECTIONS USE THE ORIGINAL NMC OFFICE NOTE 29 C INSTRUMENT TYPE CODES OBTAINED FROM THE NMC UPPER-AIR DICTIONARY. C CALLED BY SUBROUTINE "RADEVN". C C C KEY FOR INSTRUMENT TYPES USED HERE: C C JTYPE(ON29) CODE NAME (DICTIONARY) DESCRIPTION C C 1 T1J00Z U.S. NOAA / VIZ-A - 1988 -- 00Z C -- OR -- T1J12Z U.S. NOAA / VIZ-A - 1988 -- 12Z C 2 ** NO CORRECTION ** RESERVED C 3 T3L U.S. AN/AMT 4 C 4 T4M FINNISH VAISALA (IN FINLAND) C 5 T5N FRENCH MESURAL (IN FRANCE) C 6 ** NO CORRECTION ** PORTUGAL (CANADIAN MODEL IV) (INACTIVE) C 7 T7P WEST GERMAN GRAW C 8 ** NO CORRECTION ** RESERVED C 9 T9R JAPANESE "CODE SENDING" C 10 TASLSH EAST GERMAN FREIBERG (INACTIVE) C 11 TBS UNITED KINGDOM KEW C 12 T2200Z U.S.S.R A-22 -- 00Z C -- OR -- T2212Z U.S.S.R A-22 -- 12Z C 13 ** NO CORRECTION ** RESERVED C 14 TVSL2 FINNISH VAISALA (IN/OUT FINLAND) C 15 TFMR2 FRENCH MESURAL (OUT OF FRANCE) C 16 ** NO CORRECTION ** AUSTRALIAN PHILLIPS C 17 TAUS AUSTRALIAN "DIAMOND HINMAN" (INACTIVE) C 18 TCSG CANADIAN "SANGAMO" C 19 TCHI CHINESE C 20 TRK00Z U.S.S.R. RKZ -- 00Z C -- OR -- TRK12Z U.S.S.R. RKZ -- 12Z C 21 TAV00Z U.S.S.R. UNKNOWN (AVG. A-22&RKZ) -- 00Z C -- OR -- TAV12Z U.S.S.R. UNKNOWN (AVG. A-22&RKZ) -- 12Z C 22 ** NO CORRECTION ** INDIAN MET. SERVICE C 23 ** NO CORRECTION ** AUSTRIAN ELIN C 24 ** NO CORRECTION ** KOREAN JINYANG / VIZ C 25 ** NO CORRECTION ** SWISS METEOLABOR C 26 ** NO CORRECTION ** CZECH VINOHRADY C 27 ** NO CORRECTION ** U.S. MSS (SPACE DATA CORP.) C 28 T1J00Z U.S. NOAA / VIZ-B - 1988 -- 00Z C -- OR -- T1J12Z U.S. NOAA / VIZ-B - 1988 -- 12Z C 29 TSD00Z U.S. NOAA / SPACE DATA CORP. - 1989 C -- OR -- TSD12Z U.S. NOAA / SPACE DATA CORP. - 1989 C 30 \ C THRU > ** NO CORRECTION ** RESERVED C 97 / C C C KEY FOR LEVELS IN DATA (CORRECTION) TABLES: C C 1 - 1000 MB C 2 -- 925 MB C 3 -- 850 MB T -- 20 MB C 4 -- 700 MB L -- 10 MB C 5 -- 500 MB A -- 400 MB (INTERP. BETWEEN 500 & 300 MB) C 6 -- 300 MB B -- 250 MB (INTERP. BETWEEN 300 & 200 MB) C 7 -- 200 MB C -- 150 MB (INTERP. BETWEEN 200 & 100 MB) C 8 -- 100 MB D -- 70 MB (INTERP. BETWEEN 100 & 50 MB) C 9 -- 50 MB E -- 30 MB (INTERP. BETWEEN 50 & 10 MB) C $ -- 30 MB F -- 20 MB (INTERP. BETWEEN 50 & 10 MB) C C C THE RADIATION CORRECTION TABLES ARE OBTAINED FROM NOAA TECH. MEMO. C NWS NMC 63, BY MCINTURFF ET. AL. (1972). C C C THE CUTOFF ANGLE AT EACH LEVEL IS CALCULATED USING THE RELATION: C CUTOFF ANGLE = -1.76459 * (Z**.40795) , C WHERE Z IS A REFERENCE HEIGHT FOR THE LEVEL (IN KILOMETERS). C (SEE NMC OFFICE NOTE 306, TABLE 4 FOR LIST OF REFERENCE HEIGHTS.) C C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE RADT2(NOSWC,IRET) C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /RADCOM/ HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),JTYPE,OBSTM COMMON /RADCOM / HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),OBSTM COMMON /RADCOMI/ JTYPE C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL COMMON /PMAND / PRES(16) DIMENSION T1J00Z(11,16),T1J12Z(11,16),T2200Z(11,16), . T2212Z(11,16),TRK00Z(11,16),TRK12Z(11,16), . TAV00Z(11,16),TAV12Z(11,16),T3L(11,16),T4M(11,16), . T5N(11,16),T7P(11,16),T9R(11,16),TASLSH(11,16), . TBS(11,16),TVSL2(11,16),TFMR2(11,16),TAUS(11,16), . TCSG(11,16),TCHI(11,16),TSD00Z(11,16),TSD12Z(11,16), . TTAB(11,16,22),CUTOFF(16),SOLAR(16),ANGLE(11), . ALP(16),DTS(16),DHS(16),ITYPTB(99) EQUIVALENCE (TTAB(1,1,1), T1J00Z(1,1)),(TTAB(1,1,2), T1J12Z(1,1)), . (TTAB(1,1,3), T3L(1,1)), (TTAB(1,1,4), T4M(1,1)) , . (TTAB(1,1,5), T5N(1,1)), (TTAB(1,1,6), T7P(1,1)) , . (TTAB(1,1,7), T9R(1,1)), (TTAB(1,1,8), TASLSH(1,1)), . (TTAB(1,1,9), TBS(1,1)), (TTAB(1,1,10),T2200Z(1,1)), . (TTAB(1,1,11),T2212Z(1,1)),(TTAB(1,1,12),TVSL2(1,1)) , . (TTAB(1,1,13),TFMR2(1,1)), (TTAB(1,1,14),TAUS(1,1)) , . (TTAB(1,1,15),TCSG(1,1)), (TTAB(1,1,16),TCHI(1,1)) , . (TTAB(1,1,17),TRK00Z(1,1)),(TTAB(1,1,18),TRK12Z(1,1)), . (TTAB(1,1,19),TAV00Z(1,1)),(TTAB(1,1,20),TAV12Z(1,1)), . (TTAB(1,1,21),TSD00Z(1,1)),(TTAB(1,1,22),TSD12Z(1,1)) LOGICAL NOSWC,SWC DATA ANGLE /-90.,-5.,5.,15.,25.,35.,45.,55.,65.,75.,85./ DATA CUTOFF/-0.73,-1.58,-2.06,-2.77,-3.56,-3.95,-4.36,-4.58, . -4.83,-5.12,-5.49,-5.79,-6.06,-6.43,-6.72,-7.17/ C ITYPTB ASSIGNS PROPER TEMPERATURE CORRECTION TABLE TO INST. TYPES C ----------------------------------------------------------------- C ===> JTYPE: 1 2 3 4 5 6 7 8 9 10 DATA ITYPTB / 1 , 0 , 3 , 4 , 5 , 0 , 6 , 0 , 7 , 8 , C ===> JTYPE: 11 12 13 14 15 16 17 18 19 20 . 9 , 10 , 0 , 12 , 13 , 0 , 14 , 15 , 16 , 17 , C ===> JTYPE: 21 22 23 24 25 26 27 28 29 30-99 . 19 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 21 ,70*0/ C TEMPERATURE CORRECTIONS (*10 K) FOR S-W RADIATION EFFECTS C --------------------------------------------------------- C NOAA / VIZ - A 1988, TECH MEMO TABLE FOR 00Z AFTERNOON DAYLIGHT C =====> JTYPE = 1 -- ITAB = 1 <===== C -- OR -- C NOAA / VIZ - B 1988, TECH MEMO TABLE FOR 00Z AFTERNOON DAYLIGHT C =====> JTYPE = 28 -- ITAB = 1 <===== DATA T1J00Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 2., 3., 5., 6., 6., 3., 4., 5., 5., 4., 5 0., 2., 3., 4., 5., 5., 4., 4., 5., 5., 6., A 0., 2., 3., 5., 5., 5., 4., 4., 5., 5., 6., 6 0., 2., 4., 6., 6., 6., 5., 5., 5., 5., 6., B 0., 2., 4., 6., 6., 6., 5., 6., 6., 6., 7., 7 0., 1., 5., 6., 7., 7., 6., 7., 7., 7., 8., C 0., 1., 6., 7., 8., 8., 8., 8., 8., 9., 9., 8 0., 2., 7., 9., 10., 10., 10., 10., 10., 12., 10., D 0., 3., 9., 11., 12., 12., 11., 10., 11., 11., 10., 9 0., 5., 11., 13., 14., 14., 12., 11., 13., 10., 9., $ 0., 9., 16., 18., 21., 19., 14., 14., 10., 16., 12., T 0., 12., 19., 23., 26., 24., 18., 15., 13., 13., 22., L 0., 19., 24., 29., 32., 26., 28., 23., 25., 11., 32./ C NOAA / VIZ - A 1988, TECH MEMO TABLE FOR 12Z MORNING DAYLIGHT C =====> JTYPE = 1 -- ITAB = 2 <===== C -- OR -- C NOAA / VIZ - B 1988, TECH MEMO TABLE FOR 12Z MORNING DAYLIGHT C =====> JTYPE = 28 -- ITAB = 2 <===== DATA T1J12Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -2., -1., 2., 4., 5., 4., 8., 9., 0., 0., 5 0., -2., -1., 2., 4., 4., 5., 10., 9., 0., 0., A 0., -2., -1., 2., 3., 4., 6., 11., 10., 0., 0., 6 0., -2., 0., 2., 2., 4., 7., 12., 11., 0., 0., B 0., -1., 1., 3., 3., 6., 11., 11., 10., 0., 0., 7 0., 0., 2., 5., 4., 8., 15., 10., 9., 0., 0., C 0., 0., 3., 6., 5., 8., 14., 13., 9., 0., 0., 8 0., 1., 5., 7., 7., 8., 12., 16., 10., 0., 0., D 0., 1., 5., 7., 8., 9., 13., 13., 12., 0., 0., 9 0., 0., 5., 7., 9., 11., 14., 10., 15., 0., 0., $ 0., -1., 6., 10., 11., 14., 13., 22., -4., 0., 0., T 0., -2., 8., 11., 11., 15., 12., 13., 0., 0., 0., L 0., 0., 13., 13., 11., 13., 19., 35., 0., 0., 0./ C AN/AMT 4 NOAA / VIZ MILITARY TYPE C =====> JTYPE = 3 -- ITAB = 3 <===== DATA T3L / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -1., 0., 0., 2., 3., 3., 3., 2., 1., 0., 5 0., -5., -1., 0., 2., 4., 3., 4., 4., 3., 0., A 0., -3., 0., 1., 2., 4., 3., 4., 4., 3., 0., 6 0., -2., 1., 4., 4., 5., 4., 5., 6., 5., 0., B 0., -1., 2., 4., 4., 5., 4., 5., 6., 5., 0., 7 0., 0., 5., 6., 5., 5., 4., 6., 7., 6., 0., C 0., 0., 4., 6., 6., 6., 6., 7., 7., 7., 0., 8 0., -1., 4., 8., 8., 9., 9., 10., 8., 9., 0., D 0., 0., 6., 8., 9., 10., 10., 12., 11., 0., 0., 9 0., 2., 8., 8., 11., 11., 11., 14., 15., 0., 0., $ 0., 8., 12., 17., 14., 18., 15., 17., 18., 0., 0., T 0., 0., 17., 18., 18., 16., 17., 17., 16., 12., 0., L 0., 15., 14., 29., 17., 20., 25., 27., 23., 19., 0./ C VAISALA INSIDE FINLAND (NEW VALUES INTERPOLATED FOR LEVELS E&F) C =====> JTYPE = 4 -- ITAB = 4 <===== DATA T4M / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -1., 1., 1., 1., 1., 1., 0., 0., 0., 0., 5 0., -1., 2., 4., -2., 4., 0., 0., 0., 0., 0., A 0., -1., 1., 3., 0., 2., 0., 0., 0., 0., 0., 6 0., -3., 0., 2., 1., 1., 0., 0., 0., 0., 0., B 0., -2., 0., 0., 0., 1., 0., 0., 0., 0., 0., 7 0., -1., 1., -2., -2., 1., 0., 0., 0., 0., 0., C 0., 0., 0., -1., -1., 0., 0., 0., 0., 0., 0., 8 0., 0., -1., 0., -1., 0., 0., 0., 0., 0., 0., D 0., -2., -1., 0., 0., 2., 0., 0., 0., 0., 0., 9 0., -4., -2., 0., 1., 4., 0., 0., 0., 0., 0., E 0., -2., -2., -1., 2., 4., 0., 0., 0., 0., 0., F 0., 1., -1., -3., 4., 3., 0., 0., 0., 0., 0., T 0., 3., 0., -4., 5., 2., 0., 0., 0., 0., 0./ C MESURAL INSIDE METROPOLITAN FRANCE C =====> JTYPE = 5 -- ITAB = 5 <===== DATA T5N / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 0., 3., 2., 3., 2., 2., -2., 0., 0., 5 0., 0., 0., 4., 2., 3., 6., 3., 2., 0., 0., A 0., 0., 0., 3., 2., 3., 5., 3., 1., 0., 0., 6 0., 0., 0., 3., 2., 4., 5., 3., 1., 0., 0., B 0., 0., 0., 1., 3., 4., 2., 3., 1., 0., 0., 7 0., 0., 0., -1., 5., 5., -1., 5., 2., 0., 0., C 0., 0., 0., 1., 5., 5., 0., 5., 3., 0., 0., 8 0., 0., 0., 4., 6., 6., 3., 6., 5., 0., 0., D 0., 0., 0., 6., 7., 7., 5., 7., 8., 0., 0., 9 0., 0., 0., 9., 8., 8., 8., 8., 12., 0., 0., $ 0., 0., 0., 11., 12., 10., 13., 11., 9., 0., 0., T 0., 0., 0., 12., 13., 18., 12., 16., 18., 0., 0., L 0., 0., 0., 19., 22., 26., 32., 11., 9., 0., 0./ C WEST GERMAN GRAW C =====> JTYPE = 7 -- ITAB = 6 <===== DATA T7P / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 0., 1., -1., 0., 1., 0., -2., 0., 0., 5 0., 0., 0., 0., -1., 0., 0., 0., 2., 0., 0., A 0., 0., 0., 0., 0., 0., 0., 0., 1., 0., 0., 6 0., 0., 0., 0., 1., 0., 0., 0., 0., 0., 0., B 0., 0., 0., 0., 1., 1., 1., 0., 0., 0., 0., 7 0., 0., 0., 1., 2., 3., 3., 1., 2., 0., 0., C 0., 0., 0., 2., 3., 3., 3., 1., 3., 0., 0., 8 0., 0., 0., 4., 5., 3., 4., 3., 6., 0., 0., D 0., 0., 0., 5., 5., 4., 2., 3., 5., 0., 0., 9 0., 0., 0., 6., 5., 6., 2., 4., 5., 0., 0., $ 0., 0., 9., 6., 6., 8., 1., 0., 0., 0., 0., T 0., 0., 10., 5., 6., 6., -1., 4., 0., 0., 0., L 0., 0., 0., 7., 3., 7., -2., -3., 0., 0., 0./ C JAPANESE C =====> JTYPE = 9 -- ITAB = 7 <===== DATA T9R / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 3., 0., 1., 2., 2., 2., 3., 0., 0., 5 0., 0., 0., 2., 3., 3., 4., 5., 7., 0., 0., A 0., 0., 0., 3., 3., 3., 4., 5., 6., 0., 0., 6 0., 0., 0., 6., 4., 3., 4., 5., 6., 0., 0., B 0., 0., 0., 5., 4., 4., 4., 4., 5., 0., 0., 7 0., 0., 0., 4., 6., 6., 4., 4., 5., 0., 0., C 0., 0., 0., 5., 6., 6., 5., 5., 4., 0., 0., 8 0., 0., 0., 7., 8., 7., 8., 8., 4., 0., 0., D 0., 0., 0., 10., 10., 8., 8., 8., 2., 0., 0., 9 0., 0., 0., 13., 12., 10., 8., 9., 2., 1., 0., $ 0., 0., 0., 26., 19., 16., 12., 11., 10., -5., 0., T 0., 0., 0., 0., 30., 28., 19., 13., 14.,-10., 0., L 0., 0., 0., 0., 41., 35., 16., 18., 14., 0., 0./ C EAST GERMAN FREIBERG (INACTIVE - WAS NOT IN TECH MEMO) C SOURCE UNKNOWN POSSIBLY TAKEN FROM ORIGINAL RADNCORR) C =====> JTYPE = 10 -- ITAB = 8 <===== DATA TASLSH / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 5 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., A 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 6 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., B 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 7 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., C 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 8 0., 0., 4., 9., 12., 16., 19., 21., 11., 0., 0., D 0., 0., 6., 13., 16., 20., 23., 25., 13., 0., 0., 9 0., 0., 8., 17., 20., 24., 27., 29., 15., 0., 0., $ 0., 0., 12., 29., 38., 45., 50., 53., 27., 0., 0., T 0., 0., 15., 37., 50., 58., 63., 66., 33., 0., 0., L 0., 0., 29., 63., 72., 78., 80., 81., 41., 0., 0./ C UNITED KINGDOM KEW (WPT HAD THIS INSTRUMENT AS PAKISTANI FAN-TYPE) C =====> JTYPE = 11 -- ITAB = 9 <===== DATA TBS / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., -3., -1., -1., 0., -1., -1., -1., 0., 0., 5 0., 0., -2., 0., 0., 0., 0., 0., -1., -6., 0., A 0., 0., -2., 0., 0., 0., 0., 0., 0., -4., 0., 6 0., 0., -2., 0., 0., 2., 1., 1., 0., -3., 0., B 0., 0., -1., 0., 0., 1., 0., 0., 0., 0., 0., 7 0., 0., -1., -1., 0., 0., 0., -2., 0., 0., 0., C 0., 0., 0., 0., 1., 0., 0., -2., 0., 0., 0., 8 0., 0., -2., 1., 3., 2., 0., -3., -1., 0., 0., D 0., 0., -6., -1., 1., 0., -1., -1., 1., 0., 0., 9 0., 0.,-10., -3., 1., -1., -3., 0., 3., 0., 0., $ 0., 0., -5., -1., 8., 3., 1., 4., -1., 0., 0., T 0., 0., 3., 4., 16., 15., 11., 8., 0., 0., 0., L 0., 0., 32., 33., 43., 33., 28., 14., 0., 0., 0./ C USSR A-22 TECH MEMO TABLE FOR 00Z MORNING DAYLIGHT C =====> JTYPE = 12 -- ITAB = 10 <===== DATA T2200Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 1., 0., -1., 0., -1., -2., 0., 0., 0., 5 0., -1., 0., 0., -1., 0., 0., -2., 0., 0., 0., A 0., 0., 0., 0., 0., 0., 1., 0., 0., 0., 0., 6 0., 0., 0., 0., 2., 1., 2., 1., 0., 0., 0., B 0., 0., 1., 0., 2., 1., 1., 0., 0., 0., 0., 7 0., 0., 2., 1., 2., 2., -1., -2., 0., 0., 0., C 0., 0., 2., 1., 2., 3., 0., 0., 0., 0., 0., 8 0., 0., 2., 2., 3., 5., 1., 3., 0., 0., 0., D 0., 0., 2., 3., 4., 6., 3., 3., 0., 0., 0., 9 0., -1., 3., 5., 5., 8., 5., 3., 0., 0., 0., $ 0., -2., 4., 6., 5., 7., 6., 4., 3., 0., 0., T 0., -1., 6., 9., 9., 11., 12., 9., -6., 0., 0., L 0., 1., 9., 19., 28., 5., 23., 24., 0., 0., 0./ C USSR A-22 TECH MEMO TABLE FOR 12Z AFTERNOON DAYLIGHT C =====> JTYPE = 12 -- ITAB = 11 <===== DATA T2212Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 1., 3., 3., 5., 2., 2., 1., 1., 0., 0., 5 0., 2., 2., 3., 3., 2., 2., 3., 0., 0., 0., A 0., 2., 2., 3., 2., 3., 3., 3., 2., 0., 0., 6 0., 1., 3., 2., 1., 4., 4., 2., 4., 0., 0., B 0., 1., 3., 2., 2., 3., 2., 0., 2., 0., 0., 7 0., 1., 3., 2., 3., 1., 0., -2., 0., 0., 0., C 0., 1., 4., 3., 4., 3., 1., -1., 0., 0., 0., 8 0., 2., 5., 4., 5., 5., 3., 0., 0., 0., 0., D 0., 2., 5., 5., 6., 7., 4., 2., 0., 0., 0., 9 0., 3., 6., 7., 7., 9., 6., 4., 0., 0., 0., $ 0., 2., 3., 8., 9., 9., 5., 8., 0., 0., 0., T 0., 3., 5., 10., 1., 12., 10., 2., 0., 0., 0., L 0., -2., 2., 25., 3., 18., 2., 0., 0., 0., 0./ C VAISALA INSIDE & OUTSIDE OF FINLAND C =====> JTYPE = 14 -- ITAB = 12 <===== DATA TVSL2 / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -2., 1., 1., 3., 1., 2., 3., 5., 3., 2., 5 0., 2., 1., 0., 1., 2., 2., 3., 4., 6., 0., A 0., 0., 1., 0., 1., 2., 1., 3., 4., 6., 0., 6 0., -1., 1., 1., 2., 2., 3., 3., 5., 6., 0., B 0., 0., 1., 1., 1., 2., 3., 3., 5., 6., 0., 7 0., 0., 1., 1., 1., 2., 3., 5., 6., 6., 0., C 0., 0., 1., 1., 2., 3., 3., 6., 8., 8., 0., 8 0., 1., 3., 3., 4., 6., 5., 8., 13., 13., 0., D 0., 1., 5., 6., 7., 9., 8., 9., 10., 0., 0., 9 0., 1., 8., 10., 10., 12., 12., 10., 8., 0., 0., $ 0., 1., 20., 24., 22., 20., 15., 4., 1., 0., 0., T 0., 1., 19., 24., 20., 20., 16., 4., 1., 0., 0., L 0., 26., 31., 40., 18., 33., 14., 25., 0., 0., 0./ C MESURAL USED OUTSIDE OF FRANCE C =====> JTYPE = 15 -- ITAB = 13 <===== DATA TFMR2 / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 0., 0., 8., 6., 8., 5., 2., 0., 0., 5 0., 0., 0., 0., 5., 8., 9., 7., 5., 4., 0., A 0., 0., 0., 0., 8., 8., 11., 8., 6., 4., 0., 6 0., 0., 0., 0., 13., 9., 14., 11., 8., 6., 0., B 0., 0., 0., 0., 17., 10., 32., 28., 38., 20., 0., 7 0., 0., 0., 0., 23., 22., 55., 49., 76., 38., 0., C 0., 0., 0., 0., 28., 23., 42., 39., 54., 27., 0., 8 0., 0., 0., 0., 37., 25., 24., 27., 23., 12., 0., D 0., 0., 0., 0., 49., 33., 33., 15., 30., 18., 0., 9 0., 0., 0., 0., 62., 42., 43., 4., 37., 24., 0., $ 0., 0., 0., 0., 76., 66., 51., 51., 53., 0., 0., T 0., 0., 0., 0.,114., 88., 85., 93., 50., 0., 0., L 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ C AUSTRALIAN DIAMOND HINMAN (INACTIVE) C =====> JTYPE = 17 -- ITAB = 14 <===== DATA TAUS / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 3., 0., 3., 2., 1., 3., 7., 3., 4., 5 0., 0., 0., 2., 1., 2., 2., 4., 5., 4., -3., A 0., 0., 0., 2., 1., 2., 2., 3., 3., 2., 0., 6 0., 0., 0., 2., 2., 2., 3., 2., 2., 1., 0., B 0., 0., 0., 2., 2., 3., 4., 3., 3., 2., 0., 7 0., 0., 2., 4., 4., 5., 6., 5., 6., 5., 9., C 0., 0., 0., 4., 5., 5., 7., 7., 8., 7., 8., 8 0., 0., 0., 6., 8., 7., 9., 10., 11., 10., 8., D 0., 0., 0., 7., 9., 9., 11., 10., 12., 12., 0., 9 0., 0., 0., 9., 10., 11., 13., 11., 14., 14., 0., $ 0., 0., 0., 8., 17., 17., 17., 18., 14., 24., 0., T 0., 0., 0., 18., 17., 16., 28., 22., 17., 14., 0., L 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ C SANGAMO CANADIAN C =====> JTYPE = 18 -- ITAB = 15 <===== DATA TCSG / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 0., 1., 3., 4., 3., 2., -1., -3., 0., 0., 5 0., 0., 0., 4., 5., 5., 1., 3., 1., 0., 0., A 0., 0., 0., 4., 5., 5., 2., 3., 3., 0., 0., 6 0., 0., 2., 4., 5., 7., 5., 5., 6., -1., 0., B 0., 0., 2., 4., 5., 6., 3., 5., 7., 3., 0., 7 0., 0., 4., 4., 5., 6., 2., 6., 9., 10., 0., C 0., 0., 4., 5., 5., 7., 4., 8., 9., 8., 0., 8 0., 1., 6., 7., 7., 9., 8., 13., 10., 8., 0., D 0., 1., 7., 9., 8., 10., 9., 9., 9., 12., 0., 9 0., 1., 8., 11., 9., 12., 11., 7., 9., 17., 0., $ 0., 4., 11., 13., 14., 12., 10., 8., 13., 16., 0., T 0., 5., 14., 14., 14., 13., 10., 14., 14., 12., 0., L 0., 15., 19., 13., 12., 22., 4., 17., 10., 13., 0./ C CHINESE C =====> JTYPE = 19 -- ITAB = 16 <===== DATA TCHI / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -2., -2., -1., -1., 0., 0., 0., 0., 0., 0., 5 0., 1., -1., -1., 0., -4., 0., 0., 0., 0., 0., A 0., 0., -2., -2., -2., -3., 0., 0., 0., 0., 0., 6 0., 0., -4., -5., -6., -3., 0., 0., 0., 0., 0., B 0., 0., -4., -4., -4., -3., 0., 0., 0., 0., 0., 7 0., 1., -4., -3., -2., -4., 0., 0., 0., 0., 0., C 0., 0., -3., -1., 0., 0., 0., 0., 0., 0., 0., 8 0., 0., -2., 0., 1., 4., 6., 0., 0., 0., 0., D 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 9 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., $ 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., T 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., L 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0./ C USSR RKZ TECH MEMO TABLE FOR 00Z MORNING DAYLIGHT C =====> JTYPE = 20 -- ITAB = 17 <===== DATA TRK00Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., -2., 1., 0., -1., -3., -3., -3., 0., 0., 0., 5 0., 0., 0., 0., -1., -1., -1., -3., 0., 0., 0., A 0., 0., 0., 1., 0., -1., 0., -2., 0., 0., 0., 6 0., 0., 0., 2., 1., 0., 1., -1., 0., 0., 0., B 0., 0., 0., 2., 2., 0., 1., -1., 0., 0., 0., 7 0., -1., 1., 1., 4., 1., 1., -1., 0., 0., 0., C 0., 0., 2., 2., 3., 1., 1., 0., 0., 0., 0., 8 0., 0., 3., 3., 2., 1., 0., 2., 0., 0., 0., D 0., 0., 3., 4., 2., 1., 0., 2., 0., 0., 0., 9 0., 1., 4., 5., 2., 1., 1., 1., 0., 0., 0., $ 0., 1., 7., 6., 3., 1., 0., -1., -2., 0., 0., T 0., 2., 9., 9., 6., 3., 1., 3., 2., 0., 0., L 0., 5., 15., 17., 18., 16., 5., 1., 9., 0., 0./ C USSR RKZ TECH MEMO TABLE FOR 12Z AFTERNOON DAYLIGHT C =====> JTYPE = 20 -- ITAB = 18 <===== DATA TRK12Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 4 0., 1., 2., 3., 3., 3., 3., 1., 1., 0., 0., 5 0., 0., 2., 3., 3., 3., 3., 2., 1., 0., 0., A 0., 0., 3., 3., 3., 3., 3., 2., 0., 0., 0., 6 0., 1., 4., 3., 3., 3., 4., 2., 0., 0., 0., B 0., 1., 4., 3., 3., 3., 3., 1., 0., 0., 0., 7 0., 2., 3., 4., 2., 3., 2., 0., 0., 0., 0., C 0., 2., 4., 4., 2., 2., 1., 0., 0., 0., 0., 8 0., 2., 5., 5., 2., 1., 0., 0., 0., 0., 0., D 0., 3., 6., 6., 3., 1., 1., 1., 0., 0., 0., 9 0., 5., 8., 7., 5., 2., 3., 3., 0., 0., 0., $ 0., 7., 10., 9., 7., 4., 2., -2., 0., 0., 0., T 0., 8., 11., 11., 6., 6., 1., -1., 0., 0., 0., L 0., 18., 28., 17., 5., 5., 0., 0., 0., 0., 0./ C USSR UNKNOWN (AVG. OF A-22 AND RKZ) FOR 00Z MORNING DAYLIGHT C =====> JTYPE = 21 -- ITAB = 19 <===== DATA TAV00Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 3 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4 0.0,-1.0, 1.0, 0.0,-1.0,-1.5,-2.0,-2.5, 0.0, 0.0, 0.0, 5 0.0,-0.5, 0.0, 0.0,-1.0,-0.5,-0.5,-2.5, 0.0, 0.0, 0.0, A 0.0, 0.0, 0.0, 0.5, 0.0,-0.5, 0.5,-1.0, 0.0, 0.0, 0.0, 6 0.0, 0.0, 0.0, 1.0, 1.5, 0.5, 1.5, 0.0, 0.0, 0.0, 0.0, B 0.0, 0.0, 0.5, 1.0, 2.0, 0.5, 1.0,-0.5, 0.0, 0.0, 0.0, 7 0.0,-0.5, 1.5, 1.0, 3.0, 1.5, 0.0,-1.5, 0.0, 0.0, 0.0, C 0.0, 0.0, 2.0, 1.5, 2.5, 2.0, 0.5, 0.0, 0.0, 0.0, 0.0, 8 0.0, 0.0, 2.5, 2.5, 2.5, 3.0, 0.5, 2.5, 0.0, 0.0, 0.0, D 0.0, 0.0, 2.5, 3.5, 3.0, 3.5, 1.5, 2.5, 0.0, 0.0, 0.0, 9 0.0, 0.0, 3.5, 5.0, 3.5, 4.5, 3.0, 2.0, 0.0, 0.0, 0.0, $ 0.0,-0.5, 5.5, 6.0, 4.0, 4.0, 3.0, 1.5, 0.5, 0.0, 0.0, T 0.0, 0.5, 7.5, 9.0, 7.5, 7.0, 6.5, 6.0,-2.0, 0.0, 0.0, L 0.0, 3.0,12.0,18.0,23.0,10.5,14.0,12.5, 4.5, 0.0, 0.0/ C USSR UNKNOWN (AVG. OF A-22 AND RKZ) FOR 12Z AFTERNOON DAYLIGHT C =====> JTYPE = 21 -- ITAB = 20 <===== DATA TAV12Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 3 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4 0.0, 1.0, 2.5, 3.0, 4.0, 2.5, 2.5, 1.0, 1.0, 0.0, 0.0, 5 0.0, 1.0, 2.0, 3.0, 3.0, 2.5, 2.5, 2.5, 0.5, 0.0, 0.0, A 0.0, 1.0, 2.5, 3.0, 2.5, 3.0, 3.0, 2.5, 1.0, 0.0, 0.0, 6 0.0, 1.0, 3.5, 2.5, 2.0, 3.5, 4.0, 2.0, 2.0, 0.0, 0.0, B 0.0, 1.0, 3.5, 2.5, 2.5, 3.0, 2.5, 0.5, 1.0, 0.0, 0.0, 7 0.0, 1.5, 3.0, 3.0, 2.5, 2.0, 1.0,-1.0, 0.0, 0.0, 0.0, C 0.0, 1.5, 4.0, 3.5, 3.0, 2.5, 1.0,-0.5, 0.0, 0.0, 0.0, 8 0.0, 2.0, 5.0, 4.5, 3.5, 3.0, 1.5, 0.0, 0.0, 0.0, 0.0, D 0.0, 2.5, 5.5, 5.5, 4.5, 4.0, 2.5, 1.5, 0.0, 0.0, 0.0, 9 0.0, 4.0, 7.0, 7.0, 6.0, 5.5, 4.5, 3.5, 0.0, 0.0, 0.0, $ 0.0, 4.5, 6.5, 8.5, 8.0, 6.5, 3.5, 3.0, 0.0, 0.0, 0.0, T 0.0, 5.5, 8.0,10.5, 3.5, 9.0, 5.5, 0.5, 0.0, 0.0, 0.0, L 0.0, 8.0,15.0,21.0, 4.0,11.5, 1.0, 0.0, 0.0, 0.0, 0.0/ C NOAA / SPACE DATA CORP. 1989, TABLE FOR 00Z AFTERNOON DAYLIGHT C (TECH MEMO TABLE FOR NOAA / VIZ-A 1988 WITH A BIAS APPLIED) C =====> JTYPE = 29 -- ITAB = 21 <===== DATA TSD00Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 -2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7, 2 -2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5, 3 -2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3, 4 -1.7, 0.3, 1.3, 3.3, 4.3, 4.3, 1.3, 2.3, 3.3, 3.3, 2.3, 5 0.9, 2.9, 3.9, 4.9, 5.9, 5.9, 4.9, 4.9, 5.9, 5.9, 6.9, A 4.2, 6.2, 7.2, 9.2, 9.2, 9.2, 8.2, 8.2, 9.2, 9.2,10.2, 6 4.2, 6.2, 8.2,10.2,10.2,10.2, 9.2, 9.2, 9.2, 9.2,10.2, B 4.2, 6.2, 8.2,10.2,10.2,10.2, 9.2,10.2,10.2,10.2,11.2, 7 6.3, 7.3,11.3,12.3,13.3,13.3,12.3,13.3,13.3,13.3,14.3, C 6.9, 7.9,12.9,13.9,14.9,14.9,14.9,14.9,14.9,15.9,15.9, 8 6.6, 8.6,13.6,15.6,16.6,16.6,16.6,16.6,16.6,18.6,16.6, D 7.0,10.0,16.0,18.0,19.0,19.0,18.0,17.0,18.0,18.0,17.0, 9 7.4,12.4,18.4,20.4,21.4,21.4,19.4,18.4,20.4,17.4,16.4, $ 8.1,17.1,24.1,26.1,29.1,27.1,22.1,22.1,18.1,24.1,20.1, T 8.6,20.6,27.6,31.6,34.6,32.6,26.6,23.6,21.6,21.6,30.6, L 7.9,26.9,31.9,36.9,39.9,33.9,35.9,30.9,32.9,18.9,39.9/ C NOAA / SPACE DATA CORP. 1989, TABLE FOR 12Z MORNING DAYLIGHT C (TECH MEMO TABLE FOR NOAA / VIZ-A 1988 WITH A BIAS APPLIED) C =====> JTYPE = 29 -- ITAB = 22 <===== DATA TSD12Z / C N -5 5 15 25 35 45 55 65 75 85 --> SOLAR C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ ANGLE C LEVEL 1 -2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7,-2.7, 2 -2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5, 3 -2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3,-2.3, 4 -1.7,-3.7,-2.0, 0.3, 2.3, 3.3, 2.3, 6.3, 7.3,-1.7,-1.7, 5 0.9,-1.1,-0.1, 2.9, 4.9, 4.9, 5.9,10.9, 9.9, 0.9, 0.9, A 4.2, 2.2, 3.2, 6.2, 7.2, 8.2,10.2,15.2,14.2, 4.2, 4.2, 6 4.2, 2.2, 4.2, 6.2, 6.2, 8.2,11.2,16.2,15.2, 4.2, 4.2, B 4.2, 3.2, 5.2, 7.2, 7.2,10.2,15.2,15.2,14.2, 4.2, 4.2, 7 6.3, 6.3, 8.3,11.3,10.3,14.3,21.3,16.3,15.3, 6.3, 6.3, C 6.9, 6.9, 9.9,12.9,11.9,14.9,20.9,19.9,15.9, 6.9, 6.9, 8 6.6, 7.6,11.6,13.6,13.6,14.6,18.6,22.6,16.6, 6.6, 6.6, D 7.0, 8.0,12.0,14.0,15.0,16.0,20.0,20.0,19.0, 7.0, 7.0, 9 7.4, 7.4,12.4,14.4,16.4,18.4,21.4,17.4,22.4, 7.4, 7.4, $ 8.1, 7.1,14.1,18.1,19.1,22.1,21.1,30.1, 4.1, 8.1, 8.1, T 8.6, 6.6,16.6,19.6,19.6,23.6,20.6,21.6, 8.6, 8.6, 8.6, L 7.9, 7.9,20.9,20.9,18.9,20.9,26.9,42.9, 7.9, 7.9, 7.9/ DATA BMISS/10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C EACH TIME THROUGH, COMPUTE LOGS OF PRESSURE RATIOS AND ASSIGN C TO LEVELS 2 THROUGH 16 -- IF R. TYPE IS NOT 29 (S.D.C. - 1989), SET C VALUES ON 925, 850 & 700 MB TO 0. TO KEEP CONSISTENT W/ PRIOR VERSION C WHICH APPLIES NO HEIGHT CORRECTION AT 700 MB (NOTE: THIS MAY BE C CHANGED -- WHY SHOULDN'T 700 MB HAVE A HEIGHT CORRECTION?) C --------------------------------------------------------------------- ALP(1) = 0.0 DO I=2,16 ALP(I) = ALOG(PRES(I-1)/PRES(I)) ENDDO IF(JTYPE.NE.29) THEN ALP(2) = 0.0 ALP(3) = 0.0 ALP(4) = 0.0 ENDIF C INTERPOLATE SOLAR ELEVATION ANGLES AT MANDATORY LEVELS C (DUE TO DELTA TIME IN BALLOON REACHING MANDATORY LEVELS) C ---------------------------------------------------------------- SUNBA = SUN(2) - SUN(1) C NOTE: SOLAR(1)-SOLAR(3) ARE CRUDE ESTIMATE AT 1000, 925 & 850 MB C (BASED ON RATIO OF HIGHER LEVEL VALUES TO DIFFERENCES IN C REFERENCE HEIGHT) SOLAR(1 ) = SUN(1) - (.0826254 * SUNBA) SOLAR(2 ) = SUN(1) - (.0647634 * SUNBA) SOLAR(3 ) = SUN(1) - (.0456353 * SUNBA) SOLAR(4 ) = SUN(1) SOLAR(5 ) = SUN(1) + (.0791979 * SUNBA) SOLAR(6 ) = SUN(1) + (.1317209 * SUNBA) SOLAR(7 ) = SUN(1) + (.1994348 * SUNBA) SOLAR(8 ) = SUN(1) + (.2423491 * SUNBA) SOLAR(9 ) = SUN(1) + (.2948721 * SUNBA) SOLAR(10) = SUN(1) + (.3625860 * SUNBA) SOLAR(11) = SUN(1) + (.4580233 * SUNBA) SOLAR(12) = SUN(1) + (.5419766 * SUNBA) SOLAR(13) = SUN(1) + (.6211745 * SUNBA) SOLAR(14) = SUN(1) + (.7414114 * SUNBA) SOLAR(15) = SUN(1) + (.8308487 * SUNBA) SOLAR(16) = SUN(2) C GET TABLE INDEX FROM INSTRUMENT TYPE - CHECK FOR AFTERNOON CORRECTION C --------------------------------------------------------------------- ITAB = 0 IF(JTYPE.GT.0 .AND. JTYPE.LT.100) ITAB = ITYPTB(JTYPE) IF(OBSTM.GE.9. AND. OBSTM.LT.18) THEN IF(ITAB.EQ.1 ) ITAB = ITAB+1 IF(ITAB.EQ.10) ITAB = ITAB+1 IF(ITAB.EQ.17) ITAB = ITAB+1 IF(ITAB.EQ.19) ITAB = ITAB+1 IF(ITAB.EQ.21) ITAB = ITAB+1 ENDIF C CHECK FOR VALID CORRECTION PARAMETERS C ------------------------------------- NOSWC = JTYPE.LT.1 .OR. JTYPE.GT.29 IF(NOSWC .AND. JTYPE.NE.99) PRINT1,SID,JTYPE 1 FORMAT(/,5X,'* * * STN. ID ',A8,' HAS AN INVALID INSTR. ', . 'TYPE DESIGNATION (O.N. 29 CODE ',I3,') - NO CORRECTION ', . 'POSSIBLE',/) NOSWC = NOSWC .OR. ITAB.LE.0 SWC = .NOT.NOSWC IF(LWCORR.LE.1 .AND. NOSWC) THEN IRET = -1 RETURN ENDIF C APPLY SHORT- (& POSS. LONG-) WAVE TEMPERATURE AND HEIGHT CORRECTIONS C -------------------------------------------------------------------- DO ILEV=1,16 ANGLE(2) = CUTOFF(ILEV) DTS(ILEV) = 0 DHS(ILEV) = 0 DTL = 0 DHL = 0 IF(SWC) THEN IF(SOLAR(ILEV).GE.CUTOFF(ILEV)) THEN IF(SOLAR(ILEV).LT.ANGLE(11)) THEN DO K=3,11 IF(SOLAR(ILEV).LT.ANGLE(K)) THEN TABU = TTAB(K ,ILEV,ITAB) TABD = TTAB(K-1,ILEV,ITAB) DSUN = (SOLAR(ILEV) - ANGLE(K-1))/ . (ANGLE(K) - ANGLE(K-1)) DTS(ILEV) = TABD + DSUN*(TABU-TABD) GO TO 10 ENDIF ENDDO ELSE DTS(ILEV) = TTAB(11,ILEV,ITAB) ENDIF ELSE C IF ANGLE < CUTOFF (NIGHT), TEMP CORRECTION FROM 'NIGHT' VALUE IN TBL C -------------------------------------------------------------------- DTS(ILEV) = TTAB(1,ILEV,ITAB) ENDIF C COMPUTE SHORT-WAVE HEIGHT CORRECTIONS, VIA HYDROSTATIC INTERPOLATION C -------------------------------------------------------------------- 10 HYF = 1.46*ALP(ILEV) IF(ILEV.EQ.1) THEN DHS(ILEV) = HYF*DTS(ILEV) ELSE DHS(ILEV) = DHS(ILEV-1) + HYF*(10.*DTS(ILEV-1)+DTS(ILEV)) ENDIF ENDIF C CORRECT DTS BY A FACTOR OF 10 C ----------------------------- DTS(ILEV) = .1*DTS(ILEV) IF(ILEV.EQ.16 .AND. LWCORR.GT.0 .AND. TMP(16).LT.BMISS) THEN C FOR LWCORR .GT. 0, COMPUTE L-W TEMP & HGHT CORRECTIONS (ONLY AT 10MB) C --------------------------------------------------------------------- DTL = .0625*(TMP(ILEV)-DTS(ILEV)) + 5.09 DHL = (TMP(ILEV)-DTS(ILEV)) + 81.4 ENDIF C SAVE AND APPLY THE CORRECTIONS C ------------------------------ DHT(ILEV) = DHL-DHS(ILEV) DTP(ILEV) = DTL-DTS(ILEV) IF(HGT(ILEV).LT.BMISS) HGT(ILEV) = HGT(ILEV) + DHT(ILEV) IF(TMP(ILEV).LT.BMISS) TMP(ILEV) = TMP(ILEV) + DTP(ILEV) ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RADT3 APPLIES NEWEST SET OF RADIATION CORRECTNS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 94-09-20 C C ABSTRACT: THIS SUBROUTINE APPLIES RADIATION CORRECTIONS TO THE C OBSERVED RADIOSONDE HEIGHTS AND TEMPERATURES ON THE BOTTOM 16 C MANDATORY PRESSURE LEVELS. DATA ARE PASSED THROUGH COMMON C /RADCOM/. THE CORRECTION OF RAOBS FOR BOTH SHORT- AND LONG-WAVE C EFFECTS IN ACCOMPLISHED BY READING IN TABLES OF NUMBERS WHICH ARE C DEPENDENT ON THE INSTRUMENT TYPE. CALLED FOR ONE REPORT AT A TIME. C C PROGRAM HISTORY LOG: C 90-06-20 P. R. JULIAN(W/NMC00) -- ORIGINAL AUTHOR C 90-12-12 D. A. KEYSER -- FURTHER REFINEMENTS C 92-03-18 D. A. KEYSER -- ADDED CORRECTIONS AT 925 MB TO TABLES; C AIR IS-4A-1680 & AIR IS-4A-1680X SONDES RECEIVE VIZ CORRECTIONS C (BEFORE THEY WERE NOT CORRECTED) C 93-05-26 D. A. KEYSER -- ADDED INSTR. TYPE 47 FOR JAPAN-MEISEI C RS2-91, RECEIVES SAME CORRECTIONS AS MEISEI RS2-80 (I. TYPE 22) C 93-09-01 D. A. KEYSER -- AFTER 00Z 10/1/93 GRAVITATION CONSTANT C IN MICROARTS CORRECTED, VIZ & SDC SONDES NOW CORRECT GEOPOTENT. C VIA HYDRO. INTEGR. (LIKE ALL OTHER SONDES) RATHER THAN FROM C SPECIAL CORRECTION TABLES C 94-02-27 J. WOOLLEN -- CONVERTED FOR USE WITH BUFR C 94-09-20 D. A. KEYSER -- ADDED NEW CORRECTION TABLE TO CORRECT C FOR VAISALA INSTRUMENT AT U.S. SITES (THIS TABLE SLIGHTLY C DIFFERENT THAT FOR VAISALA INSTRUMENT AT NON-U.S. SITES SINCE C A DIFFERENT ON-SITE CORRECTION IS APPLIED) C C USAGE: CALL RADT3(IRET) C OUTPUT ARGUMENT LIST: C IRET - RETURN CODE (0=CORRECTIONS,1=NO CORRECTIONS) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: THESE CORRECTIONS USE THE BUFR CODE FIGURE FOR INSTRUMENT C TYPE OBTAINED FROM BUFR-FM94 TABLE 0 02 011. THE NMC UPPER-AIR C DICTIONARY ALSO CONTAINS THIS BUFR CODE FIGURE FOR INSTRUMENT C TYPE. CALLED BY SUBROUTINE "RADEVN". C C C KEY FOR INSTRUMENT TYPES USED HERE: C C JTYPE DESCRIPTION TABLE NUMBER C C 0 TO 6 NOT USED FOR SONDES C 7 TO 8 RESERVED C 9 UNKNOWN TYPE C 10 (U.S.) NOAA / VIZ TYPE A 3(T),1(G)@ C 11 ==> NOT IN USE?? (U.S.) NOAA / VIZ TYPE B 3(T),1(G)@ C 12 (U.S.) NOAA / SPACE DATA CORP. 4(T),2(G)@ C 13 ASTOR C 14 BEUKERS MICROSONDE C 15 EEC COMPANY TYPE 23 C 16 (AUSTRIA) ELIN C 17 (GERMANY) GRAW G C 18 RESERVED C 19 ==> ONLY 1 SITE (GERMANY) GRAW M60 6(T) C 20 INDIAN MET. SER TYPE MK3 C 21 ==> NOT IN USE? (N. KOREA) JINYANG C 22 (JAPAN) MEISEI RS2-80 1(T) C 23 (FRANCE) MENSURAL FMO 1950A C 24 (FRANCE) MENSURAL FMO 1945A C 25 (FRANCE) MENSURAL MH73A C 26 (SWITZERLAND) METEOLABOR BASORA C 27 (USSR) METEORITE A22IV 7(T) C 28 (USSR) METEORITE MARZ2-1 8(T) C 29 (USSR) METEORITE MARZ2-2 8(T) C 30 (JAPAN) OKI RS2-80 C 31 (CANADA) SANGAMO 2(T) C 32 (CHINA) SHANGHAI RADIO 10(T) C 33 ==> NOT IN USE UK MET OFFICE MK3 9(T) C 34 (CZECHOSLOVAKIA) VINORADY C 35 VAISALA RS18 C 36 VAISALA RS21 C 37 VAISALA RS80 5 OR 11(T) C 38 BUEKERS LOCATE (LORAN-C) C 39 (GERMANY) SPRENGER E076 C 40 (GERMANY) SPRENGER E084 C 41 (GERMANY) SPRENGER E085 C 42 (GERMANY) SPRENGER E086 C 43 AIR IS - 4A - 1680 3(T) C 44 AIR IS - 4A - 1680 X 3(T) C 45 (U.S.) MSS S. STATE SDC 1680 MHZ 4(T) C 46 AIR IS -4A - 403 C 47 (JAPAN) MEISEI RS2-91 1(T) C 48 TO 59 RESERVED FOR ADDITIONAL SONDES C 60 VAISALA RS80/MICROCORA 5 OR 11(T) C 61 VAISALA RS80/DIGICORA OR MARWIN 5 OR 11(T) C 62 VAISALA RS80/PCCORA 5 OR 11(T) C 63 VAISALA RS80/STAR 5 OR 11(T) C 64 TO 89 RESERVED FOR ADDITIONAL AUTOMATED SYSTEMS C 91 TO 99 RESERVED C C @ - VALID ONLY PRIOR TO 00Z 02/01/92 C C C KEY FOR LEVELS IN DATA (CORRECTION) TABLES: C C 1 - 1000 MB C 2 -- 925 MB C 3 -- 850 MB T -- 20 MB C 4 -- 700 MB L -- 10 MB C 5 -- 500 MB A -- 400 MB (INTERP. BETWEEN 500 & 300 MB) C 6 -- 300 MB B -- 250 MB (INTERP. BETWEEN 300 & 200 MB) C 7 -- 200 MB C -- 150 MB (INTERP. BETWEEN 200 & 100 MB) C 8 -- 100 MB D -- 70 MB (INTERP. BETWEEN 100 & 50 MB) C 9 -- 50 MB E -- 30 MB (INTERP. BETWEEN 50 & 10 MB) C $ -- 30 MB F -- 20 MB (INTERP. BETWEEN 50 & 10 MB) C C C THE RADIATION CORRECTION TABLES ARE BASED UPON DATA FROM TESTS BY C F. SCHMIDLIN AND FROM OBSERVED INCREMENTS FROM NWP ASSIMILATION. C REFER TO NMC OFFICE NOTE 374 BY P. JULIAN, ET. AL. C C C THE CUTOFF ANGLE AT EACH LEVEL CALCULATED USING THE RELATION: C CUTOFF ANGLE = -1.76459 * (Z**.40795) , C WHERE Z IS A REFERENCE HEIGHT FOR THE LEVEL (IN KILOMETERS) C (SEE NMC OFFICE NOTE 306, TABLE 4 FOR LIST OF REFERENCE HEIGHTS.) C C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE RADT3(IRET) C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /RADCOM/ HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),JTYPE,OBSTM COMMON /RADCOM / HGT(16),TMP(16),DHT(16),DTP(16),SUN(2),OBSTM COMMON /RADCOMI/ JTYPE C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL COMMON /PMAND / PRES(16) DIMENSION TTAB(10,16,11),ZTAB(10,16,2),CUTOFF(16), . SOLAR(16),ANGLE(10),ALP(16),DTS(16),DHS(16), . JAPANT(10,16),CANADT(10,16),USVZAT(10,16), . VRS80T(10,16),GRM60T(10,16),A22IVT(10,16), . UKMK3T(10,16),SHANGT(10,16),USVZAG(10,16), . USSDCT(10,16),MARZ2T(10,16),USSDCG(10,16), . VRS80U(10,16),ITYPTT(99),ITYPTG(99) EQUIVALENCE (TTAB(1,1, 1),JAPANT(1,1)),(TTAB(1,1, 2),CANADT(1,1)), . (TTAB(1,1, 3),USVZAT(1,1)),(TTAB(1,1, 4),USSDCT(1,1)), . (TTAB(1,1, 5),VRS80T(1,1)),(TTAB(1,1, 6),GRM60T(1,1)), . (TTAB(1,1, 7),A22IVT(1,1)),(TTAB(1,1, 8),MARZ2T(1,1)), . (TTAB(1,1, 9),UKMK3T(1,1)),(TTAB(1,1,10),SHANGT(1,1)), . (TTAB(1,1,11),VRS80U(1,1)),(ZTAB(1,1, 1),USVZAG(1,1)), . (ZTAB(1,1, 2),USSDCG(1,1)) LOGICAL HGTTBL REAL JAPANT,MARZ2T CHARACTER*8 SID C-MK DATA ANGLE / -90, -5, 5, 15, 25, 35, 45, 55, 65, 75/ DATA ANGLE / -90., -5., 5., 15., 25., 35., 45., 55., 65., 75./ DATA CUTOFF / -.73, -1.58, -2.06, -2.77, . -3.56, -3.95, -4.36, -4.58, . -4.83, -5.12, -5.49, -5.79, . -6.06, -6.43, -6.72, -7.17/ C ITYPTT ASSIGNS PROPER TEMPERATURE CORRECTION TABLE TO INST. TYPES C ----------------------------------------------------------------- C ===> JTYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 DATA ITYPTT/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 4, 0, 0, 0, C ===> JTYPE: 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 $ 0, 0, 0, 6, 0, 0, 1, 0, 0, 0, 0, 7, 8, 8, 0, C ===> JTYPE: 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 $ 2,10, 9, 0, 0, 0, 5, 0, 0, 0, 0, 0, 3, 3, 4, C ===> JTYPE: 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 $ 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, C ===> JTYPE: 61 62 63 64-99 $ 5, 5, 5,36*0/ C ITYPTG ASSIGNS PROPER GEOPOTENTIAL CORRECTION TABLE TO INST. TYPES C ------------------------------------------------------------------ C ===> JTYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 DATA ITYPTG/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 2, 0, 0, 0, C ===> JTYPE: 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 $ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C ===> JTYPE: 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 $ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C ===> JTYPE: 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 $ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C ===> JTYPE: 61 62 63 64-99 $ 0, 0, 0,36*0/ C TEMPERATURE CORRECTION TABLES ( * 10 K) FOR RADIATIVE EFFECTS C ------------------------------------------------------------- C (JAPAN) MEISEI RS2-80 C =====> JTYPE = 22 -- ITAB = 1 <===== C -- OR -- C (JAPAN) MEISEI RS2-91 C =====> JTYPE = 47 -- ITAB = 1 <===== DATA JAPANT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ C LEVEL 1 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 3 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4 0.0, 0.0, 3.0, 0.0, 1.0, 2.0, 2.0, 2.0, 3.0, 0.0, 5 0.0, 0.0, 0.0, 2.0, 3.0, 3.0, 4.0, 5.0, 7.0, 0.0, A 0.0, 0.0, 0.0, 3.0, 3.0, 3.0, 4.0, 5.0, 6.0, 0.0, 6 0.0, 0.0, 0.0, 6.0, 4.0, 3.0, 4.0, 5.0, 6.0, 0.0, B 0.0, 0.0, 0.0, 5.0, 4.0, 4.0, 4.0, 4.0, 5.0, 0.0, 7 0.0, 0.0, 0.0, 4.0, 6.0, 6.0, 4.0, 4.0, 5.0, 0.0, C 0.0, 0.0, 0.0, 5.0, 6.0, 6.0, 5.0, 5.0, 4.0, 0.0, 8 0.0, 0.0, 0.0, 7.0, 8.0, 7.0, 8.0, 8.0, 4.0, 0.0, D 0.0, 0.0, 0.0, 10.0, 10.0, 8.0, 8.0, 8.0, 2.0, 0.0, 9 0.0, 0.0, 0.0, 13.0, 12.0, 10.0, 8.0, 9.0, 2.0, 1.0, $ 0.0, 0.0, 0.0, 26.0, 19.0, 16.0, 12.0, 11.0, 10.0, -5.0, T 0.0, 0.0, 0.0, 33.0, 30.0, 28.0, 19.0, 13.0, 14.0,-10.0, L 0.0, 0.0, 0.0, 43.0, 41.0, 35.0, 16.0, 18.0, 14.0, 0.0/ C (CANADA) SANGAMO -- SAME CORRECTIONS AS VIZ-A C =====> JTYPE = 31 -- ITAB = 2 <===== DATA CANADT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C ___ ___ ___ ___ ___ ___ ___ ___ ___ ___ C LEVEL 1 0.2, 0.2, 0.2, 0.8, 0.8, 0.9, 0.9, 0.9, 0.9, 0.9, 2 -0.1, -0.1, 0.3, 1.1, 1.1, 1.2, 1.3, 1.3, 1.3, 1.3, 3 -0.3, -0.3, 0.3, 1.3, 1.3, 1.5, 1.7, 1.7, 1.7, 1.7, 4 -0.5, -0.5, 0.6, 1.9, 1.9, 2.0, 2.0, 2.0, 2.0, 2.0, 5 -0.6, -0.6, 1.3, 2.9, 2.9, 2.7, 2.5, 2.5, 2.5, 2.5, A -0.5, -0.5, 1.7, 3.7, 3.7, 3.3, 2.8, 2.8, 2.8, 2.8, 6 -0.2, -0.2, 2.4, 4.3, 4.3, 3.8, 3.3, 3.3, 3.3, 3.3, B 0.1, 0.1, 3.1, 4.8, 4.8, 4.5, 4.3, 4.3, 4.3, 4.3, 7 0.1, 0.1, 3.7, 5.2, 5.2, 5.4, 5.6, 5.6, 5.6, 5.6, C -0.2, -0.2, 4.4, 6.0, 6.0, 6.5, 7.1, 7.1, 7.1, 7.1, 8 -0.7, -0.7, 5.5, 7.2, 7.2, 7.6, 8.1, 8.1, 8.1, 8.1, D -1.5, -1.5, 6.3, 8.4, 8.4, 8.6, 8.9, 8.9, 8.9, 8.9, 9 -2.3, -2.3, 6.1, 9.2, 9.2, 9.3, 9.5, 9.5, 9.5, 9.5, $ -3.3, -3.3, 5.8, 10.2, 10.2, 10.0, 9.9, 9.9, 9.9, 9.9, T -4.8, -4.8, 5.4, 10.7, 10.7, 10.2, 9.8, 9.8, 9.8, 9.8, L -10.6,-10.6, 3.8, 11.8, 11.8, 10.5, 9.3, 9.3, 9.3, 9.3/ C (U.S.) NOAA / VIZ TYPE A -- BASED ON SCHMIDLIN C =====> JTYPE = 10 -- ITAB = 3 <===== C -- OR -- C (U.S.) NOAA / VIZ TYPE B -- BASED ON SCHMIDLIN C =====> JTYPE = 11 -- ITAB = 3 <===== C -- OR -- C AIR IS - 4A - 1680 -- BASED ON SCHMIDLIN C =====> JTYPE = 43 -- ITAB = 3 <===== C -- OR -- C AIR IS - 4A - 1680 X -- BASED ON SCHMIDLIN C =====> JTYPE = 44 -- ITAB = 3 <===== DATA USVZAT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0.2, 0.2, 0.2, 0.8, 0.8, 0.9, 0.9, 0.9, 0.9, 0.9, 2 -0.1, -0.1, 0.3, 1.1, 1.1, 1.2, 1.3, 1.3, 1.3, 1.3, 3 -0.3, -0.3, 0.3, 1.3, 1.3, 1.5, 1.7, 1.7, 1.7, 1.7, 4 -0.5, -0.5, 0.6, 1.9, 1.9, 2.0, 2.0, 2.0, 2.0, 2.0, 5 -0.6, -0.6, 1.3, 2.9, 2.9, 2.7, 2.5, 2.5, 2.5, 2.5, A -0.5, -0.5, 1.7, 3.7, 3.7, 3.3, 2.8, 2.8, 2.8, 2.8, 6 -0.2, -0.2, 2.4, 4.3, 4.3, 3.8, 3.3, 3.3, 3.3, 3.3, B 0.1, 0.1, 3.1, 4.8, 4.8, 4.5, 4.3, 4.3, 4.3, 4.3, 7 0.1, 0.1, 3.7, 5.2, 5.2, 5.4, 5.6, 5.6, 5.6, 5.6, C -0.2, -0.2, 4.4, 6.0, 6.0, 6.5, 7.1, 7.1, 7.1, 7.1, 8 -0.7, -0.7, 5.5, 7.2, 7.2, 7.6, 8.1, 8.1, 8.1, 8.1, D -1.5, -1.5, 6.3, 8.4, 8.4, 8.6, 8.9, 8.9, 8.9, 8.9, 9 -2.3, -2.3, 6.1, 9.2, 9.2, 9.3, 9.5, 9.5, 9.5, 9.5, $ -3.3, -3.3, 5.8, 10.2, 10.2, 10.0, 9.9, 9.9, 9.9, 9.9, T -4.8, -4.8, 5.4, 10.7, 10.7, 10.2, 9.8, 9.8, 9.8, 9.8, L -10.6,-10.6, 3.8, 11.8, 11.8, 10.5, 9.3, 9.3, 9.3, 9.3/ C (U.S.) NOAA / SPACE DATA CORP. C =====> JTYPE = 12 -- ITAB = 4 <===== C -- OR -- C (U.S.) MSS SOLID STATE SDC 1680 MHZ C =====> JTYPE = 45 -- ITAB = 4 <===== DATA USSDCT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 -2.4, -2.4, -2.3, -2.1, -1.8, -1.5, -1.2, -1.2, -1.2, -1.2, 2 -2.6, -2.6, -2.2, -1.8, -1.4, -1.0, -0.5, -0.5, -0.5, -0.5, 3 -2.8, -2.8, -2.1, -1.4, -1.0, -0.4, 0.2, 0.2, 0.2, 0.2, 4 -2.8, -2.8, -1.7, 0.2, 0.8, 1.3, 1.6, 1.6, 1.6, 1.6, 5 -1.3, -1.3, 1.1, 3.5, 3.8, 4.1, 4.5, 4.5, 4.5, 4.5, A 0.7, 0.7, 3.0, 6.0, 6.2, 6.4, 6.7, 6.7, 6.7, 6.7, 6 2.8, 2.8, 6.5, 9.1, 9.4, 9.7, 9.9, 9.9, 9.9, 9.9, B 3.8, 3.8, 7.9, 11.4, 11.8, 12.1, 12.4, 12.4, 12.4, 12.4, 7 4.9, 4.9, 9.1, 13.7, 14.2, 14.6, 14.8, 14.8, 14.8, 14.8, C 4.9, 4.9, 10.9, 16.0, 16.6, 16.8, 17.1, 17.1, 17.1, 17.1, 8 4.7, 4.7, 11.0, 17.2, 18.4, 18.8, 19.1, 19.1, 19.1, 19.1, D 4.3, 4.3, 12.2, 19.4, 20.5, 20.7, 21.9, 21.9, 21.9, 21.9, 9 3.9, 3.9, 14.0, 21.2, 22.2, 23.4, 24.5, 24.5, 24.5, 25.5, $ 3.1, 3.1, 17.4, 23.2, 23.5, 24.4, 25.9, 25.9, 25.9, 25.9, T 1.7, 1.7, 14.7, 24.7, 25.5, 26.2, 26.8, 26.8, 26.8, 26.8, L -4.0, -4.0, 12.0, 25.8, 26.6, 27.7, 28.3, 28.3, 28.3, 28.3/ C VAISALA RS80 -- NON-U.S. SITES C =====> JTYPE = 37 -- ITAB = 5 <===== C -- OR -- C VAISALA RS80/MICROCORA -- NON-U.S. SITES C =====> JTYPE = 60 -- ITAB = 5 <===== C -- OR -- C VAISALA RS80/DIGICORA OR MARWIN -- NON-U.S. SITES C =====> JTYPE = 61 -- ITAB = 5 <===== C -- OR -- C VAISALA RS80/PCCORA -- NON-U.S. SITES C =====> JTYPE = 62 -- ITAB = 5 <===== C -- OR -- C VAISALA RS80/STAR -- NON-U.S. SITES C =====> JTYPE = 63 -- ITAB = 5 <===== DATA VRS80T / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 2.0, 2.0, 0.0, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 2 1.0, 1.0, 0.5, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 3 0.0, 0.0, 1.0, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 4 1.0, 1.0, 2.0, 3.0, 3.0, 1.5, 0.0, 0.0, 0.0, 0.0, 5 1.0, 1.0, 2.0, 1.0, 1.0, 0.5, 0.0, 0.0, 0.0, 0.0, A 2.0, 2.0, 4.0, 1.0, 1.0, 0.0, -1.0, -1.0, -1.0, -1.0, 6 4.0, 4.0, 5.0, 3.0, 3.0, 2.0, 1.0, 1.0, 1.0, 1.0, B 6.0, 6.0, 7.0, 4.0, 4.0, 3.5, 3.0, 3.0, 3.0, 3.0, 7 5.0, 5.0, 5.0, 5.0, 5.0, 4.5, 4.0, 4.0, 4.0, 4.0, C 5.0, 5.0, 6.0, 3.0, 3.0, 3.5, 4.0, 4.0, 4.0, 4.0, 8 5.0, 5.0, 6.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, D 4.0, 4.0, 7.0, 3.0, 3.0, 2.5, 2.0, 2.0, 2.0, 2.0, 9 6.0, 6.0, 4.0, -1.0, -1.0, 1.0, 3.0, 3.0, 3.0, 3.0, $ 7.0, 7.0, 3.0, -2.0, -2.0, -1.0, 0.0, 0.0, 0.0, 0.0, T 11.0, 11.0, 3.0, -2.0, -2.0, -1.5, -1.0, -1.0, -1.0, -1.0, L 20.0, 20.0, 15.0, 11.0, 11.0, 9.0, 7.0, 7.0, 7.0, 7.0/ C (GERMANY) GRAW M60 -- BASED ON SCHMIDLIN C =====> JTYPE = 19 -- ITAB = 6 <===== DATA GRM60T / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 -5.0, -5.0, -2.0, 0.0, 0.0, 1.5, 3.0, 3.0, 3.0, 3.0, 2 -1.0, -1.0, -1.5, 0.5, 0.5, 1.5, 2.5, 2.5, 2.5, 2.5, 3 3.0, 3.0, -1.0, 1.0, 1.0, 1.5, 2.0, 2.0, 2.0, 2.0, 4 4.0, 4.0, 0.0, -2.0, -2.0, -1.5, -1.0, -1.0, -1.0, -1.0, 5 2.0, 2.0, 3.0, 4.0, 4.0, 2.5, 1.0, 1.0, 1.0, 1.0, A 2.0, 2.0, 6.0, 3.0, 3.0, 2.0, 1.0, 1.0, 1.0, 1.0, 6 6.0, 6.0, 8.0, 8.0, 8.0, 5.0, 3.0, 3.0, 3.0, 3.0, B 8.0, 8.0, 8.0, 9.0, 9.0, 6.0, 3.0, 3.0, 3.0, 3.0, 7 8.0, 8.0, 8.0, 5.0, 5.0, 4.5, 4.0, 4.0, 4.0, 4.0, C 5.0, 5.0, 7.0, 1.0, 1.0, 3.5, 6.0, 6.0, 6.0, 6.0, 8 3.0, 3.0, 8.0, 9.0, 9.0, 7.5, 6.0, 6.0, 6.0, 6.0, D 1.0, 1.0, 9.0, 5.0, 5.0, 7.5, 10.0, 10.0, 10.0, 10.0, 9 2.0, 2.0, 1.0, 2.0, 3.0, 5.0, 9.0, 9.0, 9.0, 9.0, $ -6.0, -6.0,-11.0, -8.0, -5.0, 0.0, 4.0, 4.0, 4.0, 4.0, T -3.0, -3.0,-15.0,-10.0, -7.5, -5.0, 0.0, 0.0, 0.0, 0.0, L -3.0, -3.0,-99.0,-75.0,-50.0,-35.0,-27.0,-27.0,-27.0,-27.0/ C (USSR) METEORITE A22IV -- AVERAGED FROM PREVIOUS TABLES C =====> JTYPE = 27 -- ITAB = 7 <===== DATA A22IVT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 3 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, A 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 6 0.0, 0.0, 2.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, B 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, 0.0, 0.0, 0.0, 0.0, 7 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, 1.0, 0.0, 0.0, 0.0, C 0.0, 0.0, 2.0, 3.0, 3.0, 3.0, 2.0, 0.0, 0.0, 0.0, 8 0.0, 0.0, 3.0, 4.0, 4.0, 5.0, 3.0, 1.0, 0.0, 0.0, D 0.0, 0.0, 3.0, 4.0, 5.0, 7.0, 5.0, 3.0, 0.0, 0.0, 9 0.0, 0.0, 4.0, 6.0, 6.0, 8.0, 6.0, 4.0, 0.0, 0.0, $ 0.0, 0.0, 4.0, 7.0, 7.0, 8.0, 6.0, 6.0, 0.0, 0.0, T 0.0, 0.0, 5.0, 10.0, 5.0, 11.0, 11.0, 6.0, 0.0, 0.0, L 0.0, 0.0, 6.0, 22.0, 16.0, 11.5, 11.3, 11.0, 0.0, 0.0/ C (USSR) METEORITE MARZ2-1 -- AVERAGED FROM PREVIOUS TABLES C =====> JTYPE = 28 -- ITAB = 8 <===== C -- OR -- C (USSR) METEORITE MARZ2-2 -- AVERAGED FROM PREVIOUS TABLES C =====> JTYPE = 29 -- ITAB = 8 <===== DATA MARZ2T / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 2 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 3 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 4 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 5 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, A 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 6 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, B 0.0, 0.0, 2.0, 2.0, 2.0, 1.0, 0.0, 0.0, 0.0, 0.0, 7 0.0, 0.0, 2.0, 2.0, 2.0, 1.0, 0.0, 0.0, 0.0, 0.0, C 0.0, 0.0, 3.5, 3.0, 2.5, 1.0, 0.5, 0.0, 0.0, 0.0, 8 0.0, 1.0, 4.0, 4.0, 2.5, 1.0, 0.5, 0.0, 0.0, 0.0, D 0.0, 2.0, 4.5, 4.5, 2.5, 1.0, 0.5, 0.0, 0.0, 0.0, 9 0.0, 3.0, 6.0, 6.0, 3.5, 1.5, 1.0, 0.0, 0.0, 0.0, $ 0.0, 4.0, 8.5, 7.5, 5.0, 2.5, 1.0, 0.0, 0.0, 0.0, T 0.0, 5.0, 10.0, 10.0, 6.0, 4.5, 1.0, 0.0, 0.0, 0.0, L 0.0, 11.0, 22.0, 17.0, 11.5, 10.5, 2.0, 1.0, 0.0, 0.0/ C UK MET OFFICE MK3 -- BASED ON SCHMIDLIN C (CURRENTLY NOT IN USE -- UK STATIONS USE VAISALA SONDE) C =====> JTYPE = 33 -- ITAB = 9 <===== DATA UKMK3T / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 3.0, 3.0, -4.0, -3.0, -3.0, -4.0, -6.0, -6.0, -6.0, -6.0, 2 0.5, 0.5, -4.0, -2.0, -2.0, -3.0, -4.5, -4.5, -4.5, -4.5, 3 -2.0, -2.0, -4.0, -1.0, -1.0, -2.0, -3.0, -3.0, -3.0, -3.0, 4 -1.0, -1.0, 1.0, 0.0, 0.0, -1.0, -2.0, -2.0, -2.0, -2.0, 5 0.0, 0.0, -2.0, 0.0, 0.0, -1.0, -3.0, -3.0, -3.0, -3.0, A -1.0, -1.0, 0.0, 0.0, 0.0, -1.0, -3.0, -3.0, -3.0, -3.0, 6 -1.0, -1.0, 0.0, 1.0, 1.0, 0.0, -2.0, -2.0, -2.0, -2.0, B 0.0, 0.0, 2.0, 3.0, 3.0, 1.0, -1.0, -1.0, -1.0, -1.0, 7 0.0, 0.0, 1.0, 2.0, 2.0, 1.0, 1.0, 1.0, 1.0, 1.0, C 0.0, 0.0, 2.0, 2.0, 2.0, 1.0, 1.0, 1.0, 1.0, 1.0, 8 0.0, 0.0, 2.0, 1.0, 1.0, 1.0, 2.0, 2.0, 2.0, 2.0, D 0.0, 0.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 9 0.0, 0.0, 3.0, 5.0, 5.0, 3.0, 2.0, 2.0, 2.0, 2.0, $ 1.0, 1.0, 2.0, 4.0, 4.0, 3.0, 2.0, 2.0, 2.0, 2.0, T 3.0, 3.0, 3.0, 5.0, 5.0, 3.0, 1.0, 1.0, 1.0, 1.0, L 6.0, 6.0, 11.0, 11.0, 11.0, 10.0, 10.0, 10.0, 10.0, 10.0/ C (CHINA) SHANGHAI RADIO -- BASED ON JULIAN C =====> JTYPE = 32 -- ITAB = 10 <===== DATA SHANGT / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0.5, 0.3, 0.0, 0.4, 0.5, 0.9, 0.9, 0.9, 0.9, 0.9, 2 0.5, 0.6, 1.0, 1.2, 1.0, 0.9, 0.9, 0.9, 0.9, 0.9, 3 0.5, 0.9, 1.9, 2.0, 1.5, 0.9, 0.9, 0.9, 0.9, 0.9, 4 -0.1, 1.9, 2.6, 2.7, 1.8, 1.8, 1.8, 1.9, 1.9, 1.9, 5 1.2, 5.5, 6.3, 6.0, 4.9, 4.1, 4.1, 4.1, 4.2, 4.2, A 4.7, 8.8, 9.8, 9.7, 9.1, 9.0, 9.0, 9.0, 9.0, 9.0, 6 10.3, 13.7, 14.2, 14.7, 15.2, 16.0, 16.0, 16.0, 16.0, 16.0, B 13.7, 15.3, 16.4, 17.2, 18.5, 19.9, 19.9, 19.9, 19.9, 19.9, 7 16.7, 17.4, 18.0, 18.9, 21.1, 22.8, 22.8, 22.8, 22.8, 22.8, C 17.4, 17.2, 17.1, 17.6, 20.3, 22.0, 22.0, 22.0, 22.0, 22.0, 8 8.7, 8.3, 8.1, 6.0, 7.6, 7.4, 7.4, 7.4, 7.4, 7.4, D -11.5,-10.1,- 9.1,-13.9,-13.4,-13.2,-13.2,-13.2,-13.2,-13.2, 9 - 9.0,-12.6,-13.3,-20.3,-18.9,-18.9,-18.9,-18.9,-18.9,-18.9, $ 1.8,- 6.7,- 7.4,-15.3,-15.0,-17.0,-17.1,-17.1,-17.1,-17.1, T 11.4, 5.0, 2.0,- 5.0,- 6.4,-10.0,-10.0,-10.0,-10.0,-10.0, L 16.6, 13.5, 12.1, 8.5, 5.7, 4.0, 4.0, 4.0, 4.0, 4.0/ C VAISALA RS80 -- U.S. SITES C =====> JTYPE = 37 -- ITAB = 11 <===== C -- OR -- C VAISALA RS80/MICROCORA -- U.S. SITES C =====> JTYPE = 60 -- ITAB = 11 <===== C -- OR -- C VAISALA RS80/DIGICORA OR MARWIN -- U.S. SITES C =====> JTYPE = 61 -- ITAB = 11 <===== C -- OR -- C VAISALA RS80/PCCORA -- U.S. SITES C =====> JTYPE = 62 -- ITAB = 11 <===== C -- OR -- C VAISALA RS80/STAR -- U.S. SITES C =====> JTYPE = 63 -- ITAB = 11 <===== DATA VRS80U / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 2.0, 2.0, 0.0, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 2 1.0, 1.0, 0.5, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 3 0.0, 0.0, 1.0, 2.0, 2.0, 1.5, 1.0, 1.0, 1.0, 1.0, 4 1.0, 1.0, 2.0, 3.0, 3.0, 1.5, 0.0, 0.0, 0.0, 0.0, 5 1.0, 1.0, 2.0, 1.0, 1.0, 0.5, 0.0, 0.0, 0.0, 0.0, A 2.0, 2.0, 4.0, 1.0, 1.0, 0.0, -1.0, -1.0, -1.0, -1.0, 6 4.0, 4.0, 5.0, 3.0, 3.0, 2.0, 1.0, 1.0, 1.0, 1.0, B 6.0, 6.0, 7.0, 4.0, 4.0, 3.5, 3.0, 3.0, 3.0, 3.0, 7 5.0, 5.0, 5.0, 5.0, 5.0, 4.5, 4.0, 4.0, 4.0, 4.0, C 5.0, 5.0, 6.0, 3.0, 3.0, 3.5, 4.0, 4.0, 4.0, 4.0, 8 5.0, 5.0, 6.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, D 4.0, 4.0, 7.0, 3.0, 3.0, 2.5, 2.0, 2.0, 2.0, 2.0, 9 6.0, 6.0, 4.0, -1.0, -1.0, 1.0, 3.0, 3.0, 3.0, 3.0, $ 4.0, 4.0, 2.0, -2.0, -2.0, -1.0, 0.0, 0.0, 0.0, 0.0, T 7.0, 7.0, 2.0, -2.0, -2.0, -1.5, -1.0, -1.0, -1.0, -1.0, L 13.0, 13.0, 13.0, 11.0, 11.0, 9.0, 7.0, 7.0, 7.0, 7.0/ C GEOPOTENTIAL CORRECTION TABLES (METERS) FOR RADIATIVE EFFECTS C AND INCORRECT GRAVITY CONSTANT IN MICROARTS C ------------------------------------------------------------- C (U.S.) NOAA / VIZ TYPE A -- BASED ON SCHMIDLIN C =====> JTYPE = 10 -- JTAB = 1 <===== C -- OR -- C (U.S.) NOAA / VIZ TYPE B -- BASED ON SCHMIDLIN C =====> JTYPE = 11 -- JTAB = 1 <===== DATA USVZAG / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 1., 1., 1., 1., 1., 1., 1., 3 1., 1., 1., 2., 2., 2., 2., 2., 2., 2., 4 2., 2., 3., 4., 4., 4., 4., 4., 4., 4., 5 3., 3., 5., 8., 8., 8., 8., 8., 8., 8., A 4., 4., 7., 11., 11., 11., 11., 11., 11., 11., 6 5., 5., 10., 16., 16., 16., 15., 15., 15., 15., B 6., 6., 13., 19., 19., 18., 17., 17., 17., 17., 7 7., 7., 16., 23., 23., 22., 21., 21., 21., 21., C 8., 8., 20., 29., 29., 29., 28., 28., 28., 28., 8 9., 9., 28., 39., 39., 39., 39., 39., 39., 39., D 9., 9., 36., 48., 48., 48., 49., 49., 49., 49., 9 9., 9., 43., 58., 59., 59., 60., 60., 60., 60., $ 7., 7., 54., 75., 75., 75., 76., 76., 76., 76., T 4., 4., 63., 89., 89., 89., 90., 90., 90., 90., L -9., -9., 75., 115., 115., 113., 112., 112., 112., 110./ C (U.S.) NOAA / SPACE DATA CORP. -- BASED ON SCHMIDLIN/AHNERT C =====> JTYPE = 12 -- JTAB = 2 <===== DATA USSDCG / C NITE -5 5 15 25 35 45 55 65 75 S.ANG C _____ _____ _____ _____ _____ _____ _____ _____ _____ _____ C LEVEL 1 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 2 0., 0., 0., 0., 0., 0., 0., 0., 0., 0., 3 0., 0., 0., 1., 1., 1., 1., 1., 1., 1., 4 0., 0., 1., 1., 2., 3., 3., 3., 3., 3., 5 -1., -1., 3., 5., 6., 7., 7., 7., 7., 7., A 0., 0., 4., 9., 11., 11., 12., 12., 12., 12., 6 3., 3., 10., 17., 18., 19., 21., 21., 21., 21., B 5., 5., 13., 23., 25., 26., 27., 27., 27., 27., 7 9., 9., 16., 32., 33., 35., 37., 37., 37., 37., C 14., 14., 25., 46., 48., 50., 52., 52., 52., 52., 8 21., 21., 38., 67., 69., 72., 75., 75., 75., 75., D 27., 27., 56., 87., 90., 94., 98., 98., 98., 98., 9 33., 33., 85., 108., 113., 117., 122., 122., 122., 122., $ 41., 41., 94., 144., 152., 157., 162., 162., 162., 162., T 45., 45., 123., 175., 182., 189., 195., 162., 162., 162., L 46., 46., 155., 230., 236., 247., 256., 256., 256., 256./ DATA BMISS/10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C EACH TIME THROUGH, COMPUTE LOGS OF PRESSURE RATIOS C -------------------------------------------------- ALP(1) = 0.0 DO I=2,16 ALP(I) = ALOG(PRES(I-1)/PRES(I)) ENDDO C INTERPOLATE SOLAR ELEVATION ANGLES AT MANDATORY LEVELS C (DUE TO DELTA TIME IN BALLOON REACHING MANDATORY LEVELS) C ---------------------------------------------------------------- SUNBA = SUN(2) - SUN(1) C NOTE: SOLAR(1)-SOLAR(3) ARE CRUDE ESTIMATE AT 1000, 925 & 850 MB C (BASED ON RATIO OF HIGHER LEVEL VALUES TO DIFFERENCES IN C REFERENCE HEIGHT) SOLAR(1 ) = SUN(1) - (.0826254 * SUNBA) SOLAR(2 ) = SUN(1) - (.0647634 * SUNBA) SOLAR(3 ) = SUN(1) - (.0456353 * SUNBA) SOLAR(4 ) = SUN(1) SOLAR(5 ) = SUN(1) + (.0791979 * SUNBA) SOLAR(6 ) = SUN(1) + (.1317209 * SUNBA) SOLAR(7 ) = SUN(1) + (.1994348 * SUNBA) SOLAR(8 ) = SUN(1) + (.2423491 * SUNBA) SOLAR(9 ) = SUN(1) + (.2948721 * SUNBA) SOLAR(10) = SUN(1) + (.3625860 * SUNBA) SOLAR(11) = SUN(1) + (.4580233 * SUNBA) SOLAR(12) = SUN(1) + (.5419766 * SUNBA) SOLAR(13) = SUN(1) + (.6211745 * SUNBA) SOLAR(14) = SUN(1) + (.7414114 * SUNBA) SOLAR(15) = SUN(1) + (.8308487 * SUNBA) SOLAR(16) = SUN(2) C GET TABLE INDEX FROM INSTRUMENT TYPE C (GEOPOTENTIAL CORRECTION TABLE JTAB ONLY VALID PRIOR TO 00Z 10/1/93) C -------------------------------------------------------------------- ITAB = 0 JTAB = 0 IF(JTYPE.GT.0.AND.JTYPE.LT.100) THEN ITAB = ITYPTT(JTYPE) IF(ITAB.EQ.5.AND.(SID(1:1).EQ.'W'.OR.SID(1:2).EQ.'70'.OR. $ SID(1:2).EQ.'72'.OR.SID(1:2).EQ.'74'.OR.SID.EQ.'89009 '.OR. $ SID.EQ.'89664 '.OR.SID.EQ.'91285 '.OR.(SID(1:5).GT.'91065' $ .AND.SID(1:5).LT.'91190'))) ITAB = 11 IF(ITAB.EQ.11) PRINT *, '+++++ A U.S. VAISALA AT STNID :',SID IF(HGTTBL) JTAB = ITYPTG(JTYPE) ENDIF C CHECK FOR VALID CORRECTION PARAMETERS C ------------------------------------- IF( JTYPE.LE.8 .OR. JTYPE.EQ.18 .OR. . (JTYPE.GE.48 .AND. JTYPE.LE.59) .OR. . (JTYPE.GE.64 .AND. JTYPE.LT.99) ) PRINT1,SID,JTYPE 1 FORMAT(/,5X,'* * * STN. ID ',A8,' HAS AN INVALID INSTR. ', . 'TYPE DESIGNATION (BUFR/ON29 CODE ',I3,') - NO CORRECTION ', . 'POSSIBLE') IF(JTYPE.LT.1.OR.JTYPE.GE.64.OR.ITAB.LE.0) THEN IRET = -1 RETURN ENDIF C APPLY TEMPERATURE AND HEIGHT CORRECTIONS C ---------------------------------------- DO ILEV=1,16 ANGLE(2) = CUTOFF(ILEV) DTS(ILEV) = 0 DHS(ILEV) = 0 DTL = 0 DHL = 0 IF(SOLAR(ILEV).GE.CUTOFF(ILEV)) THEN IF(SOLAR(ILEV).LT.ANGLE(10)) THEN DO K=3,10 IF(SOLAR(ILEV).LT.ANGLE(K)) THEN TABU = TTAB(K ,ILEV,ITAB) TABD = TTAB(K-1,ILEV,ITAB) DSUN=(SOLAR(ILEV)-ANGLE(K-1))/(ANGLE(K)-ANGLE(K-1)) DTS(ILEV) = TABD + DSUN*(TABU-TABD) IF(JTAB.GT.0) THEN TABU = ZTAB(K ,ILEV,JTAB) TABD = ZTAB(K-1,ILEV,JTAB) DHS(ILEV) = TABD + DSUN*(TABU-TABD) ENDIF GO TO 10 ENDIF ENDDO ELSE DTS(ILEV) = TTAB(10,ILEV,ITAB) IF(JTAB.GT.0) DHS(ILEV) = ZTAB(10,ILEV,JTAB) ENDIF ELSE C IF ANGLE < CUTOFF (NIGHT), CORRECTION FROM 'NIGHT' VALUE IN TBL C -------------------------------------------------------------------- DTS(ILEV) = TTAB(1,ILEV,ITAB) IF(JTAB.GT.0) DHS(ILEV) = ZTAB(1,ILEV,JTAB) ENDIF C IF JTAB IS ZERO, COMPUTE HEIGHT CORRECTIONS VIA HYDROSTATIC INTERP. C ------------------------------------------------------------------- 10 IF(JTAB.LE.0) THEN HYF = 1.46*ALP(ILEV) IF(ILEV.EQ.1) THEN DHS(ILEV) = HYF*DTS(ILEV) ELSE DHS(ILEV) = DHS(ILEV-1) + HYF*(10.*DTS(ILEV-1)+DTS(ILEV)) ENDIF ENDIF C CORRECT DTS BY A FACTOR OF 10 C ----------------------------- DTS(ILEV) = .1*DTS(ILEV) C SAVE AND APPLY THE CORRECTIONS C ------------------------------ DHT(ILEV) = DHL - DHS(ILEV) DTP(ILEV) = DTL - DTS(ILEV) IF(HGT(ILEV).LT.BMISS) HGT(ILEV) = HGT(ILEV) + DHT(ILEV) IF(TMP(ILEV).LT.BMISS) TMP(ILEV) = TMP(ILEV) + DTP(ILEV) ENDDO RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RSTATS ACCUMS STATS FOR INTERSONDE CORRECTIONS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 90-12-07 C C ABSTRACT: ACCUMULATES STATISTICS INCLUDING BIAS, RMS AND MAXIMUM C DIFFERENCE FOR EACH UNCORRECTED VS. CORRECTED "ADPUPA" MASS C REPORT'S HEIGHT OR TEMPERATURE ON ALL MANDATORY PRESSURE LEVELS. C ENTRY LSTATS COMPUTES THE THE ABOVE STATISTICS FOR PRINT OUTPUT. C C PROGRAM HISTORY LOG: C UNKNOWN G. D. DIMEGO C 90-12-06 D. A. KEYSER -- CONVERTED TO VS FORTRAN(77) AND C RESTRUCTURED; COMBINED OLD SUBR. RSTATS AND TSTATS WHICH DID C HGHT AND TEMP. CALC. SEPARATELY C C USAGE: CALL RSTATS(IVAR,ZIN,ZOUT,XI,YJ,KP) C INPUT ARGUMENT LIST: C IVAR - INTEGER INDICATING VARIABLE FOR WHICH STATS ARE C - GENERATED (=1-HEIGHT; =2-TEMPERATURE) C ZIN - REAL UNCORRECTED VARIABLE {HGHT(M), TEMP(*10 DEG. C)} C ZOUT - REAL CORRECTED VARIABLE {HGHT(M), TEMP(*10 DEG. C)} C XI - REAL STATION LONGITUDE (DEG. WEST *100) C YJ - REAL STATION LATITUDE (DEG. NORTH *100) C KP - INTEGER MANDATORY PRESSURE LEVEL (MB) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE "RADEVN". ENTRY LSTATS CALLED BY C SUBROUTINE "DMA22". C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE RSTATS(IVAR,ZIN,ZOUT,XI,YJ,KP) LOGICAL INIT(2) REAL STATS(8,21,2) INTEGER IMAX(21,2),JMAX(21,2),IPMAND(21) C-CRA COMMON /SWITCH/ LWCORR,LEVRAD,IRCTBL,HGTTBL COMMON /SWITCH / HGTTBL COMMON /SWITCHI/ LWCORR,LEVRAD,IRCTBL DATA INIT/2*.TRUE./,IPMAND/1000,925,850,700,500,400,300,250,200, $ 150,100,70,50,30,20,10,7,5,3,2,1/ IF(INIT(IVAR)) THEN C FIRST TIME THRU SET ALL STATISTICAL VARIABLES TO ZERO C ----------------------------------------------------- DO J=1,21 IMAX(J,IVAR) = 0.0 JMAX(J,IVAR) = 0.0 DO I=1,8 STATS(I,J,IVAR) = 0.0 ENDDO ENDDO INIT(IVAR) = .FALSE. END IF DO I=1,21 K = I IF(KP.GE.IPMAND(I)) GO TO 11 ENDDO 11 CONTINUE C ACCUMULATE COUNT AND VARIOUS SUMS C --------------------------------- ZDIF = ZOUT - ZIN STATS(8,K,IVAR) = STATS(8,K,IVAR) + 1. STATS(1,K,IVAR) = STATS(1,K,IVAR) + ZIN STATS(2,K,IVAR) = STATS(2,K,IVAR) + ZOUT STATS(3,K,IVAR) = STATS(3,K,IVAR) + ZDIF STATS(4,K,IVAR) = STATS(4,K,IVAR) + (ZIN * ZIN) STATS(5,K,IVAR) = STATS(5,K,IVAR) + (ZOUT * ZOUT) STATS(6,K,IVAR) = STATS(6,K,IVAR) + (ZDIF * ZDIF) C FIND REPORT WITH MAXIMUM DIFFERENCE C ----------------------------------- IF(ABS(ZDIF).GT.STATS(7,K,IVAR)) THEN STATS(7,K,IVAR) = ABS(ZDIF) IMAX(K,IVAR) = REAL(XI) JMAX(K,IVAR) = REAL(YJ) ENDIF RETURN C COMPUTE AND PRINT OUT STATISTICS -- ENTRY LSTATS C ------------------------------------------------ ENTRY LSTATS(IVAR) IF(IVAR.EQ.1) THEN PRINT 20 SCALE = 1.0 ELSE PRINT 920 SCALE = 10.0 ENDIF DO K=1,21 COUNT = AMAX1(1.0,STATS(8,K,IVAR)) COUNT = 1.0/COUNT DO I=1,3 STATS(I,K,IVAR) = (STATS(I,K,IVAR) * COUNT)/SCALE STATS(I+3,K,IVAR) = (SQRT(STATS(I+3,K,IVAR) * COUNT))/SCALE ENDDO STATS(7,K,IVAR) = STATS(7,K,IVAR)/SCALE ENDDO DO K=21,1,-1 IF(K.GE.LEVRAD) THEN KNT = IFIX(STATS(8,K,IVAR)) PRINT 30, KNT,IPMAND(K),(STATS(I,K,IVAR),I=1,3), $ (STATS(I,K,IVAR),I=6,7),IMAX(K,IVAR),JMAX(K,IVAR) ENDIF ENDDO RETURN 20 FORMAT(//27X,'***** STATISTICAL ANALYSIS BY PRESSURE FOR INTERSO', $ 'NDE HEIGHT CORRECTIONS *****'//3X,'COUNT',5X,'PRESSURE',3X,'UN', $ 'CORR. MEAN',3X,'CORRECTED MEAN',7X,'BIAS',12X,'RMS',10X,'MAXDI', $ 'F',4X,'AT',4X,'LON*100',8X,'LAT*100',/,15X,'(MB)',11X,'(M)',12X, $ '(M)',13X,'(M)',12X,'(M)',12X,'(M)',10X,'(DEG. W)',7X,'(DEG. N)') 920 FORMAT(//24X,'***** STATISTICAL ANALYSIS BY PRESSURE FOR INTERSO', $ 'NDE TEMPERATURE CORRECTIONS *****',//,3X,'COUNT',5X,'PRESSURE', $ 3X,'UNCORR. MEAN',3X,'CORRECTED MEAN',7X,'BIAS',12X,'RMS',10X, $ 'MAXDIF',4X,'AT',4X,'LON*100',8X,'LAT*100', $ /,15X,'(MB)',8X,'(DEG. C)',7X,'(DEG. C)',8X,'(DEG. C)', $ 7X,'(DEG. C)',7X,'(DEG. C)',8X,'(DEG. W)',7X,'(DEG. N)') 30 FORMAT(I7,5X,I6,7X,5(F10.3,5X),3X,2(I7,8X)) END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TAB COUNTS INSTRUMENT TYPES FOR "ADPUPA" MASS C PRGMMR: D. A. KEYSER ORG: W/NMC22 DATE: 90-12-06 C C ABSTRACT: ACCUMULATES DATA COUNTS FOR ALL "ADPUPA" MASS INSTRUMENT C TYPES. ALSO ACCUMULATES DATA COUNTS FOR ALL INSTRUMENT TYPES C LUMPED TOGETHER. INPUT INSTRUMENT TYPES ARE ASSIGNED TO A VARIABLE C READ IN VIA COMMON BLOCK /COUNT/. THE DATA COUNTER IS ALSO READ IN C VIA THIS COMMON BLOCK. C C PROGRAM HISTORY LOG: C UNKNOWN G. D. DIMEGO C 90-12-05 D. A. KEYSER -- CONVERTED TO VS FORTRAN(77) & RESTRUCTURED C C USAGE: CALL TAB(ID) C INPUT ARGUMENT LIST: C ID - INTEGER INTRUMENT TYPE CODE C C REMARKS: CALLED BY SUBROUTINE "RADEVN". C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/864, C90 C C$$$ SUBROUTINE TAB(ID) CHARACTER*8 SIDNOR C-CRA COMMON/COUNT /NTYPE(69),KTYPE(69),SIDNOR(2000),IICNT COMMON/COUNT /SIDNOR(2000) COMMON/COUNTI/NTYPE(69),KTYPE(69),IICNT DO I=1,68 IF(NTYPE(I).EQ.99999) GO TO 40 IF(NTYPE(I).EQ.ID) GO TO 50 ENDDO NTYPE(69) = ID GO TO 60 40 CONTINUE NTYPE(I) = ID 50 CONTINUE KTYPE(I) = KTYPE(I) + 1 60 CONTINUE KTYPE(69) = KTYPE(69) + 1 RETURN END C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INPUT INPUT DATA, PUT INTO LOCAL ARRAYS. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 95-02-17 C C ABSTRACT: INPUT DATA FROM BUFR FILE AND PUT INTO LOCAL ARRAYS. C C PROGRAM HISTORY LOG: C 95-02-17 W. COLLINS C C USAGE: CALL INPUT C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE INPUT PARAMETER (MXOBS=899) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), C-CRA& OINC(21,2,899), MAN(899), PS(899), GESPS(899), OINCPS(899), C-CRA& TS(899) COMMON /DATA/ OBS(21,3,899), GES(21,2,899), PSL(899), DHR(899), & OINC(21,2,899), PS(899), GESPS(899), OINCPS(899), & TS(899) COMMON /DATAI/ MAN(899) C-CRA COMMON /PARAMS / NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. XMI,XMA,YMI,YMA,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS / XMI,XMA,YMI,YMA,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /DATEC/ CDATE, IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE COMMON /DATEI/ IYR, IMO, IDY, IHR COMMON /STNKNT/ ISHP,IBLK(100) CHARACTER*40 HSTR,CAT0,CAT1,CAT2 CHARACTER*8 SUBSET,CDATE,SID DIMENSION HDR(10),SF0(10),SF2(10),UPA(10,895) EQUIVALENCE (RID,SID) LOGICAL SKIP,BLKSTA DATA HSTR/'SID XOB YOB DHR ELV T29 '/ DATA CAT0/'CAT=0 POB PFC '/ DATA CAT1/'CAT=1 POB ZOB TOB ZFC TFC '/ DATA CAT2/'CAT=2 POB PFC '/ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CLEAR ARRAYS, COUNTERS C ---------------------- C-CRA GESPS = BMISS C-CRA PSL = BMISS C-CRA OBS = BMISS C-CRA GES = BMISS C-CRA PS = BMISS DO IJ=1,899 GESPS(IJ)= BMISS PSL(IJ) = BMISS ENDDO OBS = BMISS C DO IJ=1,21*3*899 C OBS(IJ,1,1) = BMISS C ENDDO GES = BMISS C DO IJ=1,21*2*899 C GES(IJ,1,1) = BMISS C ENDDO DO IJ=1,899 PS(IJ) = BMISS ENDDO NOBS = 0 NSKP = 0 C-CRA IBLK = 0 DO IJ=1,100 IBLK(IJ) = 0 ENDDO ISHP = 0 C GET THE BUFR DATE FROM FIRST DATA MESSAGE AND OPEN THE FILE FOR READ C -------------------------------------------------------------------- CALL DATEBF(NFIN,IYR,IMO,IDY,IHR,IDATE) WRITE(CDATE,'(I8 )') IDATE PRINT*,'DATA VALID AT ',CDATE CALL OPENBF(NFIN,'IN',NFIN) C++-------------------------------------------------------------- CMIC$ PARALLEL AUTOSCOPE CMIC$.SHARED (NFIN,NOBS,XMI,XMA,YMI,YMA,BMISS) CMIC$.SHARED (NSKP,ISHP,HSTR,CAT0,CAT1,CAT2,IBLK,ID) CMIC$.SHARED (SLON,SLAT,SELV,CID,DHR,MAN,OBS,GES,PS,GESPS) CMIC$.PRIVATE (SUBSET,IDATE,HDR,SF0,SF2,UPA,IRET,ISF0,ISF2,NRET) CMIC$.PRIVATE (SID,RID,XOB,YOB,THR,ELV,RTP,NZZ,IDD,IBL,SKIP,MANL) C++-------------------------------------------------------------- C DECODE THE ADPUPA BUFR DATA C --------------------------- 10 DO WHILE(IREADMG(NFIN,SUBSET,IDATE).EQ.0) IF(SUBSET.NE.'ADPUPA') GOTO 10 DO WHILE(IREADSB(NFIN).EQ.0) CALL UFBINT(NFIN,HDR,10, 1,IRET,HSTR) CALL UFBINT(NFIN,SF0,10, 1,ISF0,CAT0) CALL UFBINT(NFIN,SF2,10, 1,ISF2,CAT2) CALL UFBINT(NFIN,UPA,10,895,NRET,CAT1) RID = HDR(1) XOB = HDR(2) YOB = HDR(3) THR = HDR(4) ELV = HDR(5) RTP = HDR(6) C COUNT HEIGHTS C ------------- NZZ = 0 DO L=1,NRET IF(UPA(2,L).LT.BMISS) NZZ = NZZ+1 ENDDO C SEVERAL CONDITIONS FOR SKIPPING THIS REPORT C ------------------------------------------- CMIC$ GUARD 0 SKIP = XOB.LT.XMI .OR. XOB.GT.XMA .OR. YOB.LT.YMI .OR. YOB.GT.YMA ..OR. RTP.LT.11 .OR. (RTP.GT.13.AND.RTP.LT.21) .OR. RTP.GT.23 ..OR. NZZ.EQ.0 .OR. NOBS.EQ.MXOBS IF(SKIP) THEN NSKP = NSKP+1 ELSE C IF CHECK REPORT - STORE THE HEADER - COUNT THE STATION C ------------------------------------------------------ NOBS = NOBS+1 SLON(NOBS) = XOB SLAT(NOBS) = YOB SELV(NOBS) = ELV CID (NOBS) = SID DHR (NOBS) = THR MAN (NOBS) = 0 IF(RTP.LE.13) THEN IF(BLKSTA(SID)) THEN READ(SID,'(I5)') IDD IBL = MIN(IDD/1000,100) IF(IBL.EQ.0) IBL = 100 IBLK(IBL) = IBLK(IBL)+1 ID(NOBS) = IDD ELSE ID(NOBS) = 200000 + NOBS ENDIF ELSE ISHP = ISHP + 1 ID(NOBS) = 100000 + ISHP ENDIF C STORE THE SURFACE DATA AND FIRST GUESS VALUES C --------------------------------------------- IF(SELV(NOBS).LT.BMISS) THEN IF(ISF0.EQ.1 .AND. SF0(2).LT.BMISS) THEN PS(NOBS) = SF0(1) GESPS(NOBS) = SF0(2) ELSEIF(ISF2.EQ.1 .AND. SF2(2).GE.BMISS) THEN PS(NOBS) = SF2(1) GESPS(NOBS) = SF2(2) ENDIF ENDIF C STORE THE UPPER AIR DATA AND FIRST GUESS VALUES C ----------------------------------------------- DO L=1,NRET MANL = MIN(NPLVL,MANLEV(UPA(1,L))) IF(MANL.GT.0) THEN MAN(NOBS) = MAX(MAN(NOBS),MANL) OBS(MANL,1,NOBS) = UPA(2,L) OBS(MANL,2,NOBS) = UPA(3,L) OBS(MANL,3,NOBS) = UPA(1,L) GES(MANL,1,NOBS) = UPA(4,L) GES(MANL,2,NOBS) = UPA(5,L) ENDIF ENDDO ENDIF CMIC$ ENDGUARD 0 ENDDO ENDDO CMIC$ END PARALLEL C FINAL ACCOUNTING FOR INPUT ACTIVITY C ----------------------------------- CALL CLOSBF(NFIN) WRITE(6,500) NOBS WRITE(6,501) NSKP IF(NOBS.EQ.0) THEN CALL COPYBF(NFIN,NFOUT) STOP 'INPUT - NO DATA' ENDIF C CHECK TO SEE IF A FIRST GUESS IS PRESENT C ---------------------------------------- C IGES = 1 IF GUESS IS MISSING FOR ANY NON-MISSING OBSERVATION C IGES = 0 IF GUESS IS PRESENT FOR ALL NON-MISSING OBSERVATIONS IGES = 1 DO N=1,NOBS DO K=1,2 DO L=1,MAN(N) IF(OBS(L,K,N).LT.BMISS .AND. GES(L,K,N).GE.BMISS) GOTO 101 ENDDO ENDDO ENDDO IGES = 0 CALL GESTPS 101 WRITE(6,502) IGES 500 FORMAT(' OBSERVATIONS FOUND = ',I5) 501 FORMAT(' OBSERVATIONS SKIPD = ',I5) 502 FORMAT(' IGES = ',I5) RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- FUNCTION BLKSTA(STR) CHARACTER*(*) STR LOGICAL BLKSTA C----------------------------------------------------------------------- C----------------------------------------------------------------------- READ(STR,'(I5)',ERR=1) III BLKSTA = .TRUE. RETURN 1 BLKSTA = .FALSE. RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE INPUTS C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) DATA BMISS/10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CLEAR THE TIME CHECK ARRAYS C --------------------------- C-CRA ITERR = 0 C-CRA TOBS = BMISS C-CRA TRES = BMISS C-CRA TPS = BMISS C-CRA TPSRES = BMISS DO IJ=1,4 ITERR(IJ) = 0 ENDDO TOBS = BMISS C DO IJ=1,21*3*899*4 C TOBS(IJ,1,1,1) = BMISS C ENDDO TRES = BMISS C DO IJ=1,21*2*899 C TRES(IJ,1,1) = BMISS C ENDDO TPS = BMISS C DO IJ=1,899*4 C TPS(IJ,1) = BMISS C ENDDO DO IJ=1,899 TPSRES(IJ) = BMISS ENDDO C READ FOUR OFF-TIME FILES AT ONCE C -------------------------------- CALL OPENBF(NFTMP(1),'IN',NFTMP(1)) CALL OPENBF(NFTMP(2),'IN',NFTMP(2)) CALL OPENBF(NFTMP(3),'IN',NFTMP(3)) CALL OPENBF(NFTMP(4),'IN',NFTMP(4)) C CALL OPENBF(NFTMP(2),'IN',NFTMP(1)) C CALL OPENBF(NFTMP(3),'IN',NFTMP(1)) C CALL OPENBF(NFTMP(4),'IN',NFTMP(1)) CMIC$ DOALL AUTOSCOPE DO IT=1,4 CALL STRCLN CALL INPUT2(IT) ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INPUT2 INPUT DATA AT OFF-TIME. C PRGMMR: W. COLLINS ORG: W/NMC22 DATE: 95-02-17 C C ABSTRACT: INPUT DATA AT OFF-TIME FROM BUFR FILE AND C PUT INTO LOCAL ARRAYS. C C PROGRAM HISTORY LOG: C 95-02-17 W. COLLINS C C USAGE: CALL INPUT2(IT) C C INPUT ARGUMENT LIST: C IT - INDEX FOR TIME LEVEL C C ATTRIBUTES: C LANGUAGE: VS FORTRAN C MACHINE: CRAY C C$$$ SUBROUTINE INPUT2(IT) C-CRA COMMON /DATEC/ CDATE, IYR, IMO, IDY, IHR COMMON /DATEC/ CDATE COMMON /DATEI/ IYR, IMO, IDY, IHR C-CRA COMMON /PARAMS/ NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS/ ALONN,ALONX,ALATN,ALATX,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) CHARACTER*8 CID C-CRA COMMON /STN/ CID(899), SLAT(899), SLON(899), SELV(899), C-CRA& IN(72,36,2), ID(899) COMMON /STN / SLAT(899), SLON(899), SELV(899) COMMON /STNI/ IN(72,36,2), ID(899) COMMON /STNC/ CID(899) C-CRA COMMON /TCK/ TOBS(21,3,899,4), TRES(21,2,899), ITERR(4), C-CRA& TPS(899,4), TPSRES(899) COMMON /TCK / TOBS(21,3,899,4), TRES(21,2,899), & TPS(899,4), TPSRES(899) COMMON /TCKI/ ITERR(4) CHARACTER*40 HSTR,USTR CHARACTER*8 SUBSET,CIT,CDATE DIMENSION IIT(4),HDR(10),UPA(10,895) EQUIVALENCE (RIT,CIT) DATA HSTR/'SID XOB YOB DHR ELV T29 '/ DATA USTR/'CAT=1 POB ZOB TOB '/ DATA IIT /-24,-12,12,24/ DATA BMISS /10E10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C SEE IF A FILE IS CONNECTED C -------------------------- MATCH = 0 LUTC = NFTMP(IT) WRITE(6,500) NFTMP(IT),IT C IF SO, OPEN THE FILE AND CHECK THE DATE/TIME C -------------------------------------------- 1 CALL READMG(LUTC,SUBSET,IDATE,IRET) IF(SUBSET.NE.'ADPUPA') THEN IF(IRET.NE.0) GOTO 200 GOTO 1 ENDIF READ(CDATE,'(I8)') JDATE CALL ADDATE(JDATE,IIT(IT),JDATE) IF(IDATE.NE.JDATE) GOTO 200 C READ AND STORE ALL MATCHING DATA FROM THIS TIME C ----------------------------------------------- 10 CALL READSB(LUTC,IRET) IF(IRET.NE.0) THEN 20 CALL READMG(LUTC,SUBSET,IDATE,IRET) IF(SUBSET.NE.'ADPUPA') THEN IF(IRET.NE.0) GOTO 100 GOTO 20 ENDIF GOTO 10 ENDIF CALL UFBINT(LUTC,HDR,10, 1,IRET,HSTR) CALL UFBINT(LUTC,UPA,10,895,NRET,USTR) C CALL UFBCNT(LUTC,IREC,ISUB) C PRINT'(5I8)',LUTC,IREC,ISUB C GOTO 10 RIT = HDR(1) XOB = HDR(2) YOB = HDR(3) THR = HDR(4) ELV = HDR(5) RTP = HDR(6) C FIND A MATCHING STATION C ----------------------- DO N=1,NOBS IF(CIT.EQ.CID(N) .AND. XOB.EQ.SLON(N) .AND. YOB.EQ.SLAT(N)) THEN MATCH = MATCH+1 DO L=1,NRET POB = UPA(1,L) MANL = MANLEV(POB) IF(MANL.GT.0 .AND. MANL.LE.NPLVL) THEN TOBS(MANL,1,N,IT) = UPA(2,L) TOBS(MANL,2,N,IT) = UPA(3,L) TOBS(MANL,3,N,IT) = UPA(1,L) ENDIF ENDDO GOTO 10 ENDIF ENDDO GOTO 10 C NORMAL EXIT AFTER READING PROPER FILE C ------------------------------------- 100 WRITE(6,501) MATCH,NFTMP(IT) RETURN C NO PROPER FILE FOUND C -------------------- 200 ITERR(IT) = 1 WRITE(6,502) IIT(IT) CALL CLOSBF(LUTC) RETURN C FORMAT STATEMENTS C ----------------- 500 FORMAT(1X,'INPUT2--READING FROM FILE ',I5,' AT ITIME = ',I5) 501 FORMAT(1X,I5,' OBS FOUND AT MATCHING STATIONS IN FILE FT',I2) 502 FORMAT(1X,'OFF-TIME DATA UNAVAILABLE FOR ',I3) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- FUNCTION MANLEV(P) COMMON /LEVMAN/ ISET,MANLIN(1001) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IP = NINT(P*10.) IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN MANLEV = 0 ELSE MANLEV = MANLIN(NINT(P)) ENDIF RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DMA22 DMA FOR SIG LVL TEMPERATURES, ETC. C PRGMMR: J. WOOLLEN ORG: W/NMC00 DATE: 94-MM-DD C C ABSTRACT: READ DATA, PERFORM DECISON MAKING ALGORITHM FOR C SIGNIFICANT LEVEL TEMPERATURES, WRITE MANDATORY LEVEL EVENTS, C WRITE SIGNIFICANT LEVEL EVENTS, PERFORM RADIATION CORRECTION C AND WRITE EVENTS, AND CALCULATE VIRTUAL TEMPERATURE AND WRITE C EVENTS. C C PROGRAM HISTORY LOG: C 94-MM-DD J. WOOLLEN C C USAGE: CALL DMA22 C C INPUT FILES: C FORT.XX - DATA FILE WHERE XX=NFIN (IN /PARAMS/) C C COMMENTS: C THIS SUBROUTINE IS CALLED WHEN A GUESS IS PRESENT FOR ALL C NON-MISSING OBSERVATIONS. C C ATTRIBUTES: C LANGUAGE: FORTRAN77 C MACHINE: CRAY C C$$$ SUBROUTINE DMA22 C-CRA COMMON /HEADER / SID,XOB,YOB,DHR,ELV,ITP,NLV,NEV,ISF COMMON /HEADER / XOB,YOB,DHR,ELV COMMON /HEADERC/ SID COMMON /HEADERI/ ITP,NLV,NEV,ISF C-CRA COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), C-CRA1 PQM(895),TQM(895),ZQM(895),IND(895),TFC(895) COMMON /ALLSND/ POB(895),TOB(895),ZOB(895),CAT(895), 1 PQM(895),TQM(895),ZQM(895),TFC(895) COMMON /ALLSNDI/IND(895) C-CRA COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), C-CRA. PQ (895),TQ (895),ZQ (895),IN (895), C-CRA. PR (895),TR (895),ZR (895) COMMON /EVNSND/ PO (895),TO (895),ZO (895),CA (895), . PQ (895),TQ (895),ZQ (895), . PR (895),TR (895),ZR (895) COMMON /EVNSNDI/IN (895) COMMON /MOISTR/ QOB(895),QQM(895),TDO(895),QO(895),QQ(895) C-CRA COMMON /PARAMS / NLEV,NOBS,NFIN,NFOUT,NPLVL, C-CRA. XMI,XMA,YMI,YMA,E2,ECON1,ECON2,NSLVL, C-CRA. NZ,NZL,NT,AA,CCON,ISCAN,IGES,DTALL,NFTMP(4) COMMON /PARAMS / XMI,XMA,YMI,YMA,E2,ECON1,ECON2, . AA,CCON,DTALL COMMON /PARAMSI/ NLEV,NOBS,NFIN,NFOUT,NPLVL, . NSLVL,NZ,NZL,NT,ISCAN,IGES,NFTMP(4) C-CRA COMMON /DATEC/ CDATE,JDATE(4) COMMON /DATEC/ CDATE COMMON /DATEI/ JDATE(4) CHARACTER*40 HSTR,OSTR,PEVN,TEVN,ZEVN,QEVN CHARACTER*8 SUBSET,CDATE,CID REAL HDR(10),OBS(10,895) EQUIVALENCE (SID,CID) LOGICAL SKIP,WIND DATA HSTR /'SID XOB YOB DHR ELV ITP TYP T29 '/ DATA OSTR /'POB TOB ZOB CAT PQM TQM ZQM TDO QQM TFC'/ DATA PEVN /'POB PQM PPC PRC '/ DATA TEVN /'TOB TQM TPC TRC '/ DATA ZEVN /'ZOB ZQM ZPC ZRC '/ DATA QEVN /'QOB QQM QPC QRC '/ DATA BMISS /10E10/ DATA IOBS / 0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- PRINT*,'DMA2 READING UNIT ',NFIN C REOPEN THE INPUT FILE AND RESTORE THE DATE C ------------------------------------------ CALL DATEBF(NFIN,IYR,IMO,IDY,IHR,IDATE) WRITE(CDATE,'(I8 )') IDATE READ (CDATE,'(4I2)') JDATE PRINT*,'DATA VALID AT ',CDATE C OPEN THE INPUT/OUTPUT FILES GET QC CODES C ---------------------------------------- CALL OPENBF(NFIN ,'IN ',NFIN) CALL OPENBF(NFOUT,'OUT',NFIN) CALL UFBQCD(NFIN,'CQCHT ',CQCPC) CALL UFBQCD(NFIN,'RADCOR',RADPC) CALL UFBQCD(NFIN,'VIRTMP',VTPPC) C READ ALL THE MESSAGES IN THE INPUT FILE - JUST COPY ANY NON-ADPUPA C**------------------------------------------------------------------ CMIC$ PARALLEL AUTOSCOPE CMIC$.SHARED (NFIN,NFOUT,HSTR,OSTR,PEVN,QEVN,TEVN,ZEVN,MSGS,BMISS ) CMIC$.SHARED (CQCPC,RADPC,VTPPC,JDATE ) CMIC$.SHARED (SID,XOB,YOB,DHR,ELV,ITP,TYP,T29,NLV,NEV,ISF ) CMIC$.SHARED (POB,QOB,TOB,ZOB,CAT,PQM,QQM,TDO,TQM,ZQM,IND,TFC ) CMIC$.SHARED (PO,QO,TO,ZO,CA,PQ,QQ,TQ,ZQ,IN,PR,TR,ZR ) CMIC$.SHARED (SKIP,WIND,CID,IDENT,XMI,XMA,YMI,YMA,ISHIP,IOBS ) CMIC$.PRIVATE (SUBSET,IDATE,HDR,OBS,ILV ) C**------------------------------------------------------------------ 10 DO WHILE(IREADMG(NFIN,SUBSET,IDATE).EQ.0) IF(SUBSET.NE.'ADPUPA') THEN CALL CLOSMG(NFOUT) CALL COPYMG(NFIN,NFOUT) GOTO 10 ELSE CALL OPENMB(NFOUT,SUBSET,IDATE) ENDIF DO WHILE(IREADSB(NFIN).EQ.0) CALL UFBINT(NFIN,HDR,10, 1,ILV,HSTR) CALL UFBINT(NFIN,OBS,10,895,ILV,OSTR) CALL UFBCPY(NFIN,NFOUT) CMIC$ GUARD 1 SID = HDR(1) XOB = HDR(2) YOB = HDR(3) DHR = HDR(4) ELV = HDR(5) ITP = HDR(6) TYP = HDR(7) T29 = HDR(8) IF(TYP.GE.BMISS) CALL SABORT('DMA22 - NOT A PREPDA FILE') NLV = ILV ISF = 0 DO L=1,NLV IND(L) = L POB(L) = OBS(1,L) TOB(L) = OBS(2,L) ZOB(L) = OBS(3,L) CAT(L) = OBS(4,L) PQM(L) = OBS(5,L) TQM(L) = OBS(6,L) ZQM(L) = OBS(7,L) TDO(L) = OBS(8,L) QQM(L) = OBS(9,L) TFC(L) = OBS(10,L) IF(CAT(L).EQ.0) ISF = L IF(TDO(L).LT.BMISS .AND. TOB(L).LT.BMISS) TDO(L) = TOB(L)-TDO(L) ENDDO C SEVERAL CONDITIONALS FOR PROCESSING THE ADPUPA REPORTS C ------------------------------------------------------ SKIP = XOB.LT.XMI .OR. XOB.GT.XMA .OR. YOB.LT.YMI .OR. YOB.GT.YMA ..OR. T29.LT.11 .OR. (T29.GT.13.AND.T29.LT.21) .OR. T29.GT.23 ..OR. MOD(TYP,100.).NE.20 WIND = TYP.GE.200 IF(WIND) ITP = 20000 IDENT = 0 READ(CID,'(I5)',ERR=15) IDENT 15 IF(IDENT.EQ.0) THEN ISHIP = ISHIP + 1 IDENT = 10000 + ISHIP ENDIF C CQC MAND AND SIG LEVEL EVENTS C ----------------------------- IF(.NOT.SKIP) THEN CALL MANEVN CALL EVENT(NFOUT,PEVN,NLV,PO,PQ,PR,ISF, 1,CQCPC) CALL EVENT(NFOUT,TEVN,NLV,TO,TQ,TR,IN,NEV,CQCPC) CALL EVENT(NFOUT,ZEVN,NLV,ZO,ZQ,ZR,IN,NEV,CQCPC) IF(.NOT.WIND) THEN IOBS = IOBS + 1 CALL STCEVN(IOBS,IDENT,DHR,YOB,XOB,ELV) CALL EVENT(NFOUT,TEVN,NLV,TO,TQ,TR,IN,NEV,CQCPC) ENDIF ENDIF C RADCOR AND VIRTMP ADJUSTMENTS FOR ALL ADPUPA MASS REPORTS C --------------------------------------------------------- IF(.NOT.WIND) THEN CALL UFBINT(-NFOUT,POB,1,895,NLL,'POB') CALL UFBINT(-NFOUT,TOB,1,895,NLL,'TOB') CALL UFBINT(-NFOUT,ZOB,1,895,NLL,'ZOB') CALL UFBINT(-NFOUT,PQM,1,895,NLL,'PQM') CALL UFBINT(-NFOUT,TQM,1,895,NLL,'TQM') CALL UFBINT(-NFOUT,ZQM,1,895,NLL,'ZQM') CALL UFBINT(-NFOUT,QQM,1,895,NLL,'QQM') IF(NLL.NE.NLV) CALL SABORT('DMA22 - NLL NE NLV') CALL RADEVN(JDATE) CALL EVENT(NFOUT,TEVN,NLV,TO,TQ,TR,IN,NEV,RADPC) CALL EVENT(NFOUT,ZEVN,NLV,ZO,ZQ,ZR,IN,NEV,RADPC) CALL VTPEVN(NFIN) CALL EVENT(NFOUT,TEVN,NLV,TO,TQ,TR,IN,NEV,VTPPC) CALL EVENT(NFOUT,QEVN,NLV,QO,QQ,TR,IN,NEV,VTPPC) ENDIF CMIC$ ENDGUARD 1 C END OF READ LOOPS - WRITE THE CURRENT SUBSET BACK TO A FILE C ----------------------------------------------------------- CALL WRITSB(NFOUT) ENDDO ENDDO CALL CLOSMG(NFOUT) CMIC$ END PARALLEL CALL CLOSBF(NFOUT) CALL CLOSBF(NFIN) C EXITS C ----- RETURN END SUBROUTINE W3FS13(IYR,IMO,IDA,JDY) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: W3FS13 YEAR, MONTH, AND DAY TO DAY OF YEAR C AUTHOR: CHASE, P. ORG: W345 DATE: 85-07-31 C C ABSTRACT: CONVERTS YEAR, MONTH AND DAY TO DAY OF YEAR. C C PROGRAM HISTORY LOG: C 85-07-31 R.E.JONES C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C C USAGE: CALL W3FS13(IYR, IMO, IDA, JDY) C C INPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C IYR ARG LIST INTEGER YEAR OF CENTURY, 00-99 OR YEAR OF ERA, C 1901-2099 C IMO ARG LIST INTEGER MONTH OF YEAR, 1-12 C IDA ARG LIST INTEGER DAY OF MONTH, 1-31 C C OUTPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C JDY ARG LIST INTEGER DAY OF YEAR, 1-366 C C SUBPROGRAMS CALLED: C NAMES LIBRARY C ------------------------------------------------------- -------- C IAND SYSTEM C C REMARKS: THIS PROCEDURE IS VALID ONLY FROM THE YEARS 1901-2099 C INCLUSIVE. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C INTEGER JTABLE(24) C DATA JTABLE/0,0,31,31,60,59,91,90,121,120,152,151, & 182,181,213,212,244,243,274,273,305,304,335,334/ C ISET = 0 IF (IAND(IYR,3).EQ.0) ISET = 1 I = IMO * 2 - ISET JDY = JTABLE(I) + IDA RETURN END SUBROUTINE W3FS21(IDATE, NMIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FS21 NUMBER OF MINUTES SINCE JAN 1, 1978 C PRGMMR: REJONES ORG: NMC421 DATE: 89-07-17 C C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000, C 1 JANUARY 1978. C C PROGRAM HISTORY LOG: C 84-06-21 A. DESMARAIS C 89-07-14 R.E.JONES CONVERT TO CYBER 205 FORTRAN 200, C CHANGE LOGIC SO IT WILL WORK IN C 21 CENTURY. C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C C USAGE: CALL W3FS21 (IDATE, NMIN) C INPUT ARGUMENT LIST: C IDATE - INTEGER SIZE 5 ARRAY CONTAINING YEAR OF CENTURY, C MONTH, DAY, HOUR AND MINUTE. IDATE(1) MAY BE C A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78 C 1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED C TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK C CORRECTLY TO THE YEAR 3300 A.D. C C OUTPUT ARGUMENT LIST: C NMIN - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978 C C SUBPROGRAMS CALLED: C LIBRARY: C W3LIB - JW3JDN C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C INTEGER IDATE(5) INTEGER NMIN INTEGER JDN78 C DATA JDN78 / 2443510 / C C*** IDATE(1) YEAR OF CENTURY C*** IDATE(2) MONTH OF YEAR C*** IDATE(3) DAY OF MONTH C*** IDATE(4) HOUR OF DAY C*** IDATE(5) MINUTE OF HOUR C NMIN = 0 C IYEAR = IDATE(1) C IF (IYEAR.LE.99) THEN IF (IYEAR.LT.78) THEN IYEAR = IYEAR + 2000 ELSE IYEAR = IYEAR + 1900 ENDIF ENDIF C C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY C IJDN = JW3JDN(IYEAR,IDATE(2),IDATE(3)) C C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE C NUMBER OF DAYS BETWEEN DATES C NDAYS = IJDN - JDN78 C C*** NUMBER OF MINUTES C NMIN = NDAYS * 1440 + IDATE(4) * 60 + IDATE(5) C RETURN END FUNCTION JW3JDN(IYEAR,MONTH,IDAY) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: JW3JDN COMPUTE JULIAN DAY NUMBER C AUTHOR: JONES,R.E. ORG: W342 DATE: 90-06-04 C MODIFIED BY M. KANAMITSU DATE: 96-11-25 C EXACT COPY OF IW3JDN BUT CHANGED NAME TO JW3JDN TO AVOID C CONFUSION WITH W3LIB COMPILED WITH SINGLE PRECISION C C ABSTRACT: COMPUTES JULIAN DAY NUMBER FROM YEAR (4 DIGITS), MONTH, C AND DAY. JW3JDN IS VALID FOR YEARS 1583 A.D. TO 3300 A.D. C JULIAN DAY NUMBER CAN BE USED TO COMPUTE DAY OF WEEK, DAY OF C YEAR, RECORD NUMBERS IN AN ARCHIVE, REPLACE DAY OF CENTURY, C FIND THE NUMBER OF DAYS BETWEEN TWO DATES. C C PROGRAM HISTORY LOG: C 87-01-16 R.E.JONES C 89-02-02 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 C 90-06-04 R.E.JONES CHANGE TO SUN FORTRAN 1.3 C 91-03-29 R.E.JONES CONVERT TO SILICON GRAPHICS FORTRAN C 93-03-29 R.E.JONES ADD SAVE STATEMENT C C USAGE: II = JW3JDN(IYEAR,MONTH,IDAY) C C INPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C IYEAR ARG LIST INTEGER*4 YEAR ( 4 DIGITS) C MONTH ARG LIST INTEGER*4 MONTH OF YEAR (1 - 12) C IDAY ARG LIST INTEGER*4 DAY OF MONTH (1 - 31) C C OUTPUT VARIABLES: C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES C ------ --------- ----------------------------------------------- C JW3JDN FUNTION INTEGER*4 JULIAN DAY NUMBER C JAN. 1,1960 IS JULIAN DAY NUMBER 2436935 C JAN. 1,1987 IS JULIAN DAY NUMBER 2446797 C C REMARKS: JULIAN PERIOD WAS DEVISED BY JOSEPH SCALIGER IN 1582. C JULIAN DAY NUMBER 1 STARTED ON JAN. 1,4713 B.C. THREE MAJOR C CHRONOLOGICAL CYCLES BEGIN ON THE SAME DAY. A 28-YEAR SOLAR C CYCLE, A 19-YEAR LUNER CYCLE, A 15-YEAR INDICTION CYCLE, USED C IN ANCIENT ROME TO REGULATE TAXES. IT WILL TAKE 7980 YEARS C TO COMPLETE THE PERIOD, THE PRODUCT OF 28, 19, AND 15. C SCALIGER NAMED THE PERIOD, DATE, AND NUMBER AFTER HIS FATHER C JULIUS (NOT AFTER THE JULIAN CALENDAR). THIS SEEMS TO HAVE C CAUSED A LOT OF CONFUSION IN TEXT BOOKS. SCALIGER NAME IS C SPELLED THREE DIFFERENT WAYS. JULIAN DATE AND JULIAN DAY C NUMBER ARE INTERCHANGED. A JULIAN DATE IS USED BY ASTRONOMERS C TO COMPUTE ACCURATE TIME, IT HAS A FRACTION. WHEN TRUNCATED TO C AN INTEGER IT IS CALLED AN JULIAN DAY NUMBER. THIS FUNCTION C WAS IN A LETTER TO THE EDITOR OF THE COMMUNICATIONS OF THE ACM C VOLUME 11 / NUMBER 10 / OCTOBER 1968. THE JULIAN DAY NUMBER C CAN BE CONVERTED TO A YEAR, MONTH, DAY, DAY OF WEEK, DAY OF C YEAR BY CALLING SUBROUTINE W3FS26. C C$$$ C SAVE C JW3JDN = IDAY - 32075 & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 RETURN END SUBROUTINE SABORT(STRING) CHARACTER*(*) STRING WRITE(*,*) 'ABORT:',STRING STOP 8 END