ungrib/src/ngl/g2/ixgb2.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM: IXGB2          MAKE INDEX RECORDS FOR FIELDS IN A GRIB2 MESSAGE
   6 C   PRGMMR: GILBERT          ORG: W/NP11      DATE: 2001-12-10
   7 C
   8 C ABSTRACT: THIS SUBPROGRAM GENERATES AN INDEX RECORD FOR EACH FIELD IN A
   9 C           GRIB2 MESSAGE.  THE INDEX RECORDS ARE WRITTEN TO INDEX BUFFER
  10 C           POINTED TO BY CBUF.
  11 C
  12 C           EACH INDEX RECORD HAS THE FOLLOWING FORM:
  13 C       BYTE 001 - 004: LENGTH OF INDEX RECORD
  14 C       BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
  15 C       BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
  16 C                       SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
  17 C       BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
  18 C       BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
  19 C       BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
  20 C       BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
  21 C       BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
  22 C       BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
  23 C       BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
  24 C       BYTE 042 - 042: MESSAGE DISCIPLINE
  25 C       BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
  26 C       BYTE 045 -  II: IDENTIFICATION SECTION (IDS)
  27 C       BYTE II+1-  JJ: GRID DEFINITION SECTION (GDS)
  28 C       BYTE JJ+1-  KK: PRODUCT DEFINITION SECTION (PDS)
  29 C       BYTE KK+1-  LL: THE DATA REPRESENTATION SECTION (DRS)
  30 C       BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
  31 C
  32 C PROGRAM HISTORY LOG:
  33 C   95-10-31  IREDELL
  34 C   96-10-31  IREDELL   AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320
  35 C 2001-12-10  GILBERT   MODIFIED FROM IXGB TO CREATE GRIB2 INDEXES
  36 C 2002-01-31  GILBERT   ADDED IDENTIFICATION SECTION TO INDEX RECORD
  37 C
  38 C USAGE:    CALL IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET)
  39 C   INPUT ARGUMENTS:
  40 C     LUGB         INTEGER LOGICAL UNIT OF INPUT GRIB FILE
  41 C     LSKIP        INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE
  42 C     LGRIB        INTEGER NUMBER OF BYTES IN GRIB MESSAGE
  43 C   OUTPUT ARGUMENTS:
  44 C     CBUF         CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS.
  45 C                  USERS SHOULD FREE MEMORY THAT CBUF POINTS TO
  46 C                  USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED.
  47 C     NUMFLD       INTEGER NUMBER OF INDEX RECORDS CREATED.
  48 C                  = 0, IF PROBLEMS
  49 C     MLEN         INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
  50 C     IRET         INTEGER RETURN CODE
  51 C                  =0, ALL OK
  52 C                  =1, NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER
  53 C                  =2, I/O ERROR IN READ
  54 C                  =3, GRIB MESSAGE IS NOT EDITION 2
  55 C                  =4, NOT ENOUGH MEMORY TO ALLOCATE EXTENT TO INDEX BUFFER
  56 C                  =5, UNIDENTIFIED GRIB SECTION ENCOUNTERED...PROBLEM
  57 C                      SOMEWHERE.
  58 C
  59 C SUBPROGRAMS CALLED:
  60 C   GBYTE        GET INTEGER DATA FROM BYTES
  61 C   SBYTE        STORE INTEGER DATA IN BYTES
  62 C   BAREAD       BYTE-ADDRESSABLE READ
  63 C   REALLOC      RE-ALLOCATES MORE MEMORY
  64 C
  65 C ATTRIBUTES:
  66 C   LANGUAGE: FORTRAN 90
  67 C
  68 C$$$
  69       USE RE_ALLOC          ! NEEDED FOR SUBROUTINE REALLOC
  70       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
  71       PARAMETER(LINMAX=5000,INIT=50000,NEXT=10000)
  72       PARAMETER(IXSKP=4,IXLUS=8,IXSGD=12,IXSPD=16,IXSDR=20,IXSBM=24,
  73      &          IXDS=28,IXLEN=36,IXFLD=42,IXIDS=44)
  74       PARAMETER(MXSKP=4,MXLUS=4,MXSGD=4,MXSPD=4,MXSDR=4,MXSBM=4,
  75      &          MXDS=4,MXLEN=4,MXFLD=2,MXBMS=6)
  76       CHARACTER CBREAD(LINMAX),CINDEX(LINMAX)
  77       CHARACTER CVER,CDISC
  78       CHARACTER CIDS(LINMAX),CGDS(LINMAX),CBMS(6)
  79       CHARACTER(LEN=4) :: CTEMP
  80       INTEGER LOCLUS,LOCGDS,LENGDS,LOCBMS
  81 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  82       LOCLUS=0
  83       IRET=0
  84       MLEN=0
  85       NUMFLD=0
  86       IF (ASSOCIATED(CBUF)) NULLIFY(CBUF)
  87       MBUF=INIT
  88       ALLOCATE(CBUF(MBUF),STAT=ISTAT)    ! ALLOCATE INITIAL SPACE FOR CBUF
  89       IF (ISTAT.NE.0) THEN
  90          IRET=1
  91          RETURN
  92       ENDIF
  93 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  94 C  READ SECTIONS 0 AND 1 FOR VERSIN NUMBER AND DISCIPLINE
  95       IBREAD=MIN(LGRIB,LINMAX)
  96       CALL BAREAD(LUGB,LSKIP,IBREAD,LBREAD,CBREAD)
  97       IF(LBREAD.NE.IBREAD) THEN
  98          IRET=2
  99          RETURN
 100       ENDIF
 101       IF(CBREAD(8).NE.CHAR(2)) THEN          !  NOT GRIB EDITION 2
 102          IRET=3
 103          RETURN
 104       ENDIF
 105       CVER=CBREAD(8)
 106       CDISC=CBREAD(7)
 107       CALL GBYTE(CBREAD,LENSEC1,16*8,4*8)
 108       LENSEC1=MIN(LENSEC1,IBREAD)
 109       CIDS(1:LENSEC1)=CBREAD(17:16+LENSEC1)
 110       IBSKIP=LSKIP+16+LENSEC1
 111 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 112 C  LOOP THROUGH REMAINING SECTIONS CREATING AN INDEX FOR EACH FIELD
 113       IBREAD=MAX(5,MXBMS)
 114       DO
 115          CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD)
 116          CTEMP=CBREAD(1)//CBREAD(2)//CBREAD(3)//CBREAD(4)
 117          IF (CTEMP.EQ.'7777') RETURN        ! END OF MESSAGE FOUND
 118          IF(LBREAD.NE.IBREAD) THEN
 119             IRET=2
 120             RETURN
 121          ENDIF
 122          CALL GBYTE(CBREAD,LENSEC,0*8,4*8)
 123          CALL GBYTE(CBREAD,NUMSEC,4*8,1*8)
 124
 125          IF (NUMSEC.EQ.2) THEN                 ! SAVE LOCAL USE LOCATION
 126             LOCLUS=IBSKIP-LSKIP
 127          ELSEIF (NUMSEC.EQ.3) THEN                 ! SAVE GDS INFO
 128             LENGDS=LENSEC
 129             CGDS=CHAR(0)
 130             CALL BAREAD(LUGB,IBSKIP,LENGDS,LBREAD,CGDS)
 131             IF(LBREAD.NE.LENGDS) THEN
 132                IRET=2
 133                RETURN
 134             ENDIF
 135             LOCGDS=IBSKIP-LSKIP
 136          ELSEIF (NUMSEC.EQ.4) THEN                 ! FOUND PDS
 137             CINDEX=CHAR(0)
 138             CALL SBYTE(CINDEX,LSKIP,8*IXSKP,8*MXSKP)    ! BYTES TO SKIP
 139             CALL SBYTE(CINDEX,LOCLUS,8*IXLUS,8*MXLUS)   ! LOCATION OF LOCAL USE
 140             CALL SBYTE(CINDEX,LOCGDS,8*IXSGD,8*MXSGD)   ! LOCATION OF GDS
 141             CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSPD,8*MXSPD)  ! LOCATION OF PDS
 142             CALL SBYTE(CINDEX,LGRIB,8*IXLEN,8*MXLEN)    ! LEN OF GRIB2
 143             CINDEX(41)=CVER
 144             CINDEX(42)=CDISC
 145             CALL SBYTE(CINDEX,NUMFLD+1,8*IXFLD,8*MXFLD)   ! FIELD NUM
 146             CINDEX(IXIDS+1:IXIDS+LENSEC1)=CIDS(1:LENSEC1)
 147             LINDEX=IXIDS+LENSEC1
 148             CINDEX(LINDEX+1:LINDEX+LENGDS)=CGDS(1:LENGDS)
 149             LINDEX=LINDEX+LENGDS
 150             ILNPDS=LENSEC
 151             CALL BAREAD(LUGB,IBSKIP,ILNPDS,LBREAD,CINDEX(LINDEX+1))
 152             IF(LBREAD.NE.ILNPDS) THEN
 153                IRET=2
 154                RETURN
 155             ENDIF
 156             !   CINDEX(LINDEX+1:LINDEX+ILNPDS)=CBREAD(1:ILNPDS)
 157             LINDEX=LINDEX+ILNPDS
 158          ELSEIF (NUMSEC.EQ.5) THEN                 ! FOUND DRS
 159             CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSDR,8*MXSDR)  ! LOCATION OF DRS
 160             ILNDRS=LENSEC
 161             CALL BAREAD(LUGB,IBSKIP,ILNDRS,LBREAD,CINDEX(LINDEX+1))
 162             IF(LBREAD.NE.ILNDRS) THEN
 163                IRET=2
 164                RETURN
 165             ENDIF
 166             !   CINDEX(LINDEX+1:LINDEX+ILNDRS)=CBREAD(1:ILNDRS)
 167             LINDEX=LINDEX+ILNDRS
 168          ELSEIF (NUMSEC.EQ.6) THEN                 ! FOUND BMS
 169             INDBMP=MOV_A2I(CBREAD(6))
 170             IF ( INDBMP.LT.254 ) THEN
 171                LOCBMS=IBSKIP-LSKIP
 172                CALL SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
 173             ELSEIF ( INDBMP.EQ.254 ) THEN
 174                CALL SBYTE(CINDEX,LOCBMS,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
 175             ELSEIF ( INDBMP.EQ.255 ) THEN
 176                CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXSBM,8*MXSBM)  ! LOC. OF BMS
 177             ENDIF
 178             CINDEX(LINDEX+1:LINDEX+MXBMS)=CBREAD(1:MXBMS)
 179             LINDEX=LINDEX+MXBMS
 180             CALL SBYTE(CINDEX,LINDEX,0,8*4)    ! NUM BYTES IN INDEX RECORD
 181          ELSEIF (NUMSEC.EQ.7) THEN                 ! FOUND DATA SECTION
 182             CALL SBYTE(CINDEX,IBSKIP-LSKIP,8*IXDS,8*MXDS)   ! LOC. OF DATA SEC.
 183             NUMFLD=NUMFLD+1
 184             IF ((LINDEX+MLEN).GT.MBUF) THEN        ! ALLOCATE MORE SPACE IF
 185                                                    ! NECESSARY
 186                NEWSIZE=MAX(MBUF+NEXT,MBUF+LINDEX)
 187                CALL REALLOC(CBUF,MLEN,NEWSIZE,ISTAT)
 188                IF ( ISTAT .NE. 0 ) THEN
 189                   NUMFLD=NUMFLD-1
 190                   IRET=4
 191                   RETURN
 192                ENDIF
 193                MBUF=NEWSIZE
 194             ENDIF
 195             CBUF(MLEN+1:MLEN+LINDEX)=CINDEX(1:LINDEX)
 196             MLEN=MLEN+LINDEX
 197          ELSE                           ! UNRECOGNIZED SECTION
 198             IRET=5
 199             RETURN
 200          ENDIF
 201          IBSKIP=IBSKIP+LENSEC
 202       ENDDO
 203
 204 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 205       RETURN
 206       END