SUBROUTINE RDBFDX(LUNIT,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDBFDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS BUFR TABLE (DICTIONARY) MESSAGES FROM C AN INPUT BUFR FILE AND COPIES THEM INTO INTERNAL MEMORY (ARRAYS IN C COMMON BLOCK /TABABD/). IT IS ASSUMED THERE IS AT LEAST ONE C DICTIONARY MESSAGE AT THE BEGINNING OF THE FILE. THIS SUBROUTINE C PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE C RDUSDX, EXECPT THAT RDUSDX READS FROM AN EXTERNAL FILE CONTAINING A C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT. SEE C DOCBLOCK IN RDUSDX FOR A DESCRIPTION OF THE ARRAYS THAT ARE FILLED C IN COMMON BLOCK /TABABD/. 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 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01 AND RDMSGW C C USAGE: CALL RDBFDX (LUNIT, LUN) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT CHRTRN CHRTRNA C DIGIT DXINIT GETLENS IDN30 C IFXY IUPBS01 IUPM MAKESTAB C NENUAA NENUBD PKTDD RDMSGW C THIS ROUTINE IS CALLED BY: 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) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*600 TABD CHARACTER*128 BORT_STR CHARACTER*128 TABB,TABB1,TABB2 CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*50 DXCMP CHARACTER*24 UNIT CHARACTER*8 NEMO CHARACTER*6 NUMB,CIDN CHARACTER*1 MOCT(MXMSGL) DIMENSION MBAY(MXMSGLD4),LDXBD(10),LDXBE(10) EQUIVALENCE (MBAY(1),MOCT(1)) LOGICAL DIGIT DATA LDXBD /38,70,8*0/ DATA LDXBE /42,42,8*0/ C----------------------------------------------------------------------- JA(I) = IA+1+LDA*(I-1) JB(I) = IB+1+LDB*(I-1) C----------------------------------------------------------------------- C INITIALIZE THE DICTIONARY TABLE CONTROL WORD PARTITION ARRAYS C ------------------------------------------------------------- CALL DXINIT(LUN,0) REWIND LUNIT IDX = 0 C CLEAR THE MESSAGE BUFFER C ------------------------ 1 DO I=1,MXMSGLD4 MBAY(I) = 0 ENDDO C READ A MESSAGE C -------------- CALL RDMSGW(LUNIT,MBAY,IER) IF(IER.EQ.-2) THEN GOTO 900 ELSEIF(IER.NE.-1) THEN c .... IDX counts the number of dictionary messages read IDX = IDX+1 ENDIF C IS THIS IS A BUFR DICTIONARY MESSAGE? C ------------------------------------- IF(IUPBS01(MBAY,'MTYP').NE.11) THEN C NO, so assume that we have now read in all of the available C dictionary messages and that, therefore, it is safe to go C ahead and build a jump/link table (in COMMON /TABLES/) using C the information that we just read and stored within C COMMON /TABABD/. CALL MAKESTAB C Before returning, go ahead and reposition the file at the C end of the dictionary messages, so that the next read (in C READMG, etc.) will get the first message which contains C actual data. REWIND LUNIT DO NDX=1,IDX-1 CALL RDMSGW(LUNIT,MBAY,IER) IF(IER.LT.0) GOTO 908 ENDDO GOTO 100 ENDIF C THIS IS A DICTIONARY MESSAGE, SO CONTINUE ONWARD C ------------------------------------------------ IDXS = IUPBS01(MBAY,'MSBT')+1 IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MBAY,'MTVL')+1 IF(LDXA(IDXS).EQ.0) GOTO 901 IF(LDXB(IDXS).EQ.0) GOTO 901 IF(LDXD(IDXS).EQ.0) GOTO 901 CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) I3 = LEN0+LEN1+LEN2 DXCMP = ' ' CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS)) IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902 C SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D C -------------------------------------------------- LDA = LDXA (IDXS) LDB = LDXB (IDXS) LDD = LDXD (IDXS) LDBD = LDXBD(IDXS) LDBE = LDXBE(IDXS) L30 = LD30 (IDXS) IA = I3+LEN3+5 LA = IUPM(MOCT(IA),8) IB = JA(LA+1) LB = IUPM(MOCT(IB),8) ID = JB(LB+1) LD = IUPM(MOCT(ID),8) C TABLE A C ------- DO I=1,LA N = NTBA(LUN)+1 IF(N.GT.NTBA(0)) GOTO 903 CALL CHRTRNA(TABA(N,LUN),MOCT(JA(I)),LDA) NUMB = ' '//TABA(N,LUN)(1:3) NEMO = TABA(N,LUN)(4:11) CALL NENUAA(NEMO,NUMB,LUN) NTBA(LUN) = N IF(DIGIT(NEMO(3:8))) THEN c .... Message type and subtype obtained directly from Table A mnemo. READ(NEMO,'(2X,2I3)') MTYP,MSBT IDNA(N,LUN,1) = MTYP IDNA(N,LUN,2) = MSBT ELSE c .... Message type obtained from Y value of Table A sequence descr. c Message subtype hardwired to ZERO READ(NUMB(4:6),'(I3)') IDNA(N,LUN,1) IDNA(N,LUN,2) = 0 ENDIF ENDDO C TABLE B C ------- DO I=1,LB N = NTBB(LUN)+1 IF(N.GT.NTBB(0)) GOTO 904 CALL CHRTRNA(TABB1,MOCT(JB(I) ),LDBD) CALL CHRTRNA(TABB2,MOCT(JB(I)+LDBD),LDBE) TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1)) NUMB = TABB(N,LUN)(1:6) NEMO = TABB(N,LUN)(7:14) UNIT = TABB(N,LUN)(71:94) CALL CAPIT(UNIT) TABB(N,LUN)(71:94) = UNIT CALL NENUBD(NEMO,NUMB,LUN) IDNB(N,LUN) = IFXY(NUMB) NTBB(LUN) = N ENDDO C TABLE D C ------- DO I=1,LD N = NTBD(LUN)+1 IF(N.GT.NTBD(0)) GOTO 905 CALL CHRTRNA(TABD(N,LUN),MOCT(ID+1),LDD) NUMB = TABD(N,LUN)(1:6) NEMO = TABD(N,LUN)(7:14) CALL NENUBD(NEMO,NUMB,LUN) IDND(N,LUN) = IFXY(NUMB) ND = IUPM(MOCT(ID+LDD+1),8) IF(ND.GT.MAXCD) GOTO 906 DO J=1,ND NDD = ID+LDD+2 + (J-1)*L30 CALL CHRTRNA(CIDN,MOCT(NDD),L30) IDN = IDN30(CIDN,L30) CALL PKTDD(N,LUN,IDN,IRET) IF(IRET.LT.0) GOTO 907 ENDDO ID = ID+LDD+1 + ND*L30 IF(IUPM(MOCT(ID+1),8).EQ.0) ID = ID+1 NTBD(LUN) = N ENDDO C GOTO READ THE NEXT MESSAGE C -------------------------- GOTO 1 C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// . 'MESSAGE') 901 CALL BORT('BUFRLIB: RDBFDX - UNEXPECTED DICTIONARY MESSAGE '// . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '// . 'KNOWN)') 902 CALL BORT('BUFRLIB: RDBFDX - UNEXPECTED DICTIONARY MESSAGE '// . 'CONTENTS') 903 WRITE(BORT_STR,'("BUFRLIB: RDBFDX - NUMBER OF TABLE A ENTRIES '// . 'IN BUFR TABLE EXCEEDS THE LIMIT (",I4,")")') NTBA(0) CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: RDBFDX - NUMBER OF TABLE B ENTRIES '// . 'IN BUFR TABLE EXCEEDS THE LIMIT (",I4,")")') NTBB(0) CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: RDBFDX - NUMBER OF TABLE D ENTRIES '// . 'IN BUFR TABLE EXCEEDS THE LIMIT (",I4,")")') NTBD(0) CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLIB: RDBFDX - NUMBER OF DESCRIPTORS IN '// . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '// . ' (",I4,")")') NEMO,ND,MAXCD CALL BORT(BORT_STR) 907 CALL BORT('BUFRLIB: RDBFDX - BAD RETURN FROM BUFRLIB ROUTINE '// . 'PKTDD, SEE PREVIOUS WARNING MESSAGE') 908 CALL BORT('BUFRLIB: RDBFDX - ERROR OR E-O-F POSITIONING READ TO'// . ' FIRST DATA MESSAGE AFTER DCTY MESSAGES (FILE CONTAINS ONLY '// . 'DCTY MSGS?)') END