cktaba.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 2000-09-19
      
C> THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE
C>   OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSLY READ FROM UNIT LUNIT
C>   USING BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR EQUIVALENT (AND NOW
C>   STORED IN THE INTERNAL MESSAGE BUFFER, ARRAY MBAY IN MODULE
C>   BITBUF).  THE TABLE A MNEMONIC IS ASSOCIATED WITH THE BUFR
C>   MESSAGE TYPE/SUBTYPE IN SECTION 1.  IT ALSO FILLS IN THE MESSAGE
C>   CONTROL WORD PARTITION ARRAYS IN MODULE MSGCWD.
C>
C> PROGRAM HISTORY LOG:
C> 2000-09-19  J. WOOLLEN -- ORIGINAL AUTHOR - CONSOLIDATED MESSAGE
C>                           DECODING LOGIC THAT HAD BEEN REPLICATED IN
C>                           READMG, READFT, READERME, RDMEMM AND READIBM
C>                           (CKTABA IS NOW CALLED BY THESE CODES);
C>                           LOGIC ENHANCED HERE TO ALLOW COMPRESSED AND
C>                           STANDARD BUFR MESSAGES TO BE READ
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MODIFIED TO NOT ABORT WHEN THE SECTION 1
C>                           MESSAGE SUBTYPE DOES NOT AGREE WITH THE
C>                           SECTION 1 MESSAGE SUBTYPE IN THE DICTIONARY
C>                           IF THE MESSAGE TYPE MNEMONIC IS NOT OF THE
C>                           FORM "NCtttsss", WHERE ttt IS THE BUFR TYPE
C>                           AND sss IS THE BUFR SUBTYPE (E.G., IN
C>                           "PREPBUFR" FILES); MODIFIED DATE
C>                           CALCULATIONS TO NO LONGER USE FLOATING
C>                           POINT ARITHMETIC SINCE THIS CAN LEAD TO
C>                           ROUND OFF ERROR AND AN IMPROPER RESULTING
C>                           DATE ON SOME MACHINES (E.G., NCEP IBM
C>                           FROST/SNOW), INCREASES PORTABILITY;
C>                           UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
C>                           HAPPEN; SUBSET DEFINED AS "        " IF
C>                           IRET RETURNED AS 11 (BEFORE WAS UNDEFINED)
C> 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2005-11-29  J. ATOR    -- USE IUPBS01, IGETDATE AND GETLENS
C> 2006-04-14  J. ATOR    -- ALLOW "FRtttsss" AND "FNtttsss" AS POSSIBLE
C>                           TABLE A MNEMONICS, WHERE ttt IS THE BUFR
C>                           TYPE AND sss IS THE BUFR SUBTYPE
C> 2009-03-23  J. ATOR    -- ADD LOGIC TO ALLOW SECTION 3 DECODING;
C>                           USE IUPBS3 AND ERRWRT
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL CKTABA (LUN, SUBSET, JDATE, IRET)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   OUTPUT ARGUMENT LIST:
C>     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
C>                BEING CHECKED:
C>                       "        " = IRET equal to 11 (see IRET below)
C>                                    and not using Section 3 decoding
C>     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
C>                MESSAGE BEING CHECKED, IN FORMAT OF EITHER YYMMDDHH OR
C>                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE 
C>     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> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     DIGIT    ERRWRT   GETLENS
C>                               I4DY     IGETDATE IUPB     IUPBS01
C>                               IUPBS3   NEMTBAX  NUMTAB   OPENBT
C>                               RDUSDX
C>    THIS ROUTINE IS CALLED BY: RDMEMM   READERME READMG
C>                               Normally not called by any application
C>                               programs.
C>
      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