C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C  sfcread.F
C
C  SAMPLE READ PROGRAM FOR NMC SURFACE OBSERVATION DATA
C
C  only categories 51 (land surface data) and 8 (additional data)
C  are expected in the KuDA land surface data set.
C
C   Copyright 1992, University Corporation for
C   Atmospheric Research, All Rights Reserved
C
C ADM (NCAR/ATD/RAF) 92 MAY 12
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 

C--------------------------------------------------------------------
C
C MAIN PROGRAM
C
C   PROGRAM ADP77
C
C  ASKS USER FOR FILENAME AND DATE, SEARCHES FILE FOR RECORD
C  OF THAT DATE, DISPLAYS DATA, AND ASKS FOR NEXT RECORD
C--------------------------------------------------------------------
      PROGRAM ADP77
      PARAMETER(MXLV8=16)
      CHARACTER ASTA*6,NADD(MXLV8)*10,FLNM*128
      CHARACTER YMD*20
      INTEGER YEAR,MONTH,DAY
      LOGICAL NOTFND
C
      LOUT=6
      IU=11
C
    4 WRITE(*,*)

C --- SET NO MATCHING RECORDS FOUND FLAG
      NOTFND=.TRUE.

C --- SET CONDITION CODE TO ALL'S WELL
      ICC=0

      WRITE(*,20)
   20 FORMAT(1X,' Enter file name to read or ''quit'' -> ',$)
      READ(*,'(A)')FLNM
      IF (FLNM.EQ.'QUIT' .OR. FLNM.EQ.'quit') THEN
          ICC=4
          GO TO 90
      ELSE
          OPEN(IU,FILE=FLNM,STATUS='OLD',IOSTAT=IERR)
          IF(IERR.NE.0) THEN
	      IF(IERR.EQ.118) THEN
	         WRITE(*,70)FLNM
   70            FORMAT(" CANNOT FIND FILE "A6)
	         GOTO 4
	      ELSE
                 WRITE(*,80)IERR,FLNM
   80            FORMAT(' ERROR OPENING FILE ='I9,' ',A6)
C                quit program - SYSTEM ERROR
	         ICC=6
                 GO TO 90
	      ENDIF
          ENDIF
      ENDIF
C
      NRO=0

C --- NOW ENTER YYMMDD

   23 WRITE(*,*)
      ICC=0
      WRITE(*,24)
   24 FORMAT(1X,' Enter YYMMDD or ''quit'' -> ',$)
      READ(*,'(A)') YMD
      IF (YMD.EQ.'QUIT' .OR. YMD.EQ.'quit') THEN
          ICC=4
          GO TO 90
      ELSE
          READ(YMD,'(I2,I2,I2)')YEAR,MONTH,DAY
          IF (YEAR.LT.90) THEN
              WRITE(*,*)' ERROR:  YEAR MUST BE GREATER THAN 90'
              GO TO 23
          ENDIF
          IF (MONTH.LT.1 .OR. MONTH.GT.12) THEN
              WRITE(*,*)' ERROR:  MONTH NOT BETWEEN 1 AND 12'
              GO TO 23
          ENDIF
          IF (DAY.LT.1 .OR. DAY.GT.31) THEN
              WRITE(*,*)' ERROR:  DAY NOT BETWEEN 1 AND 31'
              GO TO 23
          ENDIF
      ENDIF

      WRITE(*,*)' SEARCHING INPUT FILE'
          

C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C   READ first 50 characters of record
C
    5 CONTINUE
      NR=0

   10 CONTINUE
C
C       read 10 character YYMMDDHH block
C       and 40 character Report Identification block (lat,lon,etc.)
C
      CALL RDADP(IU,IDSRCH,IYR,IMO,IDY,IHR,IDSTYP,XLAT,XLON,
     2   ASTA,XHR,IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH,ISTAT)

      IF(ISTAT.NE.0) THEN
          ICC=ISTAT
          GO TO 90
      ENDIF
      NCE=0
      NR=NR+1
      IF (IYR.GT.YEAR) THEN
          ICC = 2
          GO TO 90
      ELSEIF (IMO.GT.MONTH .AND. IYR.EQ.YEAR) THEN
          ICC = 2
          GO TO 90
      ELSEIF (IDY.GT.DAY .AND. IMO.EQ.MONTH .AND. IYR.EQ.YEAR) THEN
          ICC = 2
          GO TO 90
      ENDIF
      IF (IYR.NE.YEAR .OR. IMO.NE.MONTH .OR. IDY.NE.DAY) GO TO 10

C --- DISPLAY COLUMN HEADERS ONLY ONCE PER FILE AND DATE
      IF (NOTFND) THEN
        WRITE(*,*)
        WRITE(*,444)
  444   FORMAT( ' STATN  YR MO DY HR   LAT    LON   ELEV',$)
        WRITE(*,'(A)') '   WIND DIR  WIND SPD   TEMP  DEWPT DPR'
        WRITE(*,445)
  445   FORMAT( ' -----  -- -- -- --   ---    ---   ----',$)
        WRITE(*,'(A)') '   --------  --------   ----  ---------'
      ENDIF

C --- A RECORD HAS BEEN FOUND FOR THE DATE ENTERED
      NOTFND=.FALSE.
C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C   READ CATEGORY-SPECIFIC DATA FROM RECORD
C
C   10 character Category/Counter group and 40 char report id block
C   are followed by category-dependent data
C
C --- READ CATEGORY 51 DATA
        CALL SADP51(NCNT,SLP,STP,DDD,FFF,AT,DPD,ATMX,ATMN,
     2   QSLP,QSTP,QDDFF,QAT,QDWX,IVV,IPW,IW1,IN,INH,IC1,IZCB,
     3   IC2,IC3,ICPT,IPT)
C
C READ CATEGORY 52 DATA
C        CALL SADP52(MCNT,XPC6,XSNO,XPC24,IPCT,IPRW,IZW,IDDW,IPRS,
C     2   IZS,SST,ISPH,ISPHD,ISDD,ISFF,XWEQ)
C
C --- READ CATEGORY 8 DATA
        CALL SADP08(NADD,NLV8,MXLV8)

C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C   DISPLAY DATA
C

C      WRITE(LOUT,1003)ASTA,IRTYP,XLAT,XLON,XELEV,IYR,IMO,IDY,IHR,
C     2   XHR,DDD,FFF,SLP,STP,AT,DPD
C 1003 FORMAT(1X,A6,I4,2F7.2,F7.0,3I3,I5,F5.1,2F5.0,2F7.1,3F6.1)

      WRITE(LOUT,1003)ASTA,IYR,IMO,IDY,IHR,XLAT,XLON,XELEV,
     2   DDD,FFF,AT,DPD
 1003 FORMAT(1X,A6,4I3,2F7.2,F7.0,2F10.1,2F7.1)

C ----- KEEP RECORD COUNT UP TO DATE
        NRO=NRO+1

C
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
   90 CONTINUE
      IF (ICC.EQ.0) THEN
C ----- LOOP BACK TO READ THE NEXT RECORD IN THE FILE
        GO TO 10
      ENDIF

C ----- CLOSE THE INPUT FILE - A DIFFERENT ONE MAY BE OPENED NEXT
      CLOSE(UNIT=IU)

      IF (ICC.EQ.2) THEN
C ----- LOOP BACK TO READ ANOTHER FILE
        IF (NOTFND) THEN
            WRITE (*,'(A)') 'NO RECORDS FOUND FOR DATE ENTERED'
        ENDIF
        GO TO 4

      ELSEIF (ICC.EQ.4) THEN
C ----- USER ENTERED QUIT SO STOP PROGRAM
        WRITE(*,'(A)')'EXITING PROGRAM'
        GO TO 95

      ELSEIF (ICC.EQ.5) THEN
C ----- END OF FILE, SO LOOP BACK TO READ ANOTHER FILE
        PRINT 1000,NRO
 1000   FORMAT(' END OF FILE REACHED - # OF RECORDS=',I8)
        GO TO 4

      ELSE
C ----- UNKNOWN (SYSTEM) ERROR ON OPEN OR READ - STOP PROGRAM
        WRITE(*,'(A)')'UNRECOVERABLE ERROR'
        GO TO 95

      ENDIF

   95 CONTINUE
C     END FILE LOUT
      STOP
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE RDADP
C
C   reads 60 character header info:
C       10 character YYMMDDHH block
C       40 character Report Identification block (lat,lon)
C--------------------------------------------------------------------
      SUBROUTINE RDADP(IU,IDSRCH,IYR,IMO,IDY,IHR,IDSTYP,XLAT,XLON,
     2 ASTA,XHR,IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH,ISTAT)
      SAVE
      DIMENSION IOB(1006)
      PARAMETER (NDIM=10000,LIM=NDIM/8)
      CHARACTER NBF*10000,ASTA*6,IDSTYP*10,IDSRCH*10
      DATA IOB/1006*0/
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NU,NA,LTHR/99999,0,0/

      NU=NU+LTHR

    5 CONTINUE
      IST=1
      READ(IU,'(A)',END=90)NBF
      IST=0
      NU=1

C --- The first 10 characters of each record contain the year, 
C --- month, day, and hour (2x,4i2) of each observation
C GET DATE FROM LEADER
      READ(NBF(1:10),'(2X,4I2)',ERR=80)IYR,IMO,IDY,IHR
C GET ID FOR CURRENT REPORT
      NU=11
C --- The next 40 characters of each record contain the latitude,
C --- longitude, etc.
      READ(NBF(NU:NU+39),1001,ERR=80)XLAT,XLON,ASTA,XHR,
     2 IC25,IC26,IC27,IRTYP,XELEV,IINTYP,LTH
 1001 FORMAT(F5.2,F5.2,A6,F4.2,4X,3A1,I3,F5.0,I2,I3)
C
      LTHR=LTH*10
      ISTAT=0
      IF(LTHR.GT.40) RETURN

C --- ERROR ENCOUNTERED
   80 CONTINUE
      PRINT 1002,NU,NBF(NU:NU+39)
 1002 FORMAT(' ERR IN RDADP- NU,NBF ',I5,1X,A40)
      GO TO 5

C -----end of file reached
   90 CONTINUE

      ISTAT=5
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE SADP51
C
C   reads category 51 (land surface data) records
C--------------------------------------------------------------------
      SUBROUTINE SADP51(NCNT,SLP,STP,DDD,FFF,AT,DPD,ATMX,ATMN,
     2 QSLP,QSTP,QDDFF,QAT,QDWX,IVV,IPW,IW1,IN,INH,IC1,IZCB,
     3 IC2,IC3,ICPT,IPT)
      SAVE
C
C DECODE PARAMETERS FROM CAT 51 DATA, ALL ARGUMENTS ARE OUTPUT.
C NCNT=0 MEANS NO CAT 51 DATA IN THIS REPORT.
C NCNT=-1 MEANS ERROR IN DECODE OF THE DATA
C
      CHARACTER NBF*10000,NMSG*60
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999999999999999999
     299999'/
      NTU=NU+40
      NCNT=0
C
C LOOK FOR CATEGORY 51
    5 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90

         READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
C ncc=category code, ntn=number of ten character words,
C nent=number of entries, nccc=total # of chars in current category

C --- if number of ten character words is less than 0, error
         IF(NTN.LE.0) GO TO 95
C --- if category code is 51 then found one
         IF(NCC.EQ.51) GO TO 20
C --- read more
         NTU=NU+10*(NTN-1)
      GO TO 5
C
   20 CONTINUE
C       write(*,'(A,$)') '51 '
C DECODE CATEGORY 51
      NTU=NTU+10
      READ(NBF(NTU:NTU+59),1002,ERR=95)SLP,STP,DDD,FFF,AT,DPD,ATMX,ATMN,
     2 QSLP,QSTP,QDDFF,QAT,QDWX,IVV,IPW,IW1,IN,INH,IC1,
     3 IZCB,IC2,IC3,ICPT,IPT
 1002 FORMAT(F5.1,F5.1,2F3.0,F4.1,F3.1,2F4.1,5A1,2I3,7I2,I1,I3)

      NCNT=NCNT+1
      RETURN

C --- 'END REPORT' MARKER FOUND
   90 CONTINUE
      READ(NMSG,1002,ERR=95)SLP,STP,DDD,FFF,AT,DPD,ATMX,ATMN,
     2 QSLP,QSTP,QDDFF,QAT,QDWX,IVV,IPW,IW1,IN,INH,IC1,
     3 IZCB,IC2,IC3,ICPT,IPT
      RETURN

C --- ERROR
   95 CONTINUE
      PRINT 1003,NBF(NTU:NTU+59)
 1003 FORMAT(' DECODE ERROR IN CAT51 ',A60)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE SADP08
C
C   reads category 8 (additional data) records
C--------------------------------------------------------------------
      SUBROUTINE SADP08(NADD,NCNT,MAXLEV)
      SAVE
      DIMENSION NADD(1)
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      NTU=NU+40
      NCNT=0
      NLV=0
C
C LOOK FOR CATEGORY  8
    2 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
      READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
C
      IF(NTN.LE.0) GO TO 95
      IF(NCC.EQ. 8) GO TO  3
      NTU=NU+10*(NTN-1)
      GO TO 2
C
    3 CONTINUE
C       write(*,'(A,$)') '08 '
   10 CONTINUE
      NLV=NENT
      IF (NLV .LE. MAXLEV) GO TO 12
      PRINT 1001,NLV
 1001 FORMAT('0TOO MANY LEVELS IN SADP08',I10)
      NLV=MAXLEV
   12 CONTINUE
      NTU=NTU+10

      DO 20 I=1,NLV
        READ(NBF(NTU:NTU+9),1002,ERR=95)NADD(I)
 1002   FORMAT(A10)
   20 NTU=NTU+10

C ---- 'END REPORT' found
   90 NCNT=NLV
      RETURN

   95 CONTINUE
      PRINT 1003,NBF(NTU:NTU+9)
 1003 FORMAT(' DECODE ERROR IN CAT08 ',A10)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE SADP52
C
C   reads category 52 (sea surface data) records
C--------------------------------------------------------------------
      SUBROUTINE SADP52(NCNT,XPC6,XSNO,XPC24,IPCT,IPW,IZW,IDDS,IPS,
     2 IZS,SST,ISPH,ISPHD,ISDD,ISFF,XWEQ)
      SAVE
C
C DECODE PARAMETERS FROM CAT 52 DATA, ALL ARGMENTS ARE OUTPUT.
C NCNT=0 MEANS NO CAT 52 DATA IN THIS REPORT.
C NCNT=-1 MEANS ERROR IN DECODE OF THE DATA
C
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      NTU=NU+40
      NCNT=0
C
C LOOK FOR CATEGORY 52
    5 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
        READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
        IF(NTN.LE.0) GO TO 95
        IF(NCC.EQ.52) GO TO 20
        NTU=NU+10*(NTN-1)
      GO TO 5
C
   20 CONTINUE
       write(*,'(A,$)') '52 '
C DECODE CATEGORY 52
      NTU=NTU+10
      READ(NBF(NTU:NTU+39),1002,ERR=95)XPC6,XSNO,XPC24,IPCT,IPW,IZW,
     2 IDDS,IPS,IZS,SST,ISPH,ISPHD,ISDD,ISFF,XWEQ
 1002 FORMAT(F4.2,F3.0,F4.2,I1,5I2,F4.1,2I2,I1,I2,F7.2)
      NCNT=NENT
C     NCNT=NCNT+1
      RETURN

   90 CONTINUE
      READ(NMSG,1002,ERR=95)XPC6,XSNO,XPC24,IPCT,IPW,IZW,
     2 IDDS,IPS,IZS,SST,ISPH,ISPHD,ISDD,ISFF,XWEQ
      RETURN

   95 CONTINUE
      PRINT 1003,NBF(NTU:NTU+39)
 1003 FORMAT(' DECODE ERROR IN CAT52 ',A40)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE MANADP
C
C   reads category 1 records
C--------------------------------------------------------------------
      SUBROUTINE MANADP(P,Z,T,H,D,F,Q,NCNT,MAXLEV)
      SAVE
      DIMENSION P(1),Z(1),T(1),H(1),D(1),F(1),Q(1)
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      DIMENSION PM(20)
      DATA PM/1000.,850.,700.,500.,400.,300.,250.,200.,150.,100.,70.,
     2 50.,30.,20.,10.,7.,5.,3.,2.,1./

      NTU=NU+40
      NCNT=0
      NLV=0
C
C LOOK FOR CATEGORY  1
    2 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
        READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
        IF(NTN.LE.0) GO TO 95
        IF(NCC.EQ. 1) GO TO  3
        NTU=NU+10*(NTN-1)
      GO TO 2
C
    3 CONTINUE
       write(*,'(A,$)') '01 '
   10 CONTINUE
      NLV=NENT
      IF (NLV .LE. MAXLEV) GO TO 12
      PRINT 1001,NLV
 1001 FORMAT('0TOO MANY LEVELS IN MANADP',I10)
      NLV=MAXLEV
   12 CONTINUE
      NTU=NTU+10

      DO 20 I=1,NLV
        P(I)=PM(I)
        READ(NBF(NTU:NTU+21),1002,ERR=95)Z(I),T(I),H(I),D(I),F(I),Q(I)
 1002   FORMAT(F5.0,F4.1,F3.1,2F3.0,A4)
   20 NTU=NTU+22

   90 NCNT=NLV
      RETURN

   95 CONTINUE
      PRINT 1003,NBF(NTU:NTU+21)
 1003 FORMAT(' DECODE ERROR IN CAT01 ',A22)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE SIGADP
C
C   reads category 2 records
C--------------------------------------------------------------------
      SUBROUTINE SIGADP(P,T,H,Q,NCNT,MAXLEV)
      SAVE
      DIMENSION P(1),T(1),H(1),Q(1)
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      NTU=NU+40
      NCNT=0
      NLV=0
C
C LOOK FOR CATEGORY  2
    2 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
        READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
        IF(NTN.LE.0) GO TO 95
        IF(NCC.EQ. 2) GO TO  3
        NTU=NU+10*(NTN-1)
      GO TO 2
C
    3 CONTINUE
       write(*,'(A,$)') '02 '
   10 CONTINUE
      NLV=NENT
      IF (NLV .LE. MAXLEV) GO TO 12
      PRINT 1001,NLV
 1001 FORMAT('0TOO MANY LEVELS IN SIGADP',I10)
      NLV=MAXLEV
   12 CONTINUE
      NTU=NTU+10

      DO 20 I=1,NLV
        READ(NBF(NTU:NTU+14),1002,ERR=95)P(I),T(I),H(I),Q(I)
 1002   FORMAT(F5.1,F4.1,F3.1,A3)
   20 NTU=NTU+15

   90 NCNT=NLV
      RETURN

   95 CONTINUE
      PRINT 1003,NBF(NTU:NTU+14)
 1003 FORMAT(' DECODE ERROR IN CAT02 ',A15)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *


C--------------------------------------------------------------------
C
C   SUBROUTINE STKADP
C
C--------------------------------------------------------------------
      SUBROUTINE STKADP(P,Z,T,H,D,F,Q,NLV,MAXLEV)
      SAVE
      DIMENSION P(1),Z(1),H(1),D(1),F(1),Q(1),T(1)
      NLV=0
      CALL MANADP(P,Z,T,H,D,F,Q,NMLV,MAXLEV)
      J=0
      IF (NMLV .LE. 0) GO TO 6

      DO 5 I=1,NMLV
      IF (T(I) .GT. 90. .AND. H(I) .GT. 90. .AND. Z(I) .GT. 90000. .AND.
     2 D(I) .GT. 900.) GO TO 5
        J=J+1
        IF (J .EQ. I) GO TO 5
        P(J)=P(I)
        Z(J)=Z(I)
        T(J)=T(I)
        H(J)=H(I)
        D(J)=D(I)
        F(J)=F(I)
        Q(J)=Q(I)
    5 CONTINUE

      NMLV=J
    6 CONTINUE
      MLEV=MAXLEV-NMLV
      I=NMLV+1
      CALL SIGADP(P(I),T(I),H(I),Q(I),NSLV,MLEV)
      NLV=NMLV+NSLV
      IF (NSLV .EQ. 0) RETURN

      DO 10 J=I,NLV
        D(J)=999.
        F(J)=999.
   10 Z(J)=99999.

      IF (NMLV .EQ. 0) RETURN
      IL=NMLV
   15 IL=IL+1
   16 IF (IL .GT. NLV) GO TO 40
      IS=IL
   18 IS=IS-1
      IF (IS .LT. 1) GO TO 22
      IF (P(IL) .GT. P(IS)) GO TO 18
      IF (P(IL) .NE. P(IS)) GO TO 22
      NLV=NLV-1
      IF (IL .GT. NLV) GO TO 40

      DO 20 K=IL,NLV
        J=K+1
        P(K)=P(J)
        Z(K)=Z(J)
        T(K)=T(J)
        H(K)=H(J)
        D(K)=D(J)
        F(K)=F(J)
   20 Q(K)=Q(J)

      GO TO 16
   22 CONTINUE
      IS=IS+1
      XP=P(IL)
      XZ=P(IL)
      XZ=Z(IL)
      XT=T(IL)
      XH=H(IL)
      XD=D(IL)
      XF=F(IL)
      QN=Q(IL)
      IB=1
      IE=IL-IS
      DO 25 J=IB,IE
      K=IL-J
      L=K+1
      P(L)=P(K)
      Z(L)=Z(K)
      T(L)=T(K)
      H(L)=H(K)
      D(L)=D(K)
      F(L)=F(K)
   25 Q(L)=Q(K)
      P(IS)=XP
      Z(IS)=XZ
      T(IS)=XT
      H(IS)=XH
      D(IS)=XD
      F(IS)=XF
      Q(IS)=QN
      GO TO 15
   40 CONTINUE
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

 
C--------------------------------------------------------------------
C
C   SUBROUTINE WPPADP
C & ENTRY WZZADP
C
C   reads category 3 or category 4 data
C--------------------------------------------------------------------
      SUBROUTINE WPPADP(P,D,F,Q,NCNT,MAXLEV)
      SAVE
      DIMENSION P(1),D(1),F(1),Q(1)
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      LCAT=3
      XMUL=.1
      GO TO 1

      ENTRY WZZADP(P,D,F,Q,NCNT,MAXLEV)
      LCAT=4
      XMUL=1.
    1 CONTINUE
      NTU=NU+40
      NCNT=0
      NLV=0
C
C LOOK FOR CATEGORY  LCAT
    2 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
      READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
      IF(NTN.LE.0) GO TO 95
      IF(NCC.EQ. LCAT) GO TO  3
      NTU=NU+10*(NTN-1)
      GO TO 2
C
    3 CONTINUE
       write(*,'(I2,A1,$)') LCAT,' '
   10 CONTINUE
      NLV=NENT
      IF (NLV .LE. MAXLEV) GO TO 12
      PRINT 1001,NLV
 1001 FORMAT('0TOO MANY LEVELS IN WXXADP',I10)
      NLV=MAXLEV
   12 CONTINUE
      NTU=NTU+10

      DO 20 I=1,NLV
        READ(NBF(NTU:NTU+12),1002,ERR=95)P(I),D(I),F(I),Q(I)
 1002   FORMAT(F5.0,2F3.0,A2)
        P(I)=P(I)*XMUL
   20 NTU=NTU+13

C ---- 'END REPORT FOUND'
   90 NCNT=NLV
      RETURN

   95 CONTINUE
      PRINT 1003,LCAT,NBF(NTU:NTU+12)
 1003 FORMAT(' DECODE ERROR IN CAT',I2,1X,A13)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 


C--------------------------------------------------------------------
C
C   SUBROUTINE TRPADP
C
C   reads category 6 or category 5 records
C--------------------------------------------------------------------
      SUBROUTINE TRPADP(P,T,H,D,F,Q,NCNT,MAXLEV)
      SAVE
      DIMENSION P(1),T(1),H(1),D(1),F(1),Q(1)
      CHARACTER NBF*10000,NMSG*40
      COMMON /ADPB/NBF
      COMMON/ADPC/NU,NA,LTHR
      DATA NMSG/'9999999999999999999999999999999999999999'/
      LCAT=5
      XMUL=.1
      GO TO 1
      ENTRY AFTADP(P,T,H,D,F,Q,NCNT,MAXLEV)
      LCAT=6
      XMUL=1.
    1 CONTINUE
      NTU=NU+40
      NCNT=0
      NLV=0
C
C LOOK FOR CATEGORY  LCAT
    2 CONTINUE
      IF(NBF(NTU:NTU+9).EQ.'END REPORT') GO TO 90
      READ(NBF(NTU:NTU+9),'(I2,I3,I2,I3)',ERR=95)NCC,NTN,NENT,NCCC
      IF(NTN.LE.0) GO TO 95
      IF(NCC.EQ. LCAT) GO TO  3
      NTU=NU+10*(NTN-1)
      GO TO 2
C
    3 CONTINUE
       write(*,'(I2,A1,$)') LCAT,' '
   10 CONTINUE
      NLV=NENT
      IF (NLV .LE. MAXLEV) GO TO 12
      PRINT 1001,NLV
 1001 FORMAT('0TOO MANY LEVELS IN TXXADP',I10)
      NLV=MAXLEV
   12 CONTINUE
      NTU=NTU+10

      DO 20 I=1,NLV
        READ(NBF(NTU:NTU+21),1002,ERR=95)P(I),T(I),H(I),D(I),F(I),Q(I)
 1002   FORMAT(F5.0,F4.1,F3.1,2F3.0,A4)
        P(I)=P(I)*XMUL
   20 NTU=NTU+22

C ---- 'END REPORT' found
   90 NCNT=NLV
      RETURN

   95 CONTINUE
      PRINT 1003,LCAT,NBF(NTU:NTU+12)
 1003 FORMAT(' DECODE ERROR IN CAT',I2,1X,A13)
      NCNT=-1
      RETURN
      END


C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 
C *       END OF FILE sfcread.F                                     *
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *