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
