var/external/bufr/rdusdx.f

   1       SUBROUTINE RDUSDX(LUNDX,LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    RDUSDX
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER-
   9 C   SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT, AND THEN STORES
  10 C   THIS INFORMATION INTO INTERNAL ARRAYS IN COMMON BLOCK /TABABD/ (SEE
  11 C   REMARKS FOR CONTENTS OF INTERNAL ARRAYS).  THIS SUBROUTINE PERFORMS
  12 C   A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE RDBFDX,
  13 C   EXECPT THAT RDBFDX READS THE BUFR TABLE DIRECTLY FROM MESSAGES AT
  14 C   BEGINNING OF AN INPUT BUFR FILE.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  18 C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  19 C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  20 C 1996-12-17  J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF
  21 C                           INTERNAL READS (INCREASES PORTABILITY)
  22 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  23 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  24 C                           ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
  25 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  26 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  27 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  28 C                           BUFR FILES UNDER THE MPI)
  29 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  30 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  31 C                           INTERDEPENDENCIES
  32 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  33 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  34 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  35 C                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
  36 C 2006-04-14  D. KEYSER  -- ABORTS IF A USER-DEFINED MESSAGE TYPE "011"
  37 C                           IS READ (EITHER DIRECTLY FROM A TABLE A
  38 C                           MNEMONIC OR FROM THE "Y" VALUE OF A TABLE A
  39 C                           FXY SEQUENCE DESCRIPTOR), MESSAGE TYPE
  40 C                           "011" IS RESERVED FOR DICTIONARY MESSAGES
  41 C                           (PREVIOUSLY WOULD STORE DATA WITH MESSAGE
  42 C                           TYPE "011" BUT SUCH MESSAGES WOULD BE
  43 C                           SKIPPED OVER WHEN READ)
  44 C 2007-01-19  J. ATOR    -- MODIFIED IN RESPONSE TO NUMBCK CHANGES
  45 C 2009-03-23  J. ATOR    -- INCREASE SIZE OF BORT_STR2; USE STNTBIA
  46 C 2013-01-08  J. WHITING -- ADD ERR= OPTION TO READ STATEMENT
  47 C
  48 C USAGE:    CALL RDUSDX (LUNDX, LUN)
  49 C   INPUT ARGUMENT LIST:
  50 C     LUNDX    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER-
  51 C                SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT
  52 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  53 C
  54 C   INPUT FILES:
  55 C     UNIT "LUNDX" - USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER
  56 C                    FORMAT
  57 C
  58 C REMARKS:
  59 C    CONTENTS OF INTERNAL ARRAYS WRITTEN INTO COMMON BLOCK /TABABD/:
  60 C
  61 C     For Table A entries:
  62 C        NTBA(LUN)     - INTEGER: Number of Table A entries (note that
  63 C                        NTBA(0) contains the maximum number of such
  64 C                        entries as set within subroutine BFRINI)
  65 C        TABA(N,LUN)   - CHARACTER*128: Table A entries, where
  66 C                        N=1,2,3,...,NTBA(LUN)
  67 C        IDNA(N,LUN,1) - INTEGER: Message type corresponding to
  68 C                        TABA(N,LUN)
  69 C        IDNA(N,LUN,2) - INTEGER: Message subtype corresponding to
  70 C                        TABA(N,LUN)
  71 C
  72 C     For Table B entries:
  73 C        NTBB(LUN)     - INTEGER: Number of Table B entries (note that
  74 C                        NTBB(0) contains the maximum number of such
  75 C                        entries as set within subroutine BFRINI)
  76 C        TABB(N,LUN)   - CHARACTER*128: Table B entries, where
  77 C                        N=1,2,3,...,NTBB(LUN)
  78 C        IDNB(N,LUN)   - INTEGER: Bit-wise representation of the FXY
  79 C                        value corresponding to TABB(N,LUN)
  80 C
  81 C     For Table D entries:
  82 C        NTBD(LUN)     - INTEGER: Number of Table D entries (note that
  83 C                        NTBD(0) contains the maximum number of such
  84 C                        entries as set within subroutine BFRINI)
  85 C        TABD(N,LUN)   - CHARACTER*600: Table D entries, where
  86 C                        N=1,2,3,...,NTBD(LUN)
  87 C        IDND(N,LUN)   - INTEGER: Bit-wise representation of the FXY
  88 C                        value corresponding to TABD(N,LUN)
  89 C
  90 C
  91 C    THIS ROUTINE CALLS:        BORT2    DXINIT   ELEMDX   IGETNTBI
  92 C                               MAKESTAB NEMOCK   NUMBCK   SEQSDX
  93 C                               STNTBI   STNTBIA
  94 C    THIS ROUTINE IS CALLED BY: CKTABA   READDX
  95 C                               Normally not called by any application
  96 C                               programs.
  97 C
  98 C ATTRIBUTES:
  99 C   LANGUAGE: FORTRAN 77
 100 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 101 C
 102 C$$$
 103
 104       INCLUDE 'bufrlib.prm'
 105
 106       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
 107      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
 108      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
 109      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
 110      .                TABD(MAXTBD,NFILES)
 111
 112       CHARACTER*600 TABD
 113       CHARACTER*128 BORT_STR1
 114       CHARACTER*156 BORT_STR2
 115       CHARACTER*128 TABB
 116       CHARACTER*128 TABA
 117       CHARACTER*80  CARD
 118       CHARACTER*8   NEMO
 119       CHARACTER*6   NUMB,NMB2
 120
 121 C-----------------------------------------------------------------------
 122 C-----------------------------------------------------------------------
 123
 124 C  INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS
 125 C  WITH APRIORI TABLE B AND D ENTRIES
 126 C  --------------------------------------------------------------
 127
 128       CALL DXINIT(LUN,1)
 129       REWIND LUNDX
 130
 131 C  READ USER CARDS UNTIL THERE ARE NO MORE
 132 C  ---------------------------------------
 133
 134 1     READ(LUNDX,'(A80)',END=200,ERR=200) CARD
 135
 136 C  REREAD IF NOT A DEFINITION CARD
 137 C  -------------------------------
 138
 139 c  .... This is a comment line
 140       IF(CARD(1: 1).EQ.       '*') GOTO 1
 141 c  .... This is a separation line
 142       IF(CARD(3:10).EQ.'--------') GOTO 1
 143 c  .... This is a blank line
 144       IF(CARD(3:10).EQ.'        ') GOTO 1
 145 c  .... This is a header line
 146       IF(CARD(3:10).EQ.'MNEMONIC') GOTO 1
 147 c  .... This is a header line
 148       IF(CARD(3:10).EQ.'TABLE  D') GOTO 1
 149 c  .... This is a header line
 150       IF(CARD(3:10).EQ.'TABLE  B') GOTO 1
 151
 152 C  PARSE A DESCRIPTOR DEFINITION CARD
 153 C  ----------------------------------
 154
 155       IF(CARD(12:12).EQ.'|' .AND. CARD(21:21).EQ.'|') THEN
 156
 157 c  .... NEMO is the 8-character mnemonic name
 158          NEMO = CARD(3:10)
 159          IRET=NEMOCK(NEMO)
 160          IF(IRET.EQ.-1) GOTO 900
 161          IF(IRET.EQ.-2) GOTO 901
 162
 163 c  .... NUMB is the 6-character FXY value corresponding to NEMO
 164          NUMB = CARD(14:19)
 165          NMB2 = NUMB
 166          IF(NMB2(1:1).EQ.'A') NMB2(1:1) = '3'
 167          IRET=NUMBCK(NMB2)
 168          IF(IRET.EQ.-1) GOTO 902
 169          IF(IRET.EQ.-2) GOTO 903
 170          IF(IRET.EQ.-3) GOTO 904
 171          IF(IRET.EQ.-4) GOTO 905
 172
 173 C  TABLE A DESCRIPTOR FOUND
 174 C  ------------------------
 175
 176          IF(NUMB(1:1).EQ.'A') THEN
 177            N = IGETNTBI ( LUN, 'A' )
 178            CALL STNTBIA ( N, LUN, NUMB, NEMO, CARD(23:) )
 179            IF ( IDNA(N,LUN,1) .EQ. 11 ) GOTO 906
 180 c  .... Replace "A" with "3" so Table D descriptor will be found in
 181 c  .... card as well (see below)
 182            NUMB(1:1) = '3'
 183          ENDIF
 184
 185 C  TABLE B DESCRIPTOR FOUND
 186 C  ------------------------
 187
 188          IF(NUMB(1:1).EQ.'0') THEN
 189            CALL STNTBI ( IGETNTBI(LUN,'B'), LUN, NUMB, NEMO, CARD(23:) )
 190            GOTO 1
 191          ENDIF
 192
 193 C  TABLE D DESCRIPTOR FOUND
 194 C  ------------------------
 195
 196          IF(NUMB(1:1).EQ.'3') THEN
 197            CALL STNTBI ( IGETNTBI(LUN,'D'), LUN, NUMB, NEMO, CARD(23:) )
 198            GOTO 1
 199          ENDIF
 200
 201 c  .... First character of NUMB is not 'A', '0' or '3'
 202          GOTO 902
 203
 204       ENDIF
 205
 206 C  PARSE A SEQUENCE DEFINITION CARD
 207 C  --------------------------------
 208
 209       IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).NE.'|') THEN
 210          CALL SEQSDX(CARD,LUN)
 211          GOTO 1
 212       ENDIF
 213
 214 C  PARSE AN ELEMENT DEFINITION CARD
 215 C  --------------------------------
 216
 217       IF(CARD(12:12).EQ.'|' .AND. CARD(19:19).EQ.'|') THEN
 218          CALL ELEMDX(CARD,LUN)
 219          GOTO 1
 220       ENDIF
 221
 222 C  CAN'T FIGURE OUT WHAT KIND OF CARD IT IS
 223 C  ----------------------------------------
 224
 225       GOTO 907
 226
 227 C  NORMAL ENDING
 228 C  -------------
 229
 230 200   CALL MAKESTAB
 231
 232 C  EXITS
 233 C  -----
 234
 235       RETURN
 236 900   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 237       WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY IS NOT'//
 238      . ' BETWEEN 1 AND 8 CHARACTERS")') NEMO
 239       CALL BORT2(BORT_STR1,BORT_STR2)
 240 901   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 241       WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS '//
 242      . 'INVALID CHARACTERS")') NEMO
 243       CALL BORT2(BORT_STR1,BORT_STR2)
 244 902   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 245       WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
 246      . 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE'//
 247      . ' A, 0 OR 3")') NUMB
 248       CALL BORT2(BORT_STR1,BORT_STR2)
 249 903   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 250       WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
 251      . 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y '//
 252      . 'VALUES)")') NUMB
 253       CALL BORT2(BORT_STR1,BORT_STR2)
 254 904   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 255       WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
 256      . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - '//
 257      . 'MUST BE BETWEEN 00 AND 63")') NUMB
 258       CALL BORT2(BORT_STR1,BORT_STR2)
 259 905   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 260       WRITE(BORT_STR2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
 261      . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - '//
 262      . 'MUST BE BETWEEN 000 AND 255")') NUMB
 263       CALL BORT2(BORT_STR1,BORT_STR2)
 264 906   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 265       WRITE(BORT_STR2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS '//
 266      . 'RESERVED FOR DICTIONARY MESSAGES")')
 267       CALL BORT2(BORT_STR1,BORT_STR2)
 268 907   WRITE(BORT_STR1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') CARD
 269       WRITE(BORT_STR2,'(18X,"THIS CARD HAS A BAD FORMAT - IT IS NOT '//
 270      . 'RECOGNIZED BY THIS SUBROUTINE")')
 271       CALL BORT2(BORT_STR1,BORT_STR2)
 272
 273       END