rdusdx.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE READS AND PARSES A FILE CONTAINING A USER-
C>   SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT, AND THEN STORES
C>   THIS INFORMATION INTO INTERNAL ARRAYS IN MODULE TABABD (SEE REMARKS
C>   FOR CONTENTS OF INTERNAL ARRAYS).  THIS SUBROUTINE PERFORMS
C>   A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE RDBFDX,
C>   EXECPT THAT RDBFDX READS THE BUFR TABLE DIRECTLY FROM MESSAGES AT
C>   BEGINNING OF AN INPUT BUFR FILE.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C>                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C> 1996-12-17  J. WOOLLEN -- FIXED FOR SOME MVS COMPILER'S TREATMENT OF
C>                           INTERNAL READS (INCREASES PORTABILITY)
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C>                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
C> 2006-04-14  D. KEYSER  -- ABORTS IF A USER-DEFINED MESSAGE TYPE "011"
C>                           IS READ (EITHER DIRECTLY FROM A TABLE A
C>                           MNEMONIC OR FROM THE "Y" VALUE OF A TABLE A
C>                           FXY SEQUENCE DESCRIPTOR), MESSAGE TYPE
C>                           "011" IS RESERVED FOR DICTIONARY MESSAGES
C>                           (PREVIOUSLY WOULD STORE DATA WITH MESSAGE
C>                           TYPE "011" BUT SUCH MESSAGES WOULD BE
C>                           SKIPPED OVER WHEN READ)
C> 2007-01-19  J. ATOR    -- MODIFIED IN RESPONSE TO NUMBCK CHANGES
C> 2009-03-23  J. ATOR    -- INCREASE SIZE OF BORT_STR2; USE STNTBIA
C> 2013-01-08  J. WHITING -- ADD ERR= OPTION TO READ STATEMENT
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL RDUSDX (LUNDX, LUN)
C>   INPUT ARGUMENT LIST:
C>     LUNDX    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER-
C>                SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   INPUT FILES:
C>     UNIT "LUNDX" - USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER
C>                    FORMAT
C>
C> REMARKS:
C>
C>    THIS ROUTINE CALLS:        BORT2    DXINIT   ELEMDX   IGETNTBI
C>                               MAKESTAB NEMOCK   NUMBCK   SEQSDX
C>                               STNTBI   STNTBIA
C>    THIS ROUTINE IS CALLED BY: CKTABA   READDX
C>                               Normally not called by any application
C>                               programs.
C>
      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.-1) GOTO 900
         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
900   WRITE(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card
      WRITE(bort_str2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY IS NOT'//
     . ' BETWEEN 1 AND 8 CHARACTERS")') nemo
      CALL bort2(bort_str1,bort_str2)
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