C----------------------------------------------------------------------- SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETG2IR CREATES AN INDEX OF A GRIB2 FILE C PRGMMR: GILBERT ORG: W/NP11 DATE: 2002-01-02 C C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS. C THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT: 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 2002-01-02 GILBERT MODIFIED FROM GETGIR TO CREATE GRIB2 INDEXES C C USAGE: CALL GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET) C INPUT ARGUMENTS: C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB FILE C MSK1 INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE C MSK2 INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES C MNUM INTEGER NUMBER OF GRIB MESSAGES TO SKIP (USUALLY 0) 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 NLEN INTEGER TOTAL LENGTH OF INDEX RECORD BUFFER IN BYTES C NNUM INTEGER NUMBER OF INDEX RECORDS C (=0 IF NO GRIB MESSAGES ARE FOUND) C NMESS LAST GRIB MESSAGE IN FILE SUCCESSFULLY PROCESSED C IRET INTEGER RETURN CODE C 0 ALL OK C 1 NOT ENOUGH MEMORY AVAILABLE TO HOLD FULL INDEX C BUFFER C 2 NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER C C SUBPROGRAMS CALLED: C SKGB SEEK NEXT GRIB MESSAGE C IXGB2 MAKE INDEX RECORD C C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C C$$$ USE RE_ALLOC ! NEEDED FOR SUBROUTINE REALLOC PARAMETER(INIT=50000,NEXT=10000) CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUFTMP INTERFACE ! REQUIRED FOR CBUF POINTER SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET) INTEGER,INTENT(IN) :: LUGB,LSKIP,LGRIB CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF INTEGER,INTENT(OUT) :: NUMFLD,MLEN,IRET END SUBROUTINE IXGB2 END INTERFACE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C INITIALIZE IRET=0 IF (ASSOCIATED(CBUF)) NULLIFY(CBUF) MBUF=INIT ALLOCATE(CBUF(MBUF),STAT=ISTAT) ! ALLOCATE INITIAL SPACE FOR CBUF IF (ISTAT.NE.0) THEN IRET=2 RETURN ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C SEARCH FOR FIRST GRIB MESSAGE ISEEK=0 CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB) DO M=1,MNUM IF(LGRIB.GT.0) THEN ISEEK=LSKIP+LGRIB CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) ENDIF ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C GET INDEX RECORDS FOR EVERY GRIB MESSAGE FOUND NLEN=0 NNUM=0 NMESS=MNUM DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0) CALL IXGB2(LUGB,LSKIP,LGRIB,CBUFTMP,NUMFLD,NBYTES,IRET1) IF (IRET1.NE.0) PRINT *,' SAGT ',NUMFLD,NBYTES,IRET1 IF((NBYTES+NLEN).GT.MBUF) THEN ! ALLOCATE MORE SPACE, IF ! NECESSARY NEWSIZE=MAX(MBUF+NEXT,MBUF+NBYTES) CALL REALLOC(CBUF,NLEN,NEWSIZE,ISTAT) IF ( ISTAT .NE. 0 ) THEN IRET=1 RETURN ENDIF MBUF=NEWSIZE ENDIF ! ! IF INDEX RECORDS WERE RETURNED IN CBUFTMP FROM IXGB2, ! COPY CBUFTMP INTO CBUF, THEN DEALLOCATE CBUFTMP WHEN DONE ! IF ( ASSOCIATED(CBUFTMP) ) THEN CBUF(NLEN+1:NLEN+NBYTES)=CBUFTMP(1:NBYTES) DEALLOCATE(CBUFTMP,STAT=ISTAT) IF (ISTAT.NE.0) THEN PRINT *,' deallocating cbuftmp ... ',istat stop 99 ENDIF NULLIFY(CBUFTMP) NNUM=NNUM+NUMFLD NLEN=NLEN+NBYTES NMESS=NMESS+1 ENDIF ! LOOK FOR NEXT GRIB MESSAGE ISEEK=LSKIP+LGRIB CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) ENDDO C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN END