var/external/bufr/cktaba.f

   1       SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    CKTABA
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2000-09-19
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE
   9 C   OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSLY READ FROM UNIT LUNIT
  10 C   USING BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR EQUIVALENT (AND NOW
  11 C   STORED IN THE INTERNAL MESSAGE BUFFER, ARRAY MBAY IN COMMON BLOCK
  12 C   /BITBUF/).  THE TABLE A MNEMONIC IS ASSOCIATED WITH THE BUFR
  13 C   MESSAGE TYPE/SUBTYPE IN SECTION 1.  IT ALSO FILLS IN THE MESSAGE
  14 C   CONTROL WORD PARTITION ARRAYS IN COMMON BLOCK /MSGCWD/.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 2000-09-19  J. WOOLLEN -- ORIGINAL AUTHOR - CONSOLIDATED MESSAGE
  18 C                           DECODING LOGIC THAT HAD BEEN REPLICATED IN
  19 C                           READMG, READFT, READERME, RDMEMM AND READIBM
  20 C                           (CKTABA IS NOW CALLED BY THESE CODES);
  21 C                           LOGIC ENHANCED HERE TO ALLOW COMPRESSED AND
  22 C                           STANDARD BUFR MESSAGES TO BE READ
  23 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  24 C                           INTERDEPENDENCIES
  25 C 2003-11-04  D. KEYSER  -- MODIFIED TO NOT ABORT WHEN THE SECTION 1
  26 C                           MESSAGE SUBTYPE DOES NOT AGREE WITH THE
  27 C                           SECTION 1 MESSAGE SUBTYPE IN THE DICTIONARY
  28 C                           IF THE MESSAGE TYPE MNEMONIC IS NOT OF THE
  29 C                           FORM "NCtttsss", WHERE ttt IS THE BUFR TYPE
  30 C                           AND sss IS THE BUFR SUBTYPE (E.G., IN
  31 C                           "PREPBUFR" FILES); MODIFIED DATE
  32 C                           CALCULATIONS TO NO LONGER USE FLOATING
  33 C                           POINT ARITHMETIC SINCE THIS CAN LEAD TO
  34 C                           ROUND OFF ERROR AND AN IMPROPER RESULTING
  35 C                           DATE ON SOME MACHINES (E.G., NCEP IBM
  36 C                           FROST/SNOW), INCREASES PORTABILITY;
  37 C                           UNIFIED/PORTABLE FOR WRF; ADDED
  38 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  39 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  40 C                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
  41 C                           HAPPEN; SUBSET DEFINED AS "        " IF
  42 C                           IRET RETURNED AS 11 (BEFORE WAS UNDEFINED)
  43 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  44 C                           20,000 TO 50,000 BYTES
  45 C 2005-11-29  J. ATOR    -- USE IUPBS01, IGETDATE AND GETLENS
  46 C 2006-04-14  J. ATOR    -- ALLOW "FRtttsss" AND "FNtttsss" AS POSSIBLE
  47 C                           TABLE A MNEMONICS, WHERE ttt IS THE BUFR
  48 C                           TYPE AND sss IS THE BUFR SUBTYPE
  49 C 2009-03-23  J. ATOR    -- ADD LOGIC TO ALLOW SECTION 3 DECODING;
  50 C                           USE IUPBS3 AND ERRWRT
  51 C
  52 C USAGE:    CALL CKTABA (LUN, SUBSET, JDATE, IRET)
  53 C   INPUT ARGUMENT LIST:
  54 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  55 C
  56 C   OUTPUT ARGUMENT LIST:
  57 C     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
  58 C                BEING CHECKED:
  59 C                       "        " = IRET equal to 11 (see IRET below)
  60 C                                    and not using Section 3 decoding
  61 C     JDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
  62 C                MESSAGE BEING CHECKED, IN FORMAT OF EITHER YYMMDDHH OR
  63 C                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
  64 C     IRET     - INTEGER: RETURN CODE:
  65 C                       0 = normal return
  66 C                      -1 = unrecognized Table A (message type) value
  67 C                      11 = this is a BUFR table (dictionary) message
  68 C
  69 C REMARKS:
  70 C    THIS ROUTINE CALLS:        BORT     DIGIT    ERRWRT   GETLENS
  71 C                               I4DY     IGETDATE IUPB     IUPBS01
  72 C                               IUPBS3   NEMTBAX  NUMTAB   OPENBT
  73 C                               RDUSDX
  74 C    THIS ROUTINE IS CALLED BY: RDMEMM   READERME READMG
  75 C                               Normally not called by any application
  76 C                               programs.
  77 C
  78 C ATTRIBUTES:
  79 C   LANGUAGE: FORTRAN 77
  80 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  81 C
  82 C$$$
  83
  84       INCLUDE 'bufrlib.prm'
  85
  86       COMMON /SC3BFR/ ISC3(NFILES),TAMNEM(NFILES)
  87       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  88      .                INODE(NFILES),IDATE(NFILES)
  89       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  90      .                MBAY(MXMSGLD4,NFILES)
  91       COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4
  92       COMMON /UNPTYP/ MSGUNP(NFILES)
  93       COMMON /QUIET / IPRT
  94
  95       CHARACTER*128 BORT_STR,ERRSTR
  96       CHARACTER*8   SUBSET,TAMNEM
  97       CHARACTER*2   CPFX(3)
  98       CHARACTER*1   TAB
  99       LOGICAL       TRYBT, DIGIT
 100
 101       DATA CPFX   / 'NC', 'FR', 'FN' /
 102       DATA NCPFX  / 3 /
 103
 104 C-----------------------------------------------------------------------
 105 C-----------------------------------------------------------------------
 106
 107       IRET = 0
 108
 109       TRYBT = .TRUE.
 110
 111       JDATE = IGETDATE(MBAY(1,LUN),IYR,IMO,IDY,IHR)
 112
 113 c  .... Message type
 114       MTYP = IUPBS01(MBAY(1,LUN),'MTYP')
 115 c  .... Message subtype
 116       MSBT = IUPBS01(MBAY(1,LUN),'MSBT')
 117
 118       IF(MTYP.EQ.11) THEN
 119 c  .... This is a BUFR table (dictionary) message.
 120          IRET = 11
 121 c  .... There's no need to proceed any further unless Section 3 is being
 122 c  .... used for decoding.
 123          IF(ISC3(LUN).EQ.0) THEN
 124             SUBSET = "        "
 125             GOTO 100
 126          ENDIF
 127       ENDIF
 128
 129 C  PARSE SECTION 3
 130 C  ---------------
 131
 132       CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5)
 133
 134       IAD3 = LEN0+LEN1+LEN2
 135
 136 c  .... First descriptor (integer)
 137       KSUB = IUPB(MBAY(1,LUN),IAD3+8 ,16)
 138 c  .... Second descriptor (integer)
 139       ISUB = IUPB(MBAY(1,LUN),IAD3+10,16)
 140
 141 C  LOCATE SECTION 4
 142 C  ----------------
 143
 144       IAD4 = IAD3+LEN3
 145
 146 C  NOW, TRY TO GET "SUBSET" (MNEMONIC ASSOCIATED WITH TABLE A) FROM MSG
 147 C  --------------------------------------------------------------------
 148
 149 C  FIRST CHECK WHETHER SECTION 3 IS BEING USED FOR DECODING
 150 C  --------------------------------------------------------
 151
 152       IF(ISC3(LUN).NE.0) THEN
 153         SUBSET = TAMNEM(LUN)
 154 c  .... is SUBSET from Table A?
 155         CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD)
 156         IF(INOD.GT.0) THEN
 157 c  ....   yes it is
 158           MBYT(LUN) = 8*(IAD4+4)
 159           MSGUNP(LUN) = 1
 160           GOTO 10
 161         ENDIF
 162       ENDIF
 163
 164 C  IF ISUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=0
 165 C  ----------------------------------------------------
 166
 167 c  .... get SUBSET from ISUB
 168 5     CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB)
 169 c  .... is SUBSET from Table A?
 170       CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD)
 171       IF(INOD.GT.0) THEN
 172 c  .... yes it is
 173          MBYT(LUN) = (IAD4+4)
 174          MSGUNP(LUN) = 0
 175          GOTO 10
 176       ENDIF
 177
 178 C  IF KSUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=1 (standard)
 179 C  ---------------------------------------------------------------
 180
 181 c  .... get SUBSET from KSUB
 182       CALL NUMTAB(LUN,KSUB,SUBSET,TAB,ITAB)
 183 c  .... is SUBSET from Table A?
 184       CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD)
 185       IF(INOD.GT.0) THEN
 186 c  .... yes it is
 187          MBYT(LUN) = 8*(IAD4+4)
 188          MSGUNP(LUN) = 1
 189          GOTO 10
 190       ENDIF
 191
 192 C  OKAY, STILL NO "SUBSET", LETS MAKE IT "NCtttsss" (where ttt=MTYP
 193 C  and sss=MSBT) AND SEE IF IT DEFINES TABLE A.  IF NOT, THEN ALSO
 194 C  TRY "FRtttsss" AND "FNtttsss".
 195 C  ----------------------------------------------------------------
 196
 197       II=1
 198       DO WHILE(II.LE.NCPFX)
 199          WRITE(SUBSET,'(A2,2I3.3)') CPFX(II),MTYP,MSBT
 200 c  ....    is SUBSET from Table A?
 201          CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD)
 202          IF(INOD.GT.0) THEN
 203 c  ....     yes it is
 204             IF(KSUB.EQ.IBCT) THEN
 205                MBYT(LUN) = (IAD4+4)
 206                MSGUNP(LUN) = 0
 207             ELSE
 208                MBYT(LUN) = 8*(IAD4+4)
 209                MSGUNP(LUN) = 1
 210             ENDIF
 211             GOTO 10
 212          ENDIF
 213          II=II+1
 214       ENDDO
 215
 216 C  NOW WE HAVE A GENERATED "SUBSET", BUT IT STILL DOES NOT DEFINE
 217 C  TABLE A - MAKE ONE LAST DESPERATE ATTEMPT - SEE IF AN EXTERNAL
 218 C  USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT IS DEFINED
 219 C  IN OPENBT (ONLY POSSIBLE IF APPLICATION PROGRAM HAS AN IN-LINE
 220 C  OPENBT OVERRIDING THE ONE IN THE BUFR ARCHIVE LIBRARY)
 221 C  ------------------------------------------------------------------
 222
 223       IF(TRYBT) THEN
 224          TRYBT = .FALSE.
 225          IF(IPRT.GE.1) THEN
 226       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 227       ERRSTR = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL'//
 228      .  ' BUFR TABLE VIA CALL TO IN-LINE OPENBT'
 229       CALL ERRWRT(ERRSTR)
 230       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 231       CALL ERRWRT(' ')
 232          ENDIF
 233          CALL OPENBT(LUNDX,MTYP)
 234          IF(LUNDX.GT.0) THEN
 235 c  .... Good news, there is a unit (LUNDX) connected to a table file,
 236 c  .... so store the table internally
 237             CALL RDUSDX(LUNDX,LUN)
 238             GOTO 5
 239          ENDIF
 240       ENDIF
 241
 242 C  IF ALL ATTEMPTS TO DEFINE TABLE A FAIL SKIP GIVE UP
 243 C  ---------------------------------------------------
 244
 245       IF(IPRT.GE.0)  THEN
 246       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 247       ERRSTR = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE ('//
 248      . SUBSET // ') - RETURN WITH IRET = -1'
 249       CALL ERRWRT(ERRSTR)
 250       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 251       CALL ERRWRT(' ')
 252       ENDIF
 253       IRET = -1
 254       GOTO 100
 255
 256 C  CHECK THE VALIDITY OF THE MTYP/MSBT AND FOR COMPRESSION (MSGUNP=2)
 257 C  ------------------------------------------------------------------
 258
 259 10    IF(ISC3(LUN).EQ.0) THEN
 260         IF(MTYP.NE.MTY1) GOTO 900
 261         IF(MSBT.NE.MSB1.AND.DIGIT(SUBSET(3:8))) GOTO 901
 262       ENDIF
 263       IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) MSGUNP(LUN) = 2
 264
 265 C  SET THE OTHER REQUIRED PARAMETERS IN MESSAGE CONTROL WORD PARTITION
 266 C  -------------------------------------------------------------------
 267
 268 c  .... Date for this message
 269       IDATE(LUN) = I4DY(JDATE)
 270 c  .... Positional index of Table A mnem.
 271       INODE(LUN) = INOD
 272 c  .... Number of subsets in this message
 273       MSUB(LUN) = IUPBS3(MBAY(1,LUN),'NSUB')
 274 c  .... Number of subsets read so far from this message
 275       NSUB(LUN) = 0
 276
 277       IF(IRET.NE.11) THEN
 278 c   .... Number of non-dictionary messages read so far from this file
 279          NMSG(LUN) = NMSG(LUN)+1
 280       ENDIF
 281
 282 C  EXITS
 283 C  -----
 284
 285 100   RETURN
 286 900   WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH '//
 287      . '(SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') SUBSET,MTYP,MTY1
 288       CALL BORT(BORT_STR)
 289 901   WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH '//
 290      . '(SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') SUBSET,MSBT,MSB1
 291       CALL BORT(BORT_STR)
 292       END