cktaba.f

Go to the documentation of this file.

C> @file
C> @brief Parse the Table A mnemonic and date out of Section 1 of a
C> BUFR message.
C>
C> @author Woollen @date 2000-09-19
 
C> This subroutine parses the Table A mnemonic and date
C> out of Section 1 of a BUFR message that was previously read from lun
C> using one of the [message-reading subroutines](@ref hierarchy).
C>
C> @param[in] LUN - integer: I/O stream index into internal memory arrays.
C> @param[out] SUBSET - character*8: Table A mnemonic
C>                      - returned as a string of all blank characters
C>                        if IRET is equal to 11 (see below) and if Section 3
C>                        isn't being used for decoding
C> @param[out] JDATE    - integer: date-time stored within Section 1 of BUFR
C>                        in format of either YYMMDDHH or
C>                        YYYYMMDDHH, depending on datelen() value.
C> @param[out] IRET - integer: return code:
C>                      - 0 normal return
C>                      - -1 unrecognized Table A (message type) value
C>                      - 11 this is a BUFR table (dictionary) message
C>
C> @author Woollen @date 2000-09-19
 
      SUBROUTINE cktaba(LUN,SUBSET,JDATE,IRET)
 
      USE moda_msgcwd
      USE moda_sc3bfr
      USE moda_unptyp
      USE moda_bitbuf
 
      COMMON /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
      COMMON /quiet / iprt
 
      CHARACTER*128 BORT_STR,ERRSTR
      CHARACTER*8   SUBSET
      CHARACTER*2   CPFX(3)
      CHARACTER*1   TAB
      LOGICAL       TRYBT, DIGIT
 
      DATA cpfx   / 'NC', 'FR', 'FN' /
      DATA ncpfx  / 3 /
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      iret = 0
 
      trybt = .true.
 
      jdate = igetdate(mbay(1,lun),iyr,imo,idy,ihr)
 
c  .... Message type
      mtyp = iupbs01(mbay(1,lun),'MTYP')
c  .... Message subtype
      msbt = iupbs01(mbay(1,lun),'MSBT')
 
      IF(mtyp.EQ.11) THEN
c  .... This is a BUFR table (dictionary) message.
         iret = 11
c  .... There's no need to proceed any further unless Section 3 is being
c  .... used for decoding.
         IF(isc3(lun).EQ.0) THEN
            subset = "        "
            GOTO 100
         ENDIF
      ENDIF
 
C  PARSE SECTION 3
C  ---------------
 
      CALL getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
 
      iad3 = len0+len1+len2
 
c  .... First descriptor (integer)
      ksub = iupb(mbay(1,lun),iad3+8 ,16)
c  .... Second descriptor (integer)
      isub = iupb(mbay(1,lun),iad3+10,16)
 
C  LOCATE SECTION 4
C  ----------------
 
      iad4 = iad3+len3
 
C  NOW, TRY TO GET "SUBSET" (MNEMONIC ASSOCIATED WITH TABLE A) FROM MSG
C  --------------------------------------------------------------------
 
C  FIRST CHECK WHETHER SECTION 3 IS BEING USED FOR DECODING
C  --------------------------------------------------------
 
      IF(isc3(lun).NE.0) THEN
        subset = tamnem(lun)
c  .... is SUBSET from Table A?
        CALL nemtbax(lun,subset,mty1,msb1,inod)
        IF(inod.GT.0) THEN
c  ....   yes it is
          mbyt(lun) = 8*(iad4+4)
          msgunp(lun) = 1
          GOTO 10
        ENDIF
      ENDIF
 
C  IF ISUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=0
C  ----------------------------------------------------
 
c  .... get SUBSET from ISUB
5     CALL numtab(lun,isub,subset,tab,itab)
c  .... is SUBSET from Table A?
      CALL nemtbax(lun,subset,mty1,msb1,inod)
      IF(inod.GT.0) THEN
c  .... yes it is
         mbyt(lun) = (iad4+4)
         msgunp(lun) = 0
         GOTO 10
      ENDIF
 
C  IF KSUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=1 (standard)
C  ---------------------------------------------------------------
 
c  .... get SUBSET from KSUB
      CALL numtab(lun,ksub,subset,tab,itab)
c  .... is SUBSET from Table A?
      CALL nemtbax(lun,subset,mty1,msb1,inod)
      IF(inod.GT.0) THEN
c  .... yes it is
         mbyt(lun) = 8*(iad4+4)
         msgunp(lun) = 1
         GOTO 10
      ENDIF
 
C  OKAY, STILL NO "SUBSET", LETS MAKE IT "NCtttsss" (where ttt=MTYP
C  and sss=MSBT) AND SEE IF IT DEFINES TABLE A.  IF NOT, THEN ALSO
C  TRY "FRtttsss" AND "FNtttsss".
C  ----------------------------------------------------------------
 
      ii=1
      DO WHILE(ii.LE.ncpfx)
         WRITE(subset,'(A2,2I3.3)') cpfx(ii),mtyp,msbt
c  ....    is SUBSET from Table A?
         CALL nemtbax(lun,subset,mty1,msb1,inod)
         IF(inod.GT.0) THEN
c  ....     yes it is
            IF(ksub.EQ.ibct) THEN
               mbyt(lun) = (iad4+4)
               msgunp(lun) = 0
            ELSE
               mbyt(lun) = 8*(iad4+4)
               msgunp(lun) = 1
            ENDIF
            GOTO 10
         ENDIF
         ii=ii+1
      ENDDO
 
C  NOW WE HAVE A GENERATED "SUBSET", BUT IT STILL DOES NOT DEFINE
C  TABLE A - MAKE ONE LAST DESPERATE ATTEMPT - SEE IF AN EXTERNAL
C  USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT IS DEFINED
C  IN OPENBT (ONLY POSSIBLE IF APPLICATION PROGRAM HAS AN IN-LINE
C  OPENBT OVERRIDING THE ONE IN THE BUFR ARCHIVE LIBRARY)
C  ------------------------------------------------------------------
 
      IF(trybt) THEN
         trybt = .false.
         IF(iprt.GE.1) THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      errstr = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL'//
     .  ' BUFR TABLE VIA CALL TO IN-LINE OPENBT'
      CALL errwrt(errstr)
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         CALL openbt(lundx,mtyp)
         IF(lundx.GT.0) THEN
c  .... Good news, there is a unit (LUNDX) connected to a table file,
c  .... so store the table internally
            CALL rdusdx(lundx,lun)
            GOTO 5
         ENDIF
      ENDIF
 
C  IF ALL ATTEMPTS TO DEFINE TABLE A FAIL SKIP GIVE UP
C  ---------------------------------------------------
 
      IF(iprt.GE.0)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE ('//
     . subset // ') - RETURN WITH IRET = -1'
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
      iret = -1
      GOTO 100
 
C  CHECK THE VALIDITY OF THE MTYP/MSBT AND FOR COMPRESSION (MSGUNP=2)
C  ------------------------------------------------------------------
 
10    IF(isc3(lun).EQ.0) THEN
        IF(mtyp.NE.mty1) GOTO 900
        IF(msbt.NE.msb1.AND.digit(subset(3:8))) GOTO 901
      ENDIF
      IF(iupbs3(mbay(1,lun),'ICMP').GT.0) msgunp(lun) = 2
 
C  SET THE OTHER REQUIRED PARAMETERS IN MESSAGE CONTROL WORD PARTITION
C  -------------------------------------------------------------------
 
c  .... Date for this message
      idate(lun) = i4dy(jdate)
c  .... Positional index of Table A mnem.
      inode(lun) = inod
c  .... Number of subsets in this message
      msub(lun) = iupbs3(mbay(1,lun),'NSUB')
c  .... Number of subsets read so far from this message
      nsub(lun) = 0
 
      IF(iret.NE.11) THEN
c   .... Number of non-dictionary messages read so far from this file
         nmsg(lun) = nmsg(lun)+1
      ENDIF
 
C  EXITS
C  -----
 
100   RETURN
900   WRITE(bort_str,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH '//
     . '(SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') subset,mtyp,mty1
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH '//
     . '(SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') subset,msbt,msb1
      CALL bort(bort_str)
      END