ungrib/src/ngl/g2/getgb2rp.f

   1 C-----------------------------------------------------------------------
   2       SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM: GETGB2RP       EXTRACTS A GRIB MESSAGE FROM A FILE
   6 C   PRGMMR: GILBERT          ORG: W/NMC23     DATE: 2003-12-31
   7 C
   8 C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE GIVEN THE
   9 C   INDEX FOR THE REQUESTED FIELD.
  10 C   THE GRIB MESSAGE RETURNED CAN CONTAIN ONLY THE REQUESTED FIELD
  11 C   (EXTRACT=.TRUE.). OR THE COMPLETE GRIB MESSAGE ORIGINALLY CONTAINING
  12 C   THE DESIRED FIELD CAN BE RETURNED (EXTRACT=.FALSE.) EVEN IF OTHER
  13 C   FIELDS WERE INCLUDED IN THE GRIB MESSAGE.
  14 C   IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 2003-12-31  GILBERT
  18 C
  19 C USAGE:    CALL GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET)
  20 C   INPUT ARGUMENTS:
  21 C     LUGB         INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
  22 C                  FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING
  23 C                  THIS ROUTINE.
  24 C     CINDEX       INDEX RECORD OF THE GRIB FILE  ( SEE DOCBLOCK OF
  25 C                  SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.)
  26 C     EXTRACT       LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2
  27 C                   MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE
  28 C                   GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD.
  29 C                  .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED
  30 C                           FIELD.
  31 C                  .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE
  32 C                            REQUESTED FIELD.
  33 C
  34 C   OUTPUT ARGUMENTS:
  35 C     GRIBM         RETURNED GRIB MESSAGE.
  36 C     LENG         LENGTH OF RETURNED GRIB MESSAGE IN BYTES.
  37 C     IRET         INTEGER RETURN CODE
  38 C                    0      ALL OK
  39 C                    97     ERROR READING GRIB FILE
  40 C
  41 C SUBPROGRAMS CALLED:
  42 C   BAREAD          BYTE-ADDRESSABLE READ
  43 C
  44 C REMARKS: NONE
  45 C
  46 C ATTRIBUTES:
  47 C   LANGUAGE: FORTRAN 90
  48 C
  49 C$$$
  50
  51       INTEGER,INTENT(IN) :: LUGB
  52       CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*)
  53       LOGICAL,INTENT(IN) :: EXTRACT
  54       INTEGER,INTENT(OUT) :: LENG,IRET
  55       CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM
  56
  57       INTEGER,PARAMETER :: ZERO=0
  58       CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CSEC2,CSEC6,CSEC7
  59       CHARACTER(LEN=4) :: Ctemp
  60
  61       IRET=0
  62 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  63 C  EXTRACT GRIB MESSAGE FROM FILE
  64       IF ( EXTRACT ) THEN
  65          LEN0=16
  66          LEN8=4
  67          CALL GBYTE(CINDEX,ISKIP,4*8,4*8)    ! BYTES TO SKIP IN FILE
  68          CALL GBYTE(CINDEX,ISKP2,8*8,4*8)    ! BYTES TO SKIP FOR section 2
  69          if ( iskp2 .gt. 0 ) then
  70             CALL BAREAD(LUGB,ISKIP+ISKP2,4,LREAD,ctemp)
  71             CALL GBYTE(Ctemp,LEN2,0,4*8)      ! LENGTH OF SECTION 2
  72             ALLOCATE(csec2(len2))
  73             CALL BAREAD(LUGB,ISKIP+ISKP2,LEN2,LREAD,csec2)
  74          else
  75             LEN2=0
  76          endif
  77          CALL GBYTE(CINDEX,LEN1,44*8,4*8)      ! LENGTH OF SECTION 1
  78          IPOS=44+LEN1
  79          CALL GBYTE(CINDEX,LEN3,IPOS*8,4*8)      ! LENGTH OF SECTION 3
  80          IPOS=IPOS+LEN3
  81          CALL GBYTE(CINDEX,LEN4,IPOS*8,4*8)      ! LENGTH OF SECTION 4
  82          IPOS=IPOS+LEN4
  83          CALL GBYTE(CINDEX,LEN5,IPOS*8,4*8)      ! LENGTH OF SECTION 5
  84          IPOS=IPOS+LEN5
  85          CALL GBYTE(CINDEX,LEN6,IPOS*8,4*8)      ! LENGTH OF SECTION 6
  86          IPOS=IPOS+5
  87          CALL GBYTE(CINDEX,IBMAP,IPOS*8,1*8)      ! Bitmap indicator
  88          IF ( IBMAP .eq. 254 ) THEN
  89             CALL GBYTE(CINDEX,ISKP6,24*8,4*8)    ! BYTES TO SKIP FOR section 6
  90             CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp)
  91             CALL GBYTE(Ctemp,LEN6,0,4*8)      ! LENGTH OF SECTION 6
  92          ENDIF
  93          !
  94          !  READ IN SECTION 7 from file
  95          !
  96          CALL GBYTE(CINDEX,ISKP7,28*8,4*8)    ! BYTES TO SKIP FOR section 7
  97          CALL BAREAD(LUGB,ISKIP+ISKP7,4,LREAD,ctemp)
  98          CALL GBYTE(Ctemp,LEN7,0,4*8)      ! LENGTH OF SECTION 7
  99          ALLOCATE(csec7(len7))
 100          CALL BAREAD(LUGB,ISKIP+ISKP7,LEN7,LREAD,csec7)
 101
 102          LENG=LEN0+LEN1+LEN2+LEN3+LEN4+LEN5+LEN6+LEN7+LEN8
 103          IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
 104
 105          ! Create Section 0
 106          !
 107          GRIBM(1)='G'
 108          GRIBM(2)='R'
 109          GRIBM(3)='I'
 110          GRIBM(4)='B'
 111          GRIBM(5)=CHAR(0)
 112          GRIBM(6)=CHAR(0)
 113          GRIBM(7)=CINDEX(42)
 114          GRIBM(8)=CINDEX(41)
 115          GRIBM(9)=CHAR(0)
 116          GRIBM(10)=CHAR(0)
 117          GRIBM(11)=CHAR(0)
 118          GRIBM(12)=CHAR(0)
 119          CALL SBYTE(GRIBM,LENG,12*8,4*8)
 120          !
 121          ! Copy Section 1
 122          !
 123          GRIBM(17:16+LEN1)=CINDEX(45:44+LEN1)
 124          lencur=16+LEN1
 125          ipos=44+len1
 126          !
 127          ! Copy Section 2, if necessary
 128          !
 129          if ( iskp2 .gt. 0 ) then
 130            GRIBM(lencur+1:lencur+LEN2)=csec2(1:LEN2)
 131            lencur=lencur+LEN2
 132          endif
 133          !
 134          ! Copy Sections 3 through 5
 135          !
 136          GRIBM(lencur+1:lencur+LEN3+LEN4+LEN5)=
 137      &                      CINDEX(ipos+1:ipos+LEN3+LEN4+LEN5)
 138          lencur=lencur+LEN3+LEN4+LEN5
 139          ipos=ipos+LEN3+LEN4+LEN5
 140          !
 141          ! Copy Section 6
 142          !
 143          if ( LEN6 .eq. 6 .AND. IBMAP .ne. 254 ) then
 144             GRIBM(lencur+1:lencur+LEN6)=CINDEX(ipos+1:ipos+LEN6)
 145             lencur=lencur+LEN6
 146          else
 147             CALL GBYTE(CINDEX,ISKP6,24*8,4*8)    ! BYTES TO SKIP FOR section 6
 148             CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp)
 149             CALL GBYTE(Ctemp,LEN6,0,4*8)      ! LENGTH OF SECTION 6
 150             ALLOCATE(csec6(len6))
 151             CALL BAREAD(LUGB,ISKIP+ISKP6,LEN6,LREAD,csec6)
 152             GRIBM(lencur+1:lencur+LEN6)=csec6(1:LEN6)
 153             lencur=lencur+LEN6
 154             IF ( allocated(csec6)) DEALLOCATE(csec6)
 155          endif
 156          !
 157          ! Copy Section 7
 158          !
 159          GRIBM(lencur+1:lencur+LEN7)=csec7(1:LEN7)
 160          lencur=lencur+LEN7
 161          !
 162          ! Section 8
 163          !
 164          GRIBM(lencur+1)='7'
 165          GRIBM(lencur+2)='7'
 166          GRIBM(lencur+3)='7'
 167          GRIBM(lencur+4)='7'
 168
 169          !  clean up
 170          !
 171          IF ( allocated(csec2)) DEALLOCATE(csec2)
 172          IF ( allocated(csec7)) deallocate(csec7)
 173
 174       ELSE    ! DO NOT extract field from message :  Get entire message
 175
 176          CALL GBYTE(CINDEX,ISKIP,4*8,4*8)    ! BYTES TO SKIP IN FILE
 177          CALL GBYTE(CINDEX,LENG,36*8,4*8)      ! LENGTH OF GRIB MESSAGE
 178          IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG))
 179          CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM)
 180          IF ( LENG .NE. LREAD ) THEN
 181             DEALLOCATE(GRIBM)
 182             NULLIFY(GRIBM)
 183             IRET=97
 184             RETURN
 185          ENDIF
 186       ENDIF
 187 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 188       RETURN
 189       END