external/io_grib2/g2lib/getg2ir.F

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM: GETG2IR        CREATES AN INDEX OF A GRIB2 FILE
   6 C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2002-01-02
   7 C
   8 C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS.
   9 C   THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT:
  10 C       BYTE 001 - 004: LENGTH OF INDEX RECORD
  11 C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
  12 C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
  13 C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
  14 C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
  15 C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
  16 C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
  17 C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
  18 C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
  19 C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
  20 C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
  21 C       BYTE 042 - 042: MESSAGE DISCIPLINE
  22 C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
  23 C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
  24 C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
  25 C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
  26 C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
  27 C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
  28 C
  29 C PROGRAM HISTORY LOG:
  30 C   95-10-31  IREDELL
  31 C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
  32 C 2002-01-02  GILBERT   MODIFIED FROM GETGIR TO CREATE GRIB2 INDEXES
  33 C
  34 C USAGE:    CALL GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET)
  35 C   INPUT ARGUMENTS:
  36 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB FILE
  37 C     MSK1         INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE
  38 C     MSK2         INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES
  39 C     MNUM         INTEGER NUMBER OF GRIB MESSAGES TO SKIP (USUALLY 0)
  40 C   OUTPUT ARGUMENTS:
  41 C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
  42 C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
  43 C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
  44 C     NLEN         INTEGER TOTAL LENGTH OF INDEX RECORD BUFFER IN BYTES
  45 C     NNUM         INTEGER NUMBER OF INDEX RECORDS
  46 C                  (=0 IF NO GRIB MESSAGES ARE FOUND)
  47 C     NMESS        LAST GRIB MESSAGE IN FILE SUCCESSFULLY PROCESSED
  48 C     IRET         INTEGER RETURN CODE
  49 C                    0      ALL OK
  50 C                    1      NOT ENOUGH MEMORY AVAILABLE TO HOLD FULL INDEX
  51 C                           BUFFER
  52 C                    2      NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER
  53 C
  54 C SUBPROGRAMS CALLED:
  55 C   SKGB           SEEK NEXT GRIB MESSAGE
  56 C   IXGB2          MAKE INDEX RECORD
  57 C
  58 C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
  59 C   DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR.
  60 C
  61 C ATTRIBUTES:
  62 C   LANGUAGE: FORTRAN 90
  63 C
  64 C$$$
  65       USE RE_ALLOC          ! NEEDED FOR SUBROUTINE REALLOC
  66       PARAMETER(INIT=50000,NEXT=10000)
  67       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  68       INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM
  69       INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET
  70       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUFTMP
  71       INTERFACE      ! REQUIRED FOR CBUF POINTER
  72          SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
  73            INTEGER,INTENT(IN) :: LUGB,LSKIP,LGRIB
  74            CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  75            INTEGER,INTENT(OUT) :: NUMFLD,MLEN,IRET
  76          END SUBROUTINE IXGB2
  77       END INTERFACE
  78 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  79 C  INITIALIZE
  80       IRET=0
  81       IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
  82       MBUF=INIT
  83       ALLOCATE(CBUF(MBUF),STAT=ISTAT)    ! ALLOCATE INITIAL SPACE FOR CBUF
  84       IF (ISTAT.NE.0) THEN
  85          IRET=2
  86          RETURN
  87       ENDIF
  88 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  89 C  SEARCH FOR FIRST GRIB MESSAGE
  90       ISEEK=0
  91       CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB)
  92       DO M=1,MNUM
  93         IF(LGRIB.GT.0) THEN
  94           ISEEK=LSKIP+LGRIB
  95           CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
  96         ENDIF
  97       ENDDO
  98 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  99 C  GET INDEX RECORDS FOR EVERY GRIB MESSAGE FOUND
 100       NLEN=0
 101       NNUM=0
 102       NMESS=MNUM
 103       DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0)
 104         CALL IXGB2(LUGB,LSKIP,LGRIB,CBUFTMP,NUMFLD,NBYTES,IRET1)
 105         IF (IRET1.NE.0) PRINT *,' SAGT ',NUMFLD,NBYTES,IRET1
 106         IF((NBYTES+NLEN).GT.MBUF) THEN             ! ALLOCATE MORE SPACE, IF
 107                                                    ! NECESSARY
 108            NEWSIZE=MAX(MBUF+NEXT,MBUF+NBYTES)
 109            CALL REALLOC(CBUF,NLEN,NEWSIZE,ISTAT)
 110            IF ( ISTAT .NE. 0 ) THEN
 111               IRET=1
 112               RETURN
 113            ENDIF
 114            MBUF=NEWSIZE
 115         ENDIF
 116         !
 117         !  IF INDEX RECORDS WERE RETURNED IN CBUFTMP FROM IXGB2,
 118         !  COPY CBUFTMP INTO CBUF, THEN DEALLOCATE CBUFTMP WHEN DONE
 119         !
 120         IF ( ASSOCIATED(CBUFTMP) ) THEN
 121            CBUF(NLEN+1:NLEN+NBYTES)=CBUFTMP(1:NBYTES)
 122            DEALLOCATE(CBUFTMP,STAT=ISTAT)
 123            IF (ISTAT.NE.0) THEN
 124              PRINT *,' deallocating cbuftmp ... ',istat
 125              stop 99
 126            ENDIF
 127            NULLIFY(CBUFTMP)
 128            NNUM=NNUM+NUMFLD
 129            NLEN=NLEN+NBYTES
 130            NMESS=NMESS+1
 131         ENDIF
 132         !      LOOK FOR NEXT GRIB MESSAGE
 133         ISEEK=LSKIP+LGRIB
 134         CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB)
 135       ENDDO
 136 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 137       RETURN
 138       END