SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET) 4,27
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: CKTABA
C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19
C
C ABSTRACT: 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 COMMON BLOCK
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 COMMON BLOCK /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
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
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES)
COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
. INODE(NFILES),IDATE(NFILES)
COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
. MBAY(MXMSGLD4,NFILES)
COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4
COMMON /UNPTYP/ MSGUNP(NFILES)
COMMON /QUIET / IPRT
CHARACTER*128 BORT_STR,ERRSTR
CHARACTER*8 SUBSET,TAMNEM
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