rdusdx.f

Go to the documentation of this file.

C> @file
C> @brief Read a complete DX BUFR table.
C>
C> @author Woollen @date 1994-01-06
 
C> Read a complete DX BUFR table.
C>
C> This subroutine reads and parses a file containing a user-
c> supplied DX BUFR table in character format, and then stores
c> this information into internal arrays in module @ref moda_tababd.
c> This subroutine performs
c> a function similar to BUFR archive library subroutine rdbfdx(),
c> except that rdbfdx() reads the DX BUFR table directly from messages at
c> the beginning of an input BUFR file.
C>
C> @param[in] LUNDX - integer: Fortran logical unit number for user-
C> supplied DX BUFR table in character format.
C> @param[in] LUN - integer: File ID.
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE rdusdx(LUNDX,LUN)
 
      USE moda_tababd
 
      CHARACTER*128 BORT_STR1
      CHARACTER*156 BORT_STR2
      CHARACTER*80  CARD
      CHARACTER*8   NEMO
      CHARACTER*6   NUMB,NMB2
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS
C  WITH APRIORI TABLE B AND D ENTRIES
C  --------------------------------------------------------------
 
      CALL dxinit(lun,1)
      rewind lundx
 
C  READ USER CARDS UNTIL THERE ARE NO MORE
C  ---------------------------------------
 
1     READ(lundx,'(A80)',END=200,ERR=200) card
 
C  REREAD IF NOT A DEFINITION CARD
C  -------------------------------
 
c  .... This is a comment line
      IF(card(1: 1).EQ.       '*') GOTO 1
c  .... This is a separation line
      IF(card(3:10).EQ.'--------') GOTO 1
c  .... This is a blank line
      IF(card(3:10).EQ.'        ') GOTO 1
c  .... This is a header line
      IF(card(3:10).EQ.'MNEMONIC') GOTO 1
c  .... This is a header line
      IF(card(3:10).EQ.'TABLE  D') GOTO 1
c  .... This is a header line
      IF(card(3:10).EQ.'TABLE  B') GOTO 1
 
C  PARSE A DESCRIPTOR DEFINITION CARD
C  ----------------------------------
 
      IF(card(12:12).EQ.'|' .AND. card(21:21).EQ.'|') THEN
 
c  .... NEMO is the 8-character mnemonic name
         nemo = card(3:10)
         iret=nemock(nemo)
         IF(iret.EQ.-2) GOTO 901
 
c  .... NUMB is the 6-character FXY value corresponding to NEMO
         numb = card(14:19)
         nmb2 = numb
         IF(nmb2(1:1).EQ.'A') nmb2(1:1) = '3'
         iret=numbck(nmb2)
         IF(iret.EQ.-1) GOTO 902
         IF(iret.EQ.-2) GOTO 903
         IF(iret.EQ.-3) GOTO 904
         IF(iret.EQ.-4) GOTO 905
 
C  TABLE A DESCRIPTOR FOUND
C  ------------------------
 
         IF(numb(1:1).EQ.'A') THEN
           n = igetntbi( lun, 'A' )
           CALL stntbia ( n, lun, numb, nemo, card(23:) )
           IF ( idna(n,lun,1) .EQ. 11 ) GOTO 906
c  .... Replace "A" with "3" so Table D descriptor will be found in
c  .... card as well (see below)
           numb(1:1) = '3'
         ENDIF
 
C  TABLE B DESCRIPTOR FOUND
C  ------------------------
 
         IF(numb(1:1).EQ.'0') THEN
           CALL stntbi ( igetntbi(lun,'B'), lun, numb, nemo, card(23:) )
           GOTO 1
         ENDIF
 
C  TABLE D DESCRIPTOR FOUND
C  ------------------------
 
         IF(numb(1:1).EQ.'3') THEN
           CALL stntbi ( igetntbi(lun,'D'), lun, numb, nemo, card(23:) )
           GOTO 1
         ENDIF
 
c  .... First character of NUMB is not 'A', '0' or '3'
         GOTO 902
 
      ENDIF
 
C  PARSE A SEQUENCE DEFINITION CARD
C  --------------------------------
 
      IF(card(12:12).EQ.'|' .AND. card(19:19).NE.'|') THEN
         CALL seqsdx(card,lun)
         GOTO 1
      ENDIF
 
C  PARSE AN ELEMENT DEFINITION CARD
C  --------------------------------
 
      IF(card(12:12).EQ.'|' .AND. card(19:19).EQ.'|') THEN
         CALL elemdx(card,lun)
         GOTO 1
      ENDIF
 
C  CAN'T FIGURE OUT WHAT KIND OF CARD IT IS
C  ----------------------------------------
 
      GOTO 907
 
C  NORMAL ENDING
C  -------------
 
200   CALL makestab
 
C  EXITS
C  -----
 
      RETURN
901   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS '//
     . 'INVALID CHARACTERS")') nemo
      CALL bort2(bort_str1,bort_str2)
902   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
     . 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE'//
     . ' A, 0 OR 3")') numb
      CALL bort2(bort_str1,bort_str2)
903   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
     . 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y '//
     . 'VALUES)")') numb
      CALL bort2(bort_str1,bort_str2)
904   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
     . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - '//
     . 'MUST BE BETWEEN 00 AND 63")') numb
      CALL bort2(bort_str1,bort_str2)
905   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '//
     . 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - '//
     . 'MUST BE BETWEEN 000 AND 255")') numb
      CALL bort2(bort_str1,bort_str2)
906   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS '//
     . 'RESERVED FOR DICTIONARY MESSAGES")')
      CALL bort2(bort_str1,bort_str2)
907   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"THIS CARD HAS A BAD FORMAT - IT IS NOT '//
     . 'RECOGNIZED BY THIS SUBROUTINE")')
      CALL bort2(bort_str1,bort_str2)
 
      END