ixgb2.f

Go to the documentation of this file.

C>    @file
C>    @brief This subroutine generates an index record for each field in
C>    a grib2 message. 
C>    @author Mark Iredell @date 1995-10-31
C>
 
C>    This subroutine generates an index record for each field in
C>    a grib2 message. The index records are written to index buffer
C>    pointed to by cbuf.
C>    - byte 001 - 004 length of index record
C>    - byte 005 - 008 bytes to skip in data file before grib message
C>    - byte 009 - 012 bytes to skip in message before lus (local use)
C>    set = 0, if no local use section in grib2 message.
C>    - byte 013 - 016 bytes to skip in message before gds
C>    - byte 017 - 020 bytes to skip in message before pds
C>    - byte 021 - 024 bytes to skip in message before drs
C>    - byte 025 - 028 bytes to skip in message before bms
C>    - byte 029 - 032 bytes to skip in message before data section
C>    - byte 033 - 040 bytes total in the message
C>    - byte 041 - 041 grib version number (currently 2)
C>    - byte 042 - 042 message discipline
C>    - byte 043 - 044 field number within grib2 message
C>    - byte 045 - ii identification section (ids)
C>    - byte ii+1 - jj grid definition section (gds)
C>    - byte jj+1 - kk product definition section (pds)
C>    - byte kk+1 - ll the data representation section (drs)
C>    - byte ll+1 - ll+6 first 6 bytes of the bit map section (bms)
C>
C>    Program history log:
C>    - 1995-10-31 Mark Iredell
C>    - 1996-10-31 Mark Iredell augmented optional definitions to byte 320.
C>    - 2001-12-10 Stephen Gilbert modified from ixgb to create grib2 indexes.
C>    - 2002-01-31 Stephen Gilbert added identification section to index record.
C>    
C>    @param[in] LUGB integer unit of the unblocked grib file.
C>    @param[in] LSKIP integer number of bytes to skip before grib message.
C>    @param[in] LGRIB integer number of bytes in grib message.
C>    @param[out] CBUF character*1 pointer to a buffer that contains
C>    index records users should free memory that cbuf points to
C>    using deallocate(cbuf) when cbuf is no longer needed.
C>    @param[out] NUMFLD integer number of index records created.
C>    @param[out] MLEN integer total length of all index records.
C>    @param[out] IRET integer return code
C>    - 0 all ok
C>    - 1 not enough memory available to hold full index buffer
C>    - 2 i/o error in read
C>    - 3 grib message is not edition 2
C>    - 4 not enough memory to allocate extent to index buffer
C>    - 5 unidentified grib section encountered
C>    
C>     @author Mark Iredell @date 1995-10-31
C>
 
      SUBROUTINE ixgb2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
 
      USE re_alloc          ! NEEDED FOR SUBROUTINE REALLOC
      CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
      parameter(linmax=5000,init=50000,next=10000)
      parameter(ixskp=4,ixlus=8,ixsgd=12,ixspd=16,ixsdr=20,ixsbm=24,
     &          ixds=28,ixlen=36,ixfld=42,ixids=44)
      parameter(mxskp=4,mxlus=4,mxsgd=4,mxspd=4,mxsdr=4,mxsbm=4,
     &          mxds=4,mxlen=4,mxfld=2,mxbms=6)
      CHARACTER CBREAD(LINMAX),CINDEX(LINMAX)
      CHARACTER CVER,CDISC
      CHARACTER CIDS(LINMAX),CGDS(LINMAX),CBMS(6)
      CHARACTER(LEN=4) :: CTEMP
      INTEGER LOCLUS,LOCGDS,LENGDS,LOCBMS
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      loclus=0
      iret=0
      mlen=0
      numfld=0
      IF (ASSOCIATED(cbuf)) NULLIFY(cbuf)
      mbuf=init
      ALLOCATE(cbuf(mbuf),stat=istat)    ! ALLOCATE INITIAL SPACE FOR CBUF
      IF (istat.NE.0) THEN
         iret=1
         RETURN
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  READ SECTIONS 0 AND 1 FOR VERSIN NUMBER AND DISCIPLINE
      ibread=min(lgrib,linmax)
      CALL baread(lugb,lskip,ibread,lbread,cbread)
      IF(lbread.NE.ibread) THEN
         iret=2
         RETURN
      ENDIF
      IF(cbread(8).NE.char(2)) THEN          !  NOT GRIB EDITION 2
         iret=3
         RETURN
      ENDIF
      cver=cbread(8)
      cdisc=cbread(7)
      CALL g2_gbytec(cbread,lensec1,16*8,4*8)
      lensec1=min(lensec1,ibread)
      cids(1:lensec1)=cbread(17:16+lensec1)
      ibskip=lskip+16+lensec1
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  LOOP THROUGH REMAINING SECTIONS CREATING AN INDEX FOR EACH FIELD
      ibread=max(5,mxbms)
      DO
         CALL baread(lugb,ibskip,ibread,lbread,cbread)     
         ctemp=cbread(1)//cbread(2)//cbread(3)//cbread(4)
         IF (ctemp.EQ.'7777') RETURN        ! END OF MESSAGE FOUND
         IF(lbread.NE.ibread) THEN
            iret=2
            RETURN
         ENDIF
         CALL g2_gbytec(cbread,lensec,0*8,4*8)
         CALL g2_gbytec(cbread,numsec,4*8,1*8)
 
         IF (numsec.EQ.2) THEN                 ! SAVE LOCAL USE LOCATION
            loclus=ibskip-lskip
         ELSEIF (numsec.EQ.3) THEN                 ! SAVE GDS INFO
            lengds=lensec
            cgds=char(0)
            CALL baread(lugb,ibskip,lengds,lbread,cgds)     
            IF(lbread.NE.lengds) THEN
               iret=2
               RETURN
            ENDIF
            locgds=ibskip-lskip
         ELSEIF (numsec.EQ.4) THEN                 ! FOUND PDS
            cindex=char(0)
            CALL g2_sbytec(cindex,lskip,8*ixskp,8*mxskp)    ! BYTES TO SKIP
            CALL g2_sbytec(cindex,loclus,8*ixlus,8*mxlus)   ! LOCATION OF LOCAL USE
            CALL g2_sbytec(cindex,locgds,8*ixsgd,8*mxsgd)   ! LOCATION OF GDS
            CALL g2_sbytec(cindex,ibskip-lskip,8*ixspd,8*mxspd)  ! LOCATION OF PDS
            CALL g2_sbytec(cindex,lgrib,8*ixlen,8*mxlen)    ! LEN OF GRIB2
            cindex(41)=cver
            cindex(42)=cdisc
            CALL g2_sbytec(cindex,numfld+1,8*ixfld,8*mxfld)   ! FIELD NUM
            cindex(ixids+1:ixids+lensec1)=cids(1:lensec1)
            lindex=ixids+lensec1
            cindex(lindex+1:lindex+lengds)=cgds(1:lengds)
            lindex=lindex+lengds
            ilnpds=lensec
            CALL baread(lugb,ibskip,ilnpds,lbread,cindex(lindex+1))     
            IF(lbread.NE.ilnpds) THEN
               iret=2
               RETURN
            ENDIF
            !   CINDEX(LINDEX+1:LINDEX+ILNPDS)=CBREAD(1:ILNPDS)
            lindex=lindex+ilnpds
         ELSEIF (numsec.EQ.5) THEN                 ! FOUND DRS
            CALL g2_sbytec(cindex,ibskip-lskip,8*ixsdr,8*mxsdr)  ! LOCATION OF DRS
            ilndrs=lensec
            CALL baread(lugb,ibskip,ilndrs,lbread,cindex(lindex+1))     
            IF(lbread.NE.ilndrs) THEN
               iret=2
               RETURN
            ENDIF
            !   CINDEX(LINDEX+1:LINDEX+ILNDRS)=CBREAD(1:ILNDRS)
            lindex=lindex+ilndrs
         ELSEIF (numsec.EQ.6) THEN                 ! FOUND BMS
            indbmp=mova2i(cbread(6))
            IF ( indbmp.LT.254 ) THEN
               locbms=ibskip-lskip
               CALL g2_sbytec(cindex,locbms,8*ixsbm,8*mxsbm)  ! LOC. OF BMS
            ELSEIF ( indbmp.EQ.254 ) THEN
               CALL g2_sbytec(cindex,locbms,8*ixsbm,8*mxsbm)  ! LOC. OF BMS
            ELSEIF ( indbmp.EQ.255 ) THEN
               CALL g2_sbytec(cindex,ibskip-lskip,8*ixsbm,8*mxsbm)  ! LOC. OF BMS
            ENDIF
            cindex(lindex+1:lindex+mxbms)=cbread(1:mxbms)
            lindex=lindex+mxbms
            CALL g2_sbytec(cindex,lindex,0,8*4)    ! NUM BYTES IN INDEX RECORD
         ELSEIF (numsec.EQ.7) THEN                 ! FOUND DATA SECTION
            CALL g2_sbytec(cindex,ibskip-lskip,8*ixds,8*mxds)   ! LOC. OF DATA SEC.
            numfld=numfld+1
            IF ((lindex+mlen).GT.mbuf) THEN        ! ALLOCATE MORE SPACE IF
                                                   ! NECESSARY
               newsize=max(mbuf+next,mbuf+lindex)
               CALL realloc(cbuf,mlen,newsize,istat)
               IF ( istat .NE. 0 ) THEN
                  numfld=numfld-1
                  iret=4
                  RETURN
               ENDIF
               mbuf=newsize
            ENDIF
            cbuf(mlen+1:mlen+lindex)=cindex(1:lindex)
            mlen=mlen+lindex
         ELSE                           ! UNRECOGNIZED SECTION
            iret=5
            RETURN
         ENDIF
         ibskip=ibskip+lensec
      ENDDO
 
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END