SUBROUTINE RDUSDX(LUNDX,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDUSDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: 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 COMMON BLOCK /TABABD/ (SEE C REMARKS 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 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 CONTENTS OF INTERNAL ARRAYS WRITTEN INTO COMMON BLOCK /TABABD/: C C For Table A entries: C NTBA(LUN) - INTEGER: Number of Table A entries (note that C NTBA(0) contains the maximum number of such C entries as set within subroutine BFRINI) C TABA(N,LUN) - CHARACTER*128: Table A entries, where C N=1,2,3,...,NTBA(LUN) C IDNA(N,LUN,1) - INTEGER: Message type corresponding to C TABA(N,LUN) C IDNA(N,LUN,2) - INTEGER: Message subtype corresponding to C TABA(N,LUN) C C For Table B entries: C NTBB(LUN) - INTEGER: Number of Table B entries (note that C NTBB(0) contains the maximum number of such C entries as set within subroutine BFRINI) C TABB(N,LUN) - CHARACTER*128: Table B entries, where C N=1,2,3,...,NTBB(LUN) C IDNB(N,LUN) - INTEGER: Bit-wise representation of the FXY C value corresponding to TABB(N,LUN) C C For Table D entries: C NTBD(LUN) - INTEGER: Number of Table D entries (note that C NTBD(0) contains the maximum number of such C entries as set within subroutine BFRINI) C TABD(N,LUN) - CHARACTER*600: Table D entries, where C N=1,2,3,...,NTBD(LUN) C IDND(N,LUN) - INTEGER: Bit-wise representation of the FXY C value corresponding to TABD(N,LUN) C 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 C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), . TABD(MAXTBD,NFILES) CHARACTER*600 TABD CHARACTER*128 BORT_STR1 CHARACTER*156 BORT_STR2 CHARACTER*128 TABB CHARACTER*128 TABA 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