getgb1s.f

Go to the documentation of this file.

C> @file
C> @brief Find a grib message.
C> @author Mark Iredell @date 1995-10-31
 
C> Find a grib message.
C> Find in the index file a reference to the grib message requested.
C> The grib message request specifies the number of messages to skip
c> and the unpacked pds and gds parameters. (A requested parameter
c> of -1 means to allow any value of this parameter to be found.)
C>
C> Program history log:
C> - Mark Iredell 1995-10-31
C> - Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
C>
C> @param[in] CBUF Character*1 (nlen*nnum) buffer containing index data.
C> @param[in] NLEN Integer length of each index record in bytes.
C> @param[in] NNUM Integer number of index records.
C> @param[in] J Integer number of messages to skip
c> (=0 to search from beginning).
C> @param[in] JPDS Integer (200) pds parameters for which to search
c> (=-1 for wildcard).
C> @param[in] JGDS Integer (200) gds parameters for which to search
c> (only searched if jpds(3)=255) (=-1 for wildcard).
C> @param[in] JENS Integer (200) ensemble pds parms for which to search
c> (only searched if jpds(23)=2) (=-1 for wildcard).
C> @param[out] K Integer message number found
c> (can be same as j in calling program in order to facilitate multiple searches).
C> @param[out] KPDS Integer (200) unpacked pds parameters.
C> @param[out] KGDS Integer (200) unpacked gds parameters.
C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
C> @param[out] LSKIP Integer number of bytes to skip.
C> @param[out] LGRIB Integer number of bytes to read.
C> @param[out] IRET Integer return code.
C> - 0 All ok.
C> - 1 Request not found.
C>
C> @note Subprogram can be called from a multiprocessing environment.
C> This subprogram is intended for private use by getgb routines only.
C>
C> @author Mark Iredell @date 1995-10-31
C-----------------------------------------------------------------------
      SUBROUTINE getgb1s(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS,
     &                   K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET)
      CHARACTER CBUF(NLEN*NNUM)
      INTEGER JPDS(200),JGDS(200),JENS(200)
      INTEGER KPDS(200),KGDS(200),KENS(200)
      parameter(lpds=23,lgds=22,lens=5)     ! ACTUAL SEARCH RANGES
      CHARACTER CPDS(400)*1,CGDS(400)*1
      INTEGER KPTR(200)
      INTEGER IPDSP(LPDS),JPDSP(LPDS)
      INTEGER IGDSP(LGDS),JGDSP(LGDS)
      INTEGER IENSP(LENS),JENSP(LENS)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  COMPRESS REQUEST LISTS
      k=j
      lskip=0
      lgrib=0
      iret=1
C  COMPRESS PDS REQUEST
      lpdsp=0
      DO i=1,lpds
        IF(jpds(i).NE.-1) THEN
          lpdsp=lpdsp+1
          ipdsp(lpdsp)=i
          jpdsp(lpdsp)=jpds(i)
        ENDIF
      ENDDO
C  COMPRESS GDS REQUEST
      lgdsp=0
      IF(jpds(3).EQ.255) THEN
        DO i=1,lgds
          IF(jgds(i).NE.-1) THEN
            lgdsp=lgdsp+1
            igdsp(lgdsp)=i
            jgdsp(lgdsp)=jgds(i)
          ENDIF
        ENDDO
      ENDIF
C  COMPRESS ENS REQUEST
      lensp=0
      IF(jpds(23).EQ.2) THEN
        DO i=1,lens
          IF(jens(i).NE.-1) THEN
            lensp=lensp+1
            iensp(lensp)=i
            jensp(lensp)=jens(i)
          ENDIF
        ENDDO
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  SEARCH FOR REQUEST
      dowhile(iret.NE.0.AND.k.LT.nnum)
        k=k+1
        lt=0
C  SEARCH FOR PDS REQUEST
        IF(lpdsp.GT.0) THEN
          cpds=char(0)
          cpds(1:28)=cbuf((k-1)*nlen+26:(k-1)*nlen+53)
          nless=max(184-nlen,0)
          cpds(29:40-nless)=cbuf((k-1)*nlen+173:(k-1)*nlen+184-nless)
          kptr=0
          CALL gbytec(cbuf,kptr(3),(k-1)*nlen*8+25*8,3*8)
          kpds(18)=1
          CALL gbytec(cpds,kpds(4),7*8,8)
          CALL fi632(cpds,kptr,kpds,kret)
          DO i=1,lpdsp
            ip=ipdsp(i)
            lt=lt+abs(jpds(ip)-kpds(ip))
          ENDDO
        ENDIF
C  SEARCH FOR GDS REQUEST
        IF(lt.EQ.0.AND.lgdsp.GT.0) THEN
          cgds=char(0)
          cgds(1:42)=cbuf((k-1)*nlen+54:(k-1)*nlen+95)
          nless=max(320-nlen,0)
          cgds(43:178-nless)=cbuf((k-1)*nlen+185:(k-1)*nlen+320-nless)
          kptr=0
          CALL fi633(cgds,kptr,kgds,kret)
          DO i=1,lgdsp
            ip=igdsp(i)
            lt=lt+abs(jgds(ip)-kgds(ip))
          ENDDO
        ENDIF
C  SEARCH FOR ENS REQUEST
        IF(lt.EQ.0.AND.lensp.GT.0) THEN
          nless=max(172-nlen,0)
          cpds(41:100-nless)=cbuf((k-1)*nlen+113:(k-1)*nlen+172-nless)
          CALL pdseup(kens,kprob,xprob,kclust,kmembr,45,cpds)
          DO i=1,lensp
            ip=iensp(i)
            lt=lt+abs(jens(ip)-kens(ip))
          ENDDO
        ENDIF
C  RETURN IF REQUEST IS FOUND
        IF(lt.EQ.0) THEN
          CALL gbytec(cbuf,lskip,(k-1)*nlen*8,4*8)
          CALL gbytec(cbuf,lgrib,(k-1)*nlen*8+20*8,4*8)
          IF(lpdsp.EQ.0) THEN
            cpds=char(0)
            cpds(1:28)=cbuf((k-1)*nlen+26:(k-1)*nlen+53)
            nless=max(184-nlen,0)
            cpds(29:40-nless)=cbuf((k-1)*nlen+173:(k-1)*nlen+184-nless)
            kptr=0
            CALL gbytec(cbuf,kptr(3),(k-1)*nlen*8+25*8,3*8)
            kpds(18)=1
            CALL gbytec(cpds,kpds(4),7*8,8)
            CALL fi632(cpds,kptr,kpds,kret)
          ENDIF
          IF(lgdsp.EQ.0) THEN
            cgds=char(0)
            cgds(1:42)=cbuf((k-1)*nlen+54:(k-1)*nlen+95)
            nless=max(320-nlen,0)
            cgds(43:178-nless)=cbuf((k-1)*nlen+185:(k-1)*nlen+320-nless)
            kptr=0
            CALL fi633(cgds,kptr,kgds,kret)
          ENDIF
          IF(kpds(23).EQ.2.AND.lensp.EQ.0) THEN
            nless=max(172-nlen,0)
            cpds(41:100-nless)=cbuf((k-1)*nlen+113:(k-1)*nlen+172-nless)
            CALL pdseup(kens,kprob,xprob,kclust,kmembr,45,cpds)
          ENDIF
          iret=0
        ENDIF
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END