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 GBYTE GET INTEGER DATA FROM BYTES C 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 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 GBYTE(CBREAD,LENSEC,0*8,4*8) CALL 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 SBYTE(CINDEX,LSKIP,8*IXSKP,8*MXSKP) ! BYTES TO SKIP CALL SBYTE(CINDEX,LOCLUS,8*IXLUS,8*MXLUS) ! LOCATION OF LOCAL USE CALL SBYTE(CINDEX,LOCGDS,8*IXSGD,8*MXSGD) ! LOCATION OF GDS CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSPD,8*MXSPD) ! LOCATION OF PDS CALL SBYTE(CINDEX,LGRIB,8*IXLEN,8*MXLEN) ! LEN OF GRIB2 CINDEX(41)=CVER CINDEX(42)=CDISC CALL 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 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 SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM) ! LOC. OF BMS ELSEIF ( INDBMP.EQ.254 ) THEN CALL SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM) ! LOC. OF BMS ELSEIF ( INDBMP.EQ.255 ) THEN CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSBM,8*MXSBM) ! LOC. OF BMS ENDIF CINDEX(LINDEX+1:LINDEX+MXBMS)=CBREAD(1:MXBMS) LINDEX=LINDEX+MXBMS CALL SBYTE(CINDEX,LINDEX,0,8*4) ! NUM BYTES IN INDEX RECORD ELSEIF (NUMSEC.EQ.7) THEN ! FOUND DATA SECTION CALL 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