source: trunk/WRF.COMMON/WRFV2/external/io_grib2/g2lib/ixgb2.F

C-----------------------------------------------------------------------
      SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: IXGB2          MAKE INDEX RECORDS FOR FIELDS IN A GRIB2 MESSAGE
C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2001-12-10
C
C ABSTRACT: THIS SUBPROGRAM GENERATES AN INDEX RECORD FOR EACH FIELD IN A
C           GRIB2 MESSAGE.  THE INDEX RECORDS ARE WRITTEN TO INDEX BUFFER
C           POINTED TO BY CBUF.
C
C           EACH INDEX RECORD HAS THE FOLLOWING FORM:
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   95-10-31  IREDELL
C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
C 2001-12-10  GILBERT   MODIFIED FROM IXGB TO CREATE GRIB2 INDEXES
C 2002-01-31  GILBERT   ADDED IDENTIFICATION SECTION TO INDEX RECORD
C
C USAGE:    CALL IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
C   INPUT ARGUMENTS:
C     LUGB         INTEGER LOGICAL UNIT OF INPUT GRIB FILE
C     LSKIP        INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE
C     LGRIB        INTEGER NUMBER OF BYTES IN GRIB MESSAGE
C   OUTPUT ARGUMENTS:
C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
C     NUMFLD       INTEGER NUMBER OF INDEX RECORDS CREATED.
C                  = 0, IF PROBLEMS
C     MLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
C     IRET         INTEGER RETURN CODE
C                  =0, ALL OK
C                  =1, NOT ENOUGH MEMORY TO ALLOCATE INITIAL 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...PROBLEM 
C                      SOMEWHERE.
C
C SUBPROGRAMS CALLED:
C   G2LIB_GBYTE        GET INTEGER DATA FROM BYTES
C   G2LIB_SBYTE        STORE INTEGER DATA IN BYTES
C   BAREAD       BYTE-ADDRESSABLE READ
C   REALLOC      RE-ALLOCATES MORE MEMORY
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      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 G2LIB_GBYTE(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 G2LIB_GBYTE(CBREAD,LENSEC,0*8,4*8)
         CALL G2LIB_GBYTE(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 G2LIB_SBYTE(CINDEX,LSKIP,8*IXSKP,8*MXSKP)    ! BYTES TO SKIP
            CALL G2LIB_SBYTE(CINDEX,LOCLUS,8*IXLUS,8*MXLUS)   ! LOCATION OF LOCAL USE
            CALL G2LIB_SBYTE(CINDEX,LOCGDS,8*IXSGD,8*MXSGD)   ! LOCATION OF GDS
            CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSPD,8*MXSPD)  ! LOCATION OF PDS
            CALL G2LIB_SBYTE(CINDEX,LGRIB,8*IXLEN,8*MXLEN)    ! LEN OF GRIB2
            CINDEX(41)=CVER
            CINDEX(42)=CDISC
            CALL G2LIB_SBYTE(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 G2LIB_SBYTE(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 G2LIB_SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
            ELSEIF ( INDBMP.EQ.254 ) THEN
               CALL G2LIB_SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
            ELSEIF ( INDBMP.EQ.255 ) THEN
               CALL G2LIB_SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
            ENDIF
            CINDEX(LINDEX+1:LINDEX+MXBMS)=CBREAD(1:MXBMS)
            LINDEX=LINDEX+MXBMS
            CALL G2LIB_SBYTE(CINDEX,LINDEX,0,8*4)    ! NUM BYTES IN INDEX RECORD
         ELSEIF (NUMSEC.EQ.7) THEN                 ! FOUND DATA SECTION
            CALL G2LIB_SBYTE(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