C NOTES: 5-2004: WNE
C CHANGED /DATE/ TO /DATEC/ TO AVOID DUAL DEFINITIONS F90?
C COMMENTED OUT SUBROUTINE ADDATE AS DEFINED IN BUFRLIBRARY
C FIXED LEAP YEAR IN ADDATE (THIS ROUTINE AND BUFRLIB)
C
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 255 LEVELS.
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$$$
C SUBROUTINE ADDATE(IDATE,JH,JDATE)
C
C DIMENSION MON(12)
C
C DATA MON/31,28,31,30,31,30,31,31,30,31,30,31/
C
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C
C IY = MOD(IDATE/1000000,100)
C IM = MOD(IDATE/10000 ,100)
C ID = MOD(IDATE/100 ,100)
C IH = MOD(IDATE ,100)
C
C MON(2) = 28
C IF(MOD(IY,4).EQ.0) MON(2) = 29
C IF(MOD(IY,100).EQ.0) MON(2) = 28
C IF(MOD(IY,400).EQ.0) MON(2) = 29
C
C IH = IH+JH
C
C IF(IH.LT.0) THEN
C IH = IH+24
C ID = ID-1
C IF(ID.EQ.0) THEN
C IM = IM-1
C IF(IM.EQ.0) THEN
C IM = 12
C IY = IY-1
C IF(IY.LT.0) IY = 99
C ENDIF
C ID = MON(IM)
C ENDIF
C ELSEIF(IH.GE.24) THEN
C IH = IH-24
C ID = ID+1
C IF(ID.GT.MON(IM)) THEN
C ID = 1
C IM = IM+1
C IF(IM.GT.12) THEN
C IM = 1
C IY = MOD(IY+1,100)
C ENDIF
C ENDIF
C ENDIF
C
C JDATE = IY*1E6 + IM*1E4 + ID*1E2 + IH
C
C RETURN
C 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(22,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), IR,
& NERT(21,2,899,2), NERTPS(899,2)
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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.399) 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.399) 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.399) 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.399) 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.399) 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.399) 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 = 399
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
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,255),QMS(10,255)
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,255,NLVD,OSTR)
CALL UFBINT(NFIN,QMS,10,255,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(255), HMN(255), HAN(255), VMN(255), VAN(255)
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,255)
DATA BMISS /10E10/
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
IF(NEVN.EQ.0) RETURN
C CLEAR THE UFB ARRAY FIRST
C -------------------------
C-CRA EVNS = BMISS
DO IJ=1,4*255
EVNS(IJ,1) = BMISS
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
C 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(255), TTRYC(*), TNEWC(*),
& PMQ(21), ZMQ(21), TMQ(21), PPQ(255), ZZQ(255), TTQ(255),
& ZQC(255), TQC(255), PQC(255)
INTEGER NSIG, MAN, INDX(*), ITYP(*),
& IWKSP(255)
C-MK & IWKSP(255), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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-----------------------------------------------------------------------
BLOCK DATA
COMMON /LEV926/ ISET,MANLIN(1001)
DATA ISET/0/
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
C-CRA COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
C-CRA. PQ (255),TQ (255),ZQ (255),IN (255),
C-CRA. PR (255),TR (255),ZR (255)
COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
. PQ (255),TQ (255),ZQ (255),
. PR (255),TR (255),ZR (255)
COMMON /EVNSNDI/IN (255)
C-CRA COMMON /ERROR/ NERR(21,2,899,2), NEVNT(22,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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
DO IJ=1,255
PO(IJ) = BMISS
TO(IJ) = BMISS
ZO(IJ) = BMISS
IN(IJ) = BMISS
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(255), PC(255), XPC(255), ZC(255), TC(255),
& TFU(255), TGES(21,899), TG(255), TD(255), TTRY(255), TTRYC(255),
& PD(255), XPD(255), ZD(255), TID(255), HMD(255), HAD(255),
& VMD(255), VAD(255), TSTRD(255), TNEW(255), TNEWC(255),
& TIC(255), HMC(255), HAC(255), VMC(255), VAC(255), TSTARC(255),
& PMQ(21), ZMQ(21), TMQ(21), PPQ(255), ZZQ(255), TTQ(255),
& PQD(255), ZQD(255), TQD(255), PQC(255), ZQC(255), TQC(255)
INTEGER INDX(255), ITYP(255), MB(255), MA(255), NB(255), NA(255),
& IDECC(255), IHYDC(255), IERRC(255), INDXD(255), ITYPD(255),
& IDECD(255), IHYDD(255), IERRD(255), 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(255), TSIGU(255),
& 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(399), NTMP(399)
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
C-CRA COMMON /EVNSND/ P (255),T (255),Z (255),CA (255),
C-CRA. PQ (255),TQ (255),ZQ (255),IN (255),
C-CRA. PR (255),TR (255),ZR (255)
COMMON /EVNSND/ P (255),T (255),Z (255),CA (255),
. PQ (255),TQ (255),ZQ (255),
. PR (255),TR (255),ZR (255)
COMMON /EVNSNDI/IN (255)
C-CRA COMMON /SIGCHK/ TPRM(255),HRES(255),SRES(255),RES (255),
C-CRA. MAN1(255),MAN2(255),IECM(255),IECS(255),
C-CRA. RESS(255),RESM(255),REST(255)
COMMON /SIGCHK / TPRM(255),HRES(255),SRES(255),RES (255),
. RESS(255),RESM(255),REST(255)
COMMON /SIGCHKI/ MAN1(255),MAN2(255),IECM(255),IECS(255)
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(255), IDM(21), IDS(255), IDEC(255)
REAL ZM(21), TM(21), TMG(21), PP(255), TT(255), TG(255),
& PMQ(21), ZMQ(21), TMQ(21),
& PPQ(255), ZZQ(255), TTQ(255)
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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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,399), IR,
C-CRA& NERT(21,2,899,2), DHOUR(399), NERTPS(899,2)
COMMON /ERROR/ DHOUR(399)
COMMON /ERRORI/ NERR(21,2,899,2), NEVNT(22,399), 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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
C-CRA COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
C-CRA. PQ (255),TQ (255),ZQ (255),IN (255),
C-CRA. PR (255),TR (255),ZR (255)
COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
. PQ (255),TQ (255),ZQ (255),
. PR (255),TR (255),ZR (255)
COMMON /EVNSNDI/IN (255)
COMMON /MOISTR/ QOB(255),QQM(255),TDO(255),QO(255),QQ(255)
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,255
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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
C-CRA COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
C-CRA. PQ (255),TQ (255),ZQ (255),IN (255),
C-CRA. PR (255),TR (255),ZR (255)
COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
. PQ (255),TQ (255),ZQ (255),
. PR (255),TR (255),ZR (255)
COMMON /EVNSNDI/IN (255)
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,255
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
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,255)
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
DO IJ=1,21*3*899
OBS(IJ,1,1) = BMISS
ENDDO
DO IJ=1,21*2*899
GES(IJ,1,1) = BMISS
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,255,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
DO IJ=1,21*3*899*4
TOBS(IJ,1,1,1) = BMISS
ENDDO
DO IJ=1,21*2*899
TRES(IJ,1,1) = BMISS
ENDDO
DO IJ=1,899*4
TPS(IJ,1) = BMISS
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,255)
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,255,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(255),TOB(255),ZOB(255),CAT(255),
C-CRA1 PQM(255),TQM(255),ZQM(255),IND(255),TFC(255)
COMMON /ALLSND/ POB(255),TOB(255),ZOB(255),CAT(255),
1 PQM(255),TQM(255),ZQM(255),TFC(255)
COMMON /ALLSNDI/IND(255)
C-CRA COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
C-CRA. PQ (255),TQ (255),ZQ (255),IN (255),
C-CRA. PR (255),TR (255),ZR (255)
COMMON /EVNSND/ PO (255),TO (255),ZO (255),CA (255),
. PQ (255),TQ (255),ZQ (255),
. PR (255),TR (255),ZR (255)
COMMON /EVNSNDI/IN (255)
COMMON /MOISTR/ QOB(255),QQM(255),TDO(255),QO(255),QQ(255)
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,255)
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,255,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,255,NLL,'POB')
CALL UFBINT(-NFOUT,TOB,1,255,NLL,'TOB')
CALL UFBINT(-NFOUT,ZOB,1,255,NLL,'ZOB')
CALL UFBINT(-NFOUT,PQM,1,255,NLL,'PQM')
CALL UFBINT(-NFOUT,TQM,1,255,NLL,'TQM')
CALL UFBINT(-NFOUT,ZQM,1,255,NLL,'ZQM')
CALL UFBINT(-NFOUT,QQM,1,255,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