./0000755001370400056700000000000013475260070007755 5ustar jator2emc./README_BUFRLIB0000644001370400056700000000511613475260051012004 0ustar jator2emcThis file explains how to compile the NCEP BUFRLIB software, which is described in detail at https://www.emc.ncep.noaa.gov/?branch=BUFRLIB and whose usage is governed by the terms and conditions of the disclaimer https://www.weather.gov/disclaimer The NCEP BUFRLIB software has been compiled and tested across a wide variety of UNIX platforms, so it should port with minimal difficulty to any UNIX system by following the steps below: 1) Define two environment variables on the local machine: $FC to point to the local FORTRAN compiler $CC to point to the local C compiler 2) Run the command: $CC -c `./getdefflags_C.sh` *.c This command first calls the "getdefflags_C.sh" script to generate define flags for the C compiler. These are returned as standard output and then passed directly to the C compiler in order to compile all of the C source files within this same directory. Note that the define flag "-DUNDERSCORE" should also be added to this command if the local FORTRAN compiler appends an underscore character to subprogram names in its object namespace. In such cases, specifying "-DUNDERSCORE" to the C compiler appends a matching underscore character to any C references to the same subprogram names, which will allow the linker to correctly resolve such references across the C <-> FORTRAN interface at link time. 3) Run the command: $FC -c `./getdefflags_F.sh` modv*.F moda*.F `ls -1 *.F *.f | grep -v "mod[av]_"` This command first calls the "getdefflags_F.sh" script to generate define flags for the FORTRAN compiler. These are returned as standard output and then passed directly to the FORTRAN compiler in order to compile all of the FORTRAN files within this same directory. Note that the command ensures that all of the FORTRAN module variable files are compiled first, followed by all of the FORTRAN module array files, and finally by all remaining FORTRAN source files. Note also that it may be necessary to include the additional compiler option "-fno-second-underscore" in the above command, particularly whenever $FC points to the GNU g77 or gfortran compilers. 4) Once compilation has been successfully completed, it is then recommended to assemble all of the compiled object files into a single archive library via: ar crv $BUFRLIB *.o where $BUFRLIB points to the desired pathname for the BUFRLIB archive library on the local machine. This archive library can then be easily linked whenever the user's application program is subsequently compiled on the same local system. ./adn30.f0000644001370400056700000000545113440555365011044 0ustar jator2emc FUNCTION ADN30(IDN,L30) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ADN30 C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS BIT-WISE C (INTEGER) REPRESENTATION TO ITS FIVE OR SIX CHARACTER ASCII C REPRESENTATION. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C USAGE: ADN30 (IDN, L30) C INPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) C VALUE C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR C 6) C C OUTPUT ARGUMENT LIST: C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY C VALUE) C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: CADN30 DXINIT IGETRFEL ISTDESC C NEMTBD NUMTAB RDMTBB RDMTBD C RDMTBF READS3 SEQSDX SNTBDE C SNTBFE UFBQCD UPDS3 WRDXTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*(*) ADN30 CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(LEN(ADN30).LT.L30 ) GOTO 900 IF(IDN.LT.0 .OR. IDN.GT.65535) GOTO 901 IF(L30.EQ.5) THEN WRITE(ADN30,'(I5)') IDN ELSEIF(L30.EQ.6) THEN IDF = ISHFT(IDN,-14) IDX = ISHFT(ISHFT(IDN,NBITW-14),-(NBITW-6)) IDY = ISHFT(ISHFT(IDN,NBITW- 8),-(NBITW-8)) WRITE(ADN30,'(I1,I2,I3)') IDF,IDX,IDY ELSE GOTO 902 ENDIF DO I=1,L30 IF(ADN30(I:I).EQ.' ') ADN30(I:I) = '0' ENDDO C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: ADN30 - FUNCTION RETURN STRING TOO SHORT') 901 CALL BORT('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF '// . 'DESCRIPTOR OUT OF 16-BIT RANGE') 902 WRITE(BORT_STR,'("BUFRLIB: ADN30 - CHARACTER LENGTH (",I4,") '// . 'MUST BE EITHER 5 OR 6")') L30 CALL BORT(BORT_STR) END ./arallocc.c0000644001370400056700000001017213440555365011710 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ARALLOCC C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: IF DYNAMIC MEMORY ALLOCATION IS BEING USED, THIS ROUTINE C IS CALLED DURING THE FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C OPENBF TO DYNAMICALLY ALLOCATE MEMORY FOR ALL REQUIRED C LANGUAGE C ARRAYS. THESE ARRAYS ARE SIZED USING VALUES INPUT DURING ONE OR C MORE PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE ISETPRM, OR C ELSE USING ONE OR MORE DEFAULT VALUES SPECIFIED IN MODULE FILES IF C ISETPRM IS NEVER CALLED FOR THOSE PARTICULAR SIZE VALUES. C C MEMORY ALLOCATED WITHIN THIS ROUTINE CAN BE FREED VIA A USER CALL C TO BUFR ARCHIVE LIBRARY ROUTINE ARDLLOCF (IN CASES WHERE THE C APPLICATION PROGRAM MAY WISH TO MOVE ON TO OTHER TASKS NOT C REQUIRING ANY FURTHER CALLS TO BUFR ARCHIVE LIBRARY ROUTINES), OR C ELSE IT WILL BE FREED AUTOMATICALLY WHEN THE APPLICATION PROGRAM C TERMINATES. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL ARALLOCC C C REMARKS: C THIS ROUTINE CALLS: BORT IGETPRM C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #ifdef DYNAMIC_ALLOCATION #include "bufrlib.h" #define IN_ARALLOCC #include "cread.h" #include "mstabs.h" void arallocc( void ) { char brtstr[50] = "BUFRLIB: ARALLOCC FAILED ALLOCATING "; f77int nfiles; f77int mxmtbb; f77int mxmtbd; f77int maxcd; /* ** cread arrays */ nfiles = igetprm( "NFILES", 6 ); if ( ( pb = malloc( (nfiles+1) * sizeof(FILE *) ) ) == NULL ) { strcat( brtstr, "PB" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( lstpos = malloc( (nfiles+1) * sizeof(fpos_t) ) ) == NULL ) { strcat( brtstr, "LSTPOS" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } /* ** mstabs arrays */ mxmtbb = igetprm( "MXMTBB", 6 ); mxmtbd = igetprm( "MXMTBD", 6 ); maxcd = igetprm( "MAXCD", 5 ); if ( ( MSTABS_BASE(ibfxyn) = malloc( mxmtbb * sizeof(f77int) ) ) == NULL ) { strcat( brtstr, "IBFXYN" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbscl) = malloc( mxmtbb * 4 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBSCL" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbsref) = malloc( mxmtbb * 12 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBSREF" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbbw) = malloc( mxmtbb * 4 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBBW" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbunit) = malloc( mxmtbb * 14 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBUNIT" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbmnem) = malloc( mxmtbb * 8 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBMNEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cbelem) = malloc( mxmtbb * 120 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CBELEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(idfxyn) = malloc( mxmtbd * sizeof(f77int) ) ) == NULL ) { strcat( brtstr, "IDFXYN" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cdseq) = malloc( mxmtbd * 120 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CDSEQ" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(cdmnem) = malloc( mxmtbd * 8 * sizeof(char) ) ) == NULL ) { strcat( brtstr, "CDMNEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(ndelem) = malloc( mxmtbd * sizeof(f77int) ) ) == NULL ) { strcat( brtstr, "NDELEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( MSTABS_BASE(idefxy) = malloc( mxmtbd * maxcd * sizeof(f77int) ) ) == NULL ) { strcat( brtstr, "IDEFXY" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } } #endif ./arallocf.F0000644001370400056700000003734513465105235011663 0ustar jator2emc SUBROUTINE ARALLOCF C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ARALLOCF C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: IF DYNAMIC MEMORY ALLOCATION IS BEING USED, THIS ROUTINE C IS CALLED DURING THE FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C OPENBF TO DYNAMICALLY ALLOCATE MEMORY FOR ALL REQUIRED FORTRAN C LANGUAGE ARRAYS. THESE ARRAYS ARE SIZED USING VALUES INPUT DURING c ONE OR MORE PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE C ISETPRM, OR ELSE USING ONE OR MORE DEFAULT VALUES SPECIFIED IN C MODULE FILES IF ISETPRM IS NEVER CALLED FOR THOSE PARTICULAR SIZE C VALUES. C C MEMORY ALLOCATED WITHIN THIS ROUTINE CAN BE FREED VIA A USER CALL C TO BUFR ARCHIVE LIBRARY ROUTINE ARDLLOCF (IN CASES WHERE THE C APPLICATION PROGRAM MAY WISH TO MOVE ON TO OTHER TASKS NOT C REQUIRING ANY FURTHER CALLS TO BUFR ARCHIVE LIBRARY ROUTINES), OR C ELSE IT WILL BE FREED AUTOMATICALLY WHEN THE APPLICATION PROGRAM C TERMINATES. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C 2016-05-24 J. ATOR -- ADDED ALLOCATIONS FOR MODA_BITMAPS C AND MODA_NRV203 C 2017-05-22 J. ATOR -- ADDED ALLOCATIONS FOR MODA_RLCCMN C 2019-05-09 J. ATOR -- MODIFIED ALLOCATIONS FOR MODA_BUFRMG C C USAGE: CALL ARALLOCF C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ #ifdef DYNAMIC_ALLOCATION USE MODA_USRINT USE MODA_USRBIT USE MODA_IVAL USE MODA_MSGCWD USE MODA_STBFR USE MODA_UFBCPL USE MODA_SC3BFR USE MODA_UNPTYP USE MODA_LUSHR USE MODA_NULBFR USE MODA_STCODE USE MODA_IDRDM USE MODA_XTAB USE MODA_MSGLIM USE MODA_BITBUF USE MODA_MGWA USE MODA_MGWB USE MODA_BUFRMG USE MODA_BUFRSR USE MODA_MSGMEM USE MODA_TABABD USE MODA_TABLES USE MODA_USRTMP USE MODA_IVTTMP USE MODA_COMPRX USE MODA_COMPRS USE MODA_MSTABS USE MODA_RDMTB USE MODA_NMIKRP USE MODA_S01CM USE MODA_BITMAPS USE MODA_NRV203 USE MODA_RLCCMN INCLUDE 'bufrlib.prm' CHARACTER*80 ERRSTR CHARACTER*36 BRTSTR COMMON /QUIET/ IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( IPRT .GE. 1 ) THEN CALL ERRWRT . ('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ERRSTR = 'BUFRLIB: ARRAYS WILL BE DYNAMICALLY ALLOCATED' // . ' USING THE FOLLOWING VALUES:' CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I7)' ) ' MAXSS = ', MAXSS CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' NFILES = ', NFILES CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I7)' ) ' MXMSGL = ', MXMSGL CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MXDXTS = ', MXDXTS CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I7)' ) ' MAXMSG = ', MAXMSG CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I9)' ) ' MAXMEM = ', MAXMEM CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MAXTBA = ', MAXTBA CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MAXTBB = ', MAXTBB CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MAXTBD = ', MAXTBD CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I7)' ) ' MAXJL = ', MAXJL CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I6)' ) ' MXCDV = ', MXCDV CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXLCC = ', MXLCC CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I6)' ) ' MXCSB = ', MXCSB CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MXMTBB = ', MXMTBB CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I5)' ) ' MXMTBD = ', MXMTBD CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MAXCD = ', MAXCD CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXNRV = ', MXNRV CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXS01V = ', MXS01V CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXTAMC = ', MXTAMC CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXTCO = ', MXTCO CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXBTM = ', MXBTM CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXBTMSE = ', MXBTMSE CALL ERRWRT(ERRSTR) WRITE ( ERRSTR, '(A,I4)' ) ' MXRST = ', MXRST CALL ERRWRT(ERRSTR) CALL ERRWRT . ('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') END IF BRTSTR = 'BUFRLIB: ARALLOCF FAILED ALLOCATING ' C MODA_USRINT arrays. ALLOCATE( NVAL(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NVAL' ) ALLOCATE( INV(MAXSS,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INV' ) ALLOCATE( NRFELM(MAXSS,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NRFELM' ) ALLOCATE( VAL(MAXSS,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VAL' ) C MODA_USRBIT arrays. ALLOCATE( NBIT(MAXSS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NBIT' ) ALLOCATE( MBIT(MAXSS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MBIT' ) C MODA_IVAL arrays. ALLOCATE( IVAL(MAXSS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IVAL' ) C MODA_MSGCWD arrays. ALLOCATE( NMSG(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NMSG' ) ALLOCATE( NSUB(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NSUB' ) ALLOCATE( MSUB(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSUB' ) ALLOCATE( INODE(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INODE' ) ALLOCATE( IDATE(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDATE' ) C MODA_STBFR arrays. ALLOCATE( IOLUN(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IOLUN' ) ALLOCATE( IOMSG(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IOMSG' ) C MODA_UFBCPL arrays. ALLOCATE( LUNCPY(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUNCPY' ) C MODA_SC3BFR arrays. ALLOCATE( ISC3(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISC3' ) ALLOCATE( TAMNEM(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAMNEM' ) C MODA_UNPTYP arrays. ALLOCATE( MSGUNP(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGUNP' ) C MODA_LUSHR arrays. ALLOCATE( LUS(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUS' ) C MODA_NULBFR arrays. ALLOCATE( NULL(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NULL' ) C MODA_STCODE arrays. ALLOCATE( ISCODES(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISCODES' ) C MODA_IDRDM arrays. ALLOCATE( IDRDM(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDRDM' ) C MODA_XTAB arrays. ALLOCATE( XTAB(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'XTAB' ) C MODA_MSGLIM arrays. ALLOCATE( MSGLIM(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGLIM' ) C Calculate MXMSGLD4 from MXMSGL. IF ( MOD(MXMSGL,4) .eq. 0 ) THEN MXMSGLD4 = MXMSGL/4 ELSE MXMSGLD4 = MXMSGL/4 + 1 END IF C MODA_BITBUF arrays. ALLOCATE( IBAY(MXMSGLD4), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBAY' ) ALLOCATE( MBYT(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MBYT' ) ALLOCATE( MBAY(MXMSGLD4,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MBAY' ) C MODA_MGWA arrays. ALLOCATE( MGWA(MXMSGLD4), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWA' ) C MODA_MGWB arrays. ALLOCATE( MGWB(MXMSGLD4), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWB' ) C MODA_BUFRMG arrays. ALLOCATE( MSGLEN(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGLEN' ) ALLOCATE( MSGTXT(MXMSGLD4,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGTXT' ) C MODA_BUFRSR arrays. ALLOCATE( JSR(NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JSR' ) ALLOCATE( JBAY(MXMSGLD4), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JBAY' ) C Calculate MXDXM and MXDXW from MXDXTS and MXMSGLD4. MXDXM = MXDXTS*3 MXDXW = MXDXM*MXMSGLD4 C MODA_MSGMEM arrays. ALLOCATE( MSGP(0:MAXMSG), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGP' ) ALLOCATE( MSGS(MAXMEM), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGS' ) ALLOCATE( MDX(MXDXW), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MDX' ) ALLOCATE( IPDXM(MXDXM), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IPDXM' ) ALLOCATE( IFDXTS(MXDXTS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IFDXTS' ) ALLOCATE( ICDXTS(MXDXTS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ICDXTS' ) ALLOCATE( IPMSGS(MXDXTS), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IPMSGS' ) C MODA_TABABD arrays. ALLOCATE( NTBA(0:NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NTBA' ) ALLOCATE( NTBB(0:NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NTBB' ) ALLOCATE( NTBD(0:NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NTBD' ) ALLOCATE( MTAB(MAXTBA,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MTAB' ) ALLOCATE( IDNA(MAXTBA,NFILES,2), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDNA' ) ALLOCATE( IDNB(MAXTBB,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDNB' ) ALLOCATE( IDND(MAXTBD,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDND' ) ALLOCATE( TABA(MAXTBA,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TABA' ) ALLOCATE( TABB(MAXTBB,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TABB' ) ALLOCATE( TABD(MAXTBD,NFILES), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TABD' ) C MODA_TABLES arrays. ALLOCATE( TAG(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAG' ) ALLOCATE( TYP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TYP' ) ALLOCATE( KNT(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KNT' ) ALLOCATE( JUMP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JUMP' ) ALLOCATE( LINK(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LINK' ) ALLOCATE( JMPB(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JMPB' ) ALLOCATE( IBT(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBT' ) ALLOCATE( IRF(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IRF' ) ALLOCATE( ISC(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISC' ) ALLOCATE( ITP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ITP' ) ALLOCATE( VALI(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VALI' ) ALLOCATE( KNTI(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KNTI' ) ALLOCATE( ISEQ(MAXJL,2), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISEQ' ) ALLOCATE( JSEQ(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JSEQ' ) C MODA_USRTMP arrays. ALLOCATE( IUTMP(MAXJL,MAXRCR), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IUTMP' ) ALLOCATE( VUTMP(MAXJL,MAXRCR), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VUTMP' ) C MODA_IVTTMP arrays. ALLOCATE( TTMP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TTMP' ) ALLOCATE( ITMP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ITMP' ) ALLOCATE( VTMP(MAXJL), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VTMP' ) C MODA_COMPRX arrays. ALLOCATE( KMIN(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KMIN' ) ALLOCATE( KMAX(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KMAX' ) ALLOCATE( KMIS(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KMIS' ) ALLOCATE( KBIT(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KBIT' ) ALLOCATE( ITYP(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ITYP' ) ALLOCATE( IWID(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IWID' ) ALLOCATE( CHARACTER*(MXLCC) :: CSTR(MXCDV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CSTR' ) C MODA_COMPRS arrays. ALLOCATE( MATX(MXCDV,MXCSB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MATX' ) ALLOCATE( CHARACTER*(MXLCC) :: CATX(MXCDV,MXCSB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CATX' ) C MODA_MSTABS arrays. ALLOCATE( IBFXYN(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBFXYN' ) ALLOCATE( CBSCL(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSCL' ) ALLOCATE( CBSREF(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSREF' ) ALLOCATE( CBBW(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBBW' ) ALLOCATE( CBUNIT(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBUNIT' ) ALLOCATE( CBMNEM(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBMNEM' ) ALLOCATE( CBELEM(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBELEM' ) ALLOCATE( IDFXYN(MXMTBD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDFXYN' ) ALLOCATE( CDSEQ(MXMTBD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CDSEQ' ) ALLOCATE( CDMNEM(MXMTBD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CDMNEM' ) ALLOCATE( NDELEM(MXMTBD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NDELEM' ) ALLOCATE( IDEFXY(MXMTBD*MAXCD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDEFXY' ) C MODA_RDMTB arrays. ALLOCATE( IEFXYN(MXMTBD,MAXCD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IEFXYN' ) ALLOCATE( CMDSCB(MXMTBB), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CMDSCB' ) ALLOCATE( CMDSCD(MXMTBD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CMDSCD' ) ALLOCATE( CEELEM(MXMTBD,MAXCD), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CEELEM' ) C MODA_NMIKRP arrays. ALLOCATE( NEM(MAXCD,10), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NEM' ) ALLOCATE( IRP(MAXCD,10), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IRP' ) ALLOCATE( KRP(MAXCD,10), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KRP' ) C MODA_S01CM arrays. ALLOCATE( IVMNEM(MXS01V), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IVMNEM' ) ALLOCATE( CMNEM(MXS01V), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CMNEM' ) C MODA_BITMAPS arrays. ALLOCATE( INODTAMC(MXTAMC), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INODTAMC' ) ALLOCATE( NTCO(MXTAMC), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NTCO' ) ALLOCATE( CTCO(MXTAMC,MXTCO), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CTCO' ) ALLOCATE( INODTCO(MXTAMC,MXTCO), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INODTCO' ) ALLOCATE( NBTMSE(MXBTM), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NBTMSE' ) ALLOCATE( ISTBTM(MXBTM), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISTBTM' ) ALLOCATE( ISZBTM(MXBTM), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISZBTM' ) ALLOCATE( IBTMSE(MXBTM,MXBTMSE), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBTMSE' ) C MODA_NRV203 arrays. ALLOCATE( TAGNRV(MXNRV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAGNRV' ) ALLOCATE( INODNRV(MXNRV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INODNRV' ) ALLOCATE( NRV(MXNRV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NRV' ) ALLOCATE( ISNRV(MXNRV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISNRV' ) ALLOCATE( IENRV(MXNRV), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IENRV' ) C MODA_RLCCMN arrays. ALLOCATE( IRNCH(MXRST), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IRNCH' ) ALLOCATE( IRBIT(MXRST), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IRBIT' ) ALLOCATE( CRTAG(MXRST), STAT=iost ) IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CRTAG' ) #endif RETURN END ./ardllocc.c0000644001370400056700000000235213440555365011714 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ARDLLOCC C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: THIS ROUTINE FREES ANY MEMORY THAT WAS DYNAMICALLY C ALLOCATED BY A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY ROUTINE C ARALLOCC. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL ARDLLOCC C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: ARDLLOCF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #ifdef DYNAMIC_ALLOCATION #include "bufrlib.h" #include "cread.h" #include "mstabs.h" void ardllocc( void ) { /* ** cread arrays */ free( pb ); free( lstpos ); /* ** mstabs arrays */ free( MSTABS_BASE(ibfxyn) ); free( MSTABS_BASE(cbscl) ); free( MSTABS_BASE(cbsref) ); free( MSTABS_BASE(cbbw) ); free( MSTABS_BASE(cbunit) ); free( MSTABS_BASE(cbmnem) ); free( MSTABS_BASE(cbelem) ); free( MSTABS_BASE(idfxyn) ); free( MSTABS_BASE(cdseq) ); free( MSTABS_BASE(cdmnem) ); free( MSTABS_BASE(ndelem) ); free( MSTABS_BASE(idefxy) ); } #endif ./ardllocf.F0000644001370400056700000001274013465105332011654 0ustar jator2emc SUBROUTINE ARDLLOCF C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ARDLLOCF C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: THIS SUBROUTINE FREES ANY MEMORY THAT WAS DYNAMICALLY C ALLOCATED BY PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY ROUTINES C ARALLOCF OR ARALLOCC. C C NOTE THAT THIS SUBROUTINE IS CALLED WITHIN BUFR ARCHIVE LIBRARY C SUBROUTINE EXITBUFR AS PART OF THE PROCESS TO RESET THE LIBRARY AND C PREPARE IT FOR POTENTIAL RE-ALLOCATION OF NEW ARRAY SPACE VIA ONE OR C MORE SUBSEQUENT CALLS TO SUBROUTINES ISETPRM AND OPENBF. THIS C SUBROUTINE SHOULD ONLY BE CALLED DIRECTLY BY AN APPLICATION PROGRAM C IF THE PROGRAM IS COMPLETELY FINISHED WITH ALL CALLS TO ALL OTHER C BUFR ARCHIVE LIBRARY ROUTINES, BECAUSE THE MEMORY FREED HEREIN WILL C RENDER THE LIBRARY AS EFFECTIVELY UNUSABLE FOR THE REMAINDER OF THE C LIFE OF THE APPLICATION PROGRAM. HOWEVER, THIS MAY BE A USEFUL C OPTION FOR APPLICATION PROGRAMS WHICH WANT TO MOVE ON TO OTHER C UNRELATED TASKS WITHOUT CONTINUING TO TIE UP A SIGNIFICANT AMOUNT C OF DYNAMICALLY-ALLOCATED HEAP MEMORY RELATED TO THIS LIBRARY. C OTHERWISE, ALL SUCH MEMORY WILL BE FREED AUTOMATICALLY ONCE THE C APPLICATION PROGRAM TERMINATES. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C 2019-05-09 J. ATOR -- MODIFIED DEALLOCATIONS FOR MODA_BUFRMG C C USAGE: CALL ARDLLOCF C C REMARKS: C THIS ROUTINE CALLS: ARDLLOCC C THIS ROUTINE IS CALLED BY: EXITBUFR C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ #ifdef DYNAMIC_ALLOCATION USE MODA_USRINT USE MODA_USRBIT USE MODA_IVAL USE MODA_MSGCWD USE MODA_STBFR USE MODA_UFBCPL USE MODA_SC3BFR USE MODA_UNPTYP USE MODA_LUSHR USE MODA_NULBFR USE MODA_STCODE USE MODA_IDRDM USE MODA_XTAB USE MODA_MSGLIM USE MODA_BITBUF USE MODA_MGWA USE MODA_MGWB USE MODA_BUFRMG USE MODA_BUFRSR USE MODA_MSGMEM USE MODA_TABABD USE MODA_TABLES USE MODA_USRTMP USE MODA_IVTTMP USE MODA_COMPRX USE MODA_COMPRS USE MODA_MSTABS USE MODA_RDMTB USE MODA_NMIKRP USE MODA_S01CM USE MODA_BITMAPS USE MODA_NRV203 USE MODA_RLCCMN C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MODA_USRINT arrays. DEALLOCATE( NVAL ) DEALLOCATE( INV ) DEALLOCATE( NRFELM ) DEALLOCATE( VAL ) C MODA_USRBIT arrays. DEALLOCATE( NBIT ) DEALLOCATE( MBIT ) C MODA_IVAL arrays. DEALLOCATE( IVAL ) C MODA_MSGCWD arrays. DEALLOCATE( NMSG ) DEALLOCATE( NSUB ) DEALLOCATE( MSUB ) DEALLOCATE( INODE ) DEALLOCATE( IDATE ) C MODA_STBFR arrays. DEALLOCATE( IOLUN ) DEALLOCATE( IOMSG ) C MODA_UFBCPL arrays. DEALLOCATE( LUNCPY ) C MODA_SC3BFR arrays. DEALLOCATE( ISC3 ) DEALLOCATE( TAMNEM ) C MODA_UNPTYP arrays. DEALLOCATE( MSGUNP ) C MODA_LUSHR arrays. DEALLOCATE( LUS ) C MODA_NULBFR arrays. DEALLOCATE( NULL ) C MODA_STCODE arrays. DEALLOCATE( ISCODES ) C MODA_IDRDM arrays. DEALLOCATE( IDRDM ) C MODA_XTAB arrays. DEALLOCATE( XTAB ) C MODA_MSGLIM arrays. DEALLOCATE( MSGLIM ) C MODA_BITBUF arrays. DEALLOCATE( IBAY ) DEALLOCATE( MBYT ) DEALLOCATE( MBAY ) C MODA_MGWA arrays. DEALLOCATE( MGWA ) C MODA_MGWB arrays. DEALLOCATE( MGWB ) C MODA_BUFRMG arrays. DEALLOCATE( MSGLEN ) DEALLOCATE( MSGTXT ) C MODA_BUFRSR arrays. DEALLOCATE( JSR ) DEALLOCATE( JBAY ) C MODA_MSGMEM arrays. DEALLOCATE( MSGP ) DEALLOCATE( MSGS ) DEALLOCATE( MDX ) DEALLOCATE( IPDXM ) DEALLOCATE( IFDXTS ) DEALLOCATE( ICDXTS ) DEALLOCATE( IPMSGS ) C MODA_TABABD arrays. DEALLOCATE( NTBA ) DEALLOCATE( NTBB ) DEALLOCATE( NTBD ) DEALLOCATE( MTAB ) DEALLOCATE( IDNA ) DEALLOCATE( IDNB ) DEALLOCATE( IDND ) DEALLOCATE( TABA ) DEALLOCATE( TABB ) DEALLOCATE( TABD ) C MODA_TABLES arrays. DEALLOCATE( TAG ) DEALLOCATE( TYP ) DEALLOCATE( KNT ) DEALLOCATE( JUMP ) DEALLOCATE( LINK ) DEALLOCATE( JMPB ) DEALLOCATE( IBT ) DEALLOCATE( IRF ) DEALLOCATE( ISC ) DEALLOCATE( ITP ) DEALLOCATE( VALI ) DEALLOCATE( KNTI ) DEALLOCATE( ISEQ ) DEALLOCATE( JSEQ ) C MODA_USRTMP arrays. DEALLOCATE( IUTMP ) DEALLOCATE( VUTMP ) C MODA_IVTTMP arrays. DEALLOCATE( TTMP ) DEALLOCATE( ITMP ) DEALLOCATE( VTMP ) C MODA_COMPRX arrays. DEALLOCATE( KMIN ) DEALLOCATE( KMAX ) DEALLOCATE( KMIS ) DEALLOCATE( KBIT ) DEALLOCATE( ITYP ) DEALLOCATE( IWID ) DEALLOCATE( CSTR ) C MODA_COMPRS arrays. DEALLOCATE( MATX ) DEALLOCATE( CATX ) C MODA_MSTABS arrays. DEALLOCATE( IBFXYN ) DEALLOCATE( CBSCL ) DEALLOCATE( CBSREF ) DEALLOCATE( CBBW ) DEALLOCATE( CBUNIT ) DEALLOCATE( CBMNEM ) DEALLOCATE( CBELEM ) DEALLOCATE( IDFXYN ) DEALLOCATE( CDSEQ ) DEALLOCATE( CDMNEM ) DEALLOCATE( NDELEM ) DEALLOCATE( IDEFXY ) C MODA_RDMTB arrays. DEALLOCATE( IEFXYN ) DEALLOCATE( CMDSCB ) DEALLOCATE( CMDSCD ) DEALLOCATE( CEELEM ) C MODA_NMIKRP arrays. DEALLOCATE( NEM ) DEALLOCATE( IRP ) DEALLOCATE( KRP ) C MODA_S01CM arrays. DEALLOCATE( IVMNEM ) DEALLOCATE( CMNEM ) C MODA_BITMAPS arrays. DEALLOCATE( INODTAMC ) DEALLOCATE( NTCO ) DEALLOCATE( CTCO ) DEALLOCATE( INODTCO ) DEALLOCATE( NBTMSE ) DEALLOCATE( ISTBTM ) DEALLOCATE( ISZBTM ) DEALLOCATE( IBTMSE ) C MODA_NRV203 arrays. DEALLOCATE( TAGNRV ) DEALLOCATE( INODNRV ) DEALLOCATE( NRV ) DEALLOCATE( ISNRV ) DEALLOCATE( IENRV ) C MODA_RLCCMN arrays. DEALLOCATE( IRNCH ) DEALLOCATE( IRBIT ) DEALLOCATE( CRTAG ) C C language arrays. CALL ARDLLOCC #endif RETURN END ./atrcpt.f0000644001370400056700000000603213440555365011430 0ustar jator2emc SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ATRCPT C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE, APPENDS THE C TANK RECEIPT TIME TO SECTION 1, AND WRITES THE RESULT TO A NEW BUFR C MESSAGE FOR OUTPUT. THE TANK RECEIPT TIME MUST HAVE BEEN SPECIFIED C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE STRCPT. THE C OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE INPUT MESSAGE, SO C THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE OUTPUT ARRAY. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL ATRCPT (MSGIN, LMSGOT, MSGOT) C INPUT ARGUMENT LIST: C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE MSGOT ARRAY C C OUTPUT ARGUMENT LIST: C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE C WITH TANK RECEIPT TIME APPENDED TO SECTION 1 C C REMARKS: C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. C C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB C PKB C THIS ROUTINE IS CALLED BY: MSGWRT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MSGIN(*), MSGOT(*) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT CHARACTER*1 CTRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Get some section lengths and addresses from the input message. CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5) IAD1 = LEN0 IAD2 = IAD1 + LEN1 LENM = IUPBS01(MSGIN,'LENM') C Check for overflow of the output array. Note that the new C message will be 6 bytes longer than the input message. LENMOT = LENM + 6 IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 LEN1OT = LEN1 + 6 C Write Section 0 of the new message into the output array. CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) IBIT = 32 CALL PKB ( LENMOT, 24, MSGOT, IBIT ) CALL MVB ( MSGIN, 8, MSGOT, 8, 1 ) C Store the length of the new Section 1. IBIT = IAD1*8 CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) C Copy the remainder of Section 1 from the input array to the C output array. CALL MVB ( MSGIN, IAD1+4, MSGOT, (IBIT/8)+1, LEN1-3 ) C Append the tank receipt time data to the new Section 1. IBIT = IAD2*8 CALL PKB ( ITRYR, 16, MSGOT, IBIT ) CALL PKB ( ITRMO, 8, MSGOT, IBIT ) CALL PKB ( ITRDY, 8, MSGOT, IBIT ) CALL PKB ( ITRHR, 8, MSGOT, IBIT ) CALL PKB ( ITRMI, 8, MSGOT, IBIT ) C Copy Sections 2, 3, 4 and 5 from the input array to the C output array. CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LENM-IAD2 ) RETURN 900 CALL BORT('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE '// . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./bfrini.f0000644001370400056700000002145413465107143011403 0ustar jator2emc SUBROUTINE BFRINI C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BFRINI C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE IS CALLED ONLY ONE TIME (DURING THE FIRST C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF) IN ORDER TO C INITIALIZE SOME GLOBAL VARIABLES AND ARRAYS WITHIN SEVERAL COMMON C BLOCKS. 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 1998-07-08 J. WOOLLEN -- MODIFIED TO MAKE Y2K COMPLIANT 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 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); INITIALIZES C VARIABLE JSR AS ZERO IN NEW COMMON BLOCK C /BUFRSR/ (WAS IN VERIFICATION VERSION); C UNIFIED/PORTABLE FOR WRF; ADDED HISTORY C DOCUMENTATION C 2004-08-18 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGSTD/; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- ADDED INITIALIZATION OF COMMON /MSGCMP/ C AND CALLS TO PKVS1 AND PKVS01 C 2009-03-23 J. ATOR -- ADDED INITIALIZATION OF COMMON /DSCACH/, C COMMON /MSTINF/ AND COMMON /TNKRCP/ C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE, C ADDED INITIALIZATION OF COMMON BLOCKS C /ENDORD/ AND /BUFRBMISS/ C 2014-09-15 J. ATOR -- CHANGE DEFAULT LOCATION OF MTDIR C 2014-11-18 J. ATOR -- ADDED INITIALIZATION OF MODULES MSGLIM C AND USRINT; REMOVE S01CM INITIALIZATION C 2016-11-29 J. ATOR -- EXPLICITLY INITIALIZE BMISS AS 10E10_8 C 2017-10-13 J. ATOR -- ADDED INITIALIZATION OF COMMON /TABLEF/ C 2019-05-03 J. ATOR -- CHANGE DEFAULT LOCATION OF MTDIR C 2019-05-09 J. ATOR -- ADDED DIMENSIONS FOR MSGLEN C C USAGE: CALL BFRINI C C REMARKS: C THIS ROUTINE CALLS: IFXY IPKM C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_STBFR USE MODA_IDRDM USE MODA_MSGLIM USE MODA_BITBUF USE MODA_BUFRMG USE MODA_BUFRSR USE MODA_TABABD USE MODA_USRINT USE MODA_TABLES USE MODA_H4WLC INCLUDE 'bufrlib.prm' COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), . IDCACH(MXCNEM,MAXNC) COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT COMMON /DATELN/ LENDAT COMMON /ACMODE/ IAC COMMON /MSGSTD/ CSMF COMMON /MSGCMP/ CCMF COMMON /TABLEF/ CDMF COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT COMMON /MSTINF/ LUN1,LUN2,LMTD,MTDIR COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) CHARACTER*100 MTDIR CHARACTER*56 DXSTR CHARACTER*8 CNEM CHARACTER*6 ADSN(5,2),DNDX(25,10) CHARACTER*3 TYPX(5,2),TYPS CHARACTER*1 REPX(5,2),REPS CHARACTER*1 CSMF CHARACTER*1 CCMF CHARACTER*1 CDMF CHARACTER*1 CTRT DIMENSION NDNDX(10),NLDXA(10),NLDXB(10),NLDXD(10),NLD30(10) DIMENSION LENX(5) DATA ADSN / '101000','360001','360002','360003','360004' , . '101255','031002','031001','031001','031000' / DATA TYPX / 'REP', 'DRP', 'DRP', 'DRS' , 'DRB' , . 'SEQ', 'RPC', 'RPC', 'RPS' , 'SEQ' / DATA REPX / '"', '(', '{', '[' , '<' , . '"', ')', '}', ']' , '>' / DATA LENX / 0 , 16 , 8 , 8 , 1 / DATA (DNDX(I,1),I=1,25)/ .'102000','031001','000001','000002', .'110000','031001','000010','000011','000012','000013','000015', . '000016','000017','000018','000019','000020', .'107000','031001','000010','000011','000012','000013','101000', . '031001','000030'/ DATA (DNDX(I,2),I=1,15)/ .'103000','031001','000001','000002','000003', .'101000','031001','300004', .'105000','031001','300003','205064','101000','031001','000030'/ DATA NDNDX / 25 , 15 , 8*0 / DATA NLDXA / 35 , 67 , 8*0 / DATA NLDXB / 80 , 112 , 8*0 / DATA NLDXD / 38 , 70 , 8*0 / DATA NLD30 / 5 , 6 , 8*0 / C----------------------------------------------------------------------- C----------------------------------------------------------------------- C INITIALIZE /ENDORD/ TO CONTROL OUTPUT BLOCKING -1=LE 0=NONE +1=BE C ----------------------------------------------------------------- IBLOCK = 0 C INITIALIZE /BUFRBMISS/ C ---------------------- BMISS = 10E10_8 C INITIALIZE MODULE BITBUF C ------------------------ MAXBYT = MIN(10000,MXMSGL) C INITIALIZE MODULE H4WLC C ----------------------- NH4WLC = 0 C INITIALIZE /MAXCMP/ C ------------------- MAXCMB = MAXBYT MAXROW = 0 MAXCOL = 0 NCMSGS = 0 NCSUBS = 0 NCBYTS = 0 C INITIALIZE /PADESC/ C ------------------- IBCT = IFXY('063000') IPD1 = IFXY('102000') IPD2 = IFXY('031001') IPD3 = IFXY('206001') IPD4 = IFXY('063255') C INITIALIZE MODULE STBFR C ----------------------- DO I=1,NFILES IOLUN(I) = 0 IOMSG(I) = 0 ENDDO C INITIALIZE MODULE IDRDM C ----------------------- DO I=1,NFILES IDRDM(I) = 0 ENDDO C INITIALIZE MODULE MSGLIM C ------------------------ DO I=1,NFILES MSGLIM(I) = 3 ENDDO C INITIALIZE MODULE USRINT C ------------------------ DO I=1,NFILES NVAL(I) = 0 ENDDO C INITIALIZE /REPTAB/ C ------------------- DO I=1,5 LENS(I) = LENX(I) DO J=1,2 IDNR(I,J) = IFXY(ADSN(I,J)) TYPS(I,J) = TYPX(I,J) REPS(I,J) = REPX(I,J) ENDDO ENDDO C INITIALIZE TABABD (INTERNAL ARRAYS HOLDING DICTIONARY TABLE) C ------------------------------------------------------------ C NTBA(0) is the maximum number of entries w/i internal BUFR table A NTBA(0) = MAXTBA C NTBB(0) is the maximum number of entries w/i internal BUFR Table B NTBB(0) = MAXTBB C NTBD(0) is the maximum number of entries w/i internal BUFR Table D NTBD(0) = MAXTBD C INITIALIZE /DXTAB/ C ------------------ MAXDX = MAXBYT c .... IDXV is the version number of the local tables IDXV = 1 DO J=1,10 LDXA(J) = NLDXA(J) LDXB(J) = NLDXB(J) LDXD(J) = NLDXD(J) LD30(J) = NLD30(J) DXSTR(J) = ' ' NXSTR(J) = NDNDX(J)*2 DO I=1,NDNDX(J) I1 = I*2-1 CALL IPKM(DXSTR(J)(I1:I1),2,IFXY(DNDX(I,J))) ENDDO ENDDO C INITIALIZE MODULE TABLES C ------------------------ MAXTAB = MAXJL C INITIALIZE MODULE BUFRMG C ------------------------ DO I=1,NFILES MSGLEN(I) = 0 ENDDO C INITIALIZE /MRGCOM/ C ------------------- NRPL = 0 NMRG = 0 NAMB = 0 NTOT = 0 C INITIALIZE /DATELN/ C ------------------- IF(LENDAT.NE.10) LENDAT = 8 C INITIALIZE /ACMODE/ C ------------------_ c .... DK: What does this control?? IAC = 0 C INITIALIZE MODULE BUFRSR C ------------------------ DO I=1,NFILES JSR(I) = 0 ENDDO C INITIALIZE /DSCACH/ C ------------------- NCNEM = 0 C INITIALIZE /MSGSTD/ C ------------------- CSMF = 'N' C INITIALIZE /MSGCMP/ C ------------------- CCMF = 'N' C INITIALIZE /TABLEF/ C ------------------- CDMF = 'N' C INITIALIZE /TNKRCP/ C ------------------- CTRT = 'N' C INITIALIZE /MSTINF/ C ------------------- MTDIR = '/gpfs/dell1/nco/ops/nwprod/decoders/decod_shared/fix' LMTD = 33 LUN1 = 98 LUN2 = 99 RETURN END ./blocks.f0000644001370400056700000000644613440555365011421 0ustar jator2emc SUBROUTINE BLOCKS(MBAY,MWRD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BLOCKS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 C C ABSTRACT: BLOCKS WILL ADD IEEE FORTRAN TYPE RECORD CONTROL C WORDS TO A PURE BUFR RECORD PASSED FROM MSGWRT, IN C PREPARATION FOR OUTPUTING THE RECORD TO DISK. THE C DEFAULT OUTPUT TYPE IS PURE (NO CONTROL WORDS), IN C WHICH CASE THIS ROUTINE DOES NOTHING. AN APPLICATION C CAN SPECIFY THAT EITHER BIG OR LITTLE ENDIAN RECORD C CONTROL WORDS ARE TO BE APPENDED TO PURE BUFR RECORDS C VIA A PREVIOUS CALL TO SUBROUTINE SETBLOCK. C C THE FOLLOWING DIAGRAM ILLUSTRATES IEEE CONTROL WORDS FOUND C IN AN UNFORMATTED FORTRAN RECORD CONRTAINING FOUR 4-BYTE WORDS C C ctw1-wrd1-wrd2-wrd3-wrd4-ctw2 C | | | | | | C 0016-aaaa-bbbb-cccc-dddd-0016 C C CTW1 AND CTW2 CONTAIN A BYTE COUNT FOR THE DATA RECORD THAT C THEY ENCLOSE. THEY CAN BE STORED IN EITHER BIG OR LITTLE C ENDIAN BYTE ORDERING (NOTE: CTWS ARE ALWAYS 4-BYTE WORDS) C C PROGRAM HISTORY LOG: C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR C C USAGE: CALL BLOCKS(MBAY,MWRD) C INPUT ARGUMENTS: c MBAY - INTEGER ARRAY CONTAINING PURE BUFR MESSAGE c MWRD - INTEGER WORD COUNT FOR MBAY C C OUTPUT ARGUMENTS: c MBAY - INTEGER ARRAY CONTAINING INPUT BUFR MESSAGE, POSSIBLY c WITH CONTROL WORDS ADDED DEPENDING ON WHETHER SUBROUTINE c SETBLOCK WAS PREVIOUSLY CALLED c MWRD - INTEGER WORD COUNT FOR MBAY C C REMARKS: C THIS ROUTINE CALLS: None C C THIS ROUTINE IS CALLED BY: MSGWRT C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) INTEGER*4 MBAY(MWRD),IINT,JINT CHARACTER*1 CINT(4),DINT(4) EQUIVALENCE(CINT,IINT) EQUIVALENCE(DINT,JINT) DATA IFIRST/0/ SAVE IFIRST c---------------------------------------------------------------------- c---------------------------------------------------------------------- if(iblock.eq.0) return if(ifirst.eq.0) then c Initialize some arrays for later use. Note that Fortran c record control words are always 4 bytes. iint=0; cint(1)=char(1) do i=1,4 if(cint(1).eq.char(01)) then iordbe(i)=4-i+1 iordle(i)=i else iordle(i)=4-i+1 iordbe(i)=i endif enddo ifirst=1 endif c make room in mbay for control words - one at each end of the record c ------------------------------------------------------------------- if(nbytw.eq.8) mwrd=mwrd*2 do m=mwrd,1,-1 mbay(m+1) = mbay(m) enddo c store the endianized control word in bytes in dint/jint c ------------------------------------------------------- iint=mwrd*4 do i=1,4 if(iblock.eq.+1) dint(i)=cint(iordbe(i)) if(iblock.eq.-1) dint(i)=cint(iordle(i)) enddo c increment mrwd and install the control words in their proper places c ------------------------------------------------------------------- mwrd = mwrd+2 mbay(1) = jint mbay(mwrd) = jint if(nbytw.eq.8) mwrd=mwrd/2 return end ./bort2.f0000644001370400056700000000340513440555365011164 0ustar jator2emc SUBROUTINE BORT2(STR1,STR2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BORT2 C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE C ERRWRT) TWO GIVEN ERROR STRINGS AND THEN CALLS BUFR ARCHIVE LIBRARY C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT, EXCEPT BORT PRINTS ONLY ONE ERROR STRING. C C PROGRAM HISTORY LOG: C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL BORT2 (STR1, STR2) C INPUT ARGUMENT LIST: C STR1 - CHARACTER*(*): FIRST ERROR MESSAGE TO BE WRITTEN VIA C SUBROUTINE ERRWRT C STR2 - CHARACTER*(*): SECOND ERROR MESSAGE TO BE WRITTEN VIA C SUBROUTINE ERRWRT C C REMARKS: C THIS ROUTINE CALLS: BORT_EXIT ERRWRT C THIS ROUTINE IS CALLED BY: ELEMDX GETNTBE IREADMT MTFNAM C MTINFO PARSTR PARUSR PARUTG C RDUSDX SEQSDX SNTBBE SNTBDE C SNTBFE STRING UFBINT UFBOVR C UFBREP UFBSTP VALX C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR1, STR2 CALL ERRWRT(' ') CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') CALL ERRWRT(STR1) CALL ERRWRT(STR2) CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') CALL ERRWRT(' ') CALL BORT_EXIT END ./bort_exit.c0000644001370400056700000000164713440555365012136 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BORT_EXIT C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE WILL TERMINATE THE APPLICATION PROGRAM AND C RETURN AN IMPLEMENTATION-DEFINED NON-ZERO STATUS CODE TO THE C EXECUTING SHELL SCRIPT. C C PROGRAM HISTORY LOG: C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF C 2004-08-18 J. ATOR -- USE bufrlib.h INCLUDE FILE C 2007-01-19 J. ATOR -- FIX DECLARATION FOR ANSI-C C C USAGE: CALL BORT_EXIT C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: BORT BORT2 C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" void bort_exit( void ) { exit( EXIT_FAILURE ); } ./bort.f0000644001370400056700000001017713440555365011106 0ustar jator2emc SUBROUTINE BORT(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BORT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 C C ABSTRACT: THIS SUBROUTINE WRITES (VIA BUFR ARCHIVE LIBRARY SUBROUTINE C ERRWRT) A GIVEN ERROR STRING AND THEN CALLS BUFR ARCHIVE LIBRARY C SUBROUTINE BORT_EXIT TO ABORT THE APPLICATION PROGRAM CALLING THE C BUFR ARCHIVE LIBRARY SOFTWARE. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT2, EXCEPT BORT2 WRITES TWO ERROR STRINGS. C C PROGRAM HISTORY LOG: C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (REPLACED CRAY LIBRARY C ROUTINE ABORT) C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION; REPLACED CALL TO C INTRINSIC C ROUTINE "EXIT" WITH CALL TO C BUFRLIB C ROUTINE "BORT_EXIT" WHICH ALWAYS C RETURNS A NON-ZERO STATUS BACK TO EXECUTING C SHELL SCRIPT 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 C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL BORT (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): ERROR MESSAGE TO BE WRITTEN VIA C SUBROUTINE ERRWRT C C REMARKS: C THIS ROUTINE CALLS: BORT_EXIT ERRWRT C THIS ROUTINE IS CALLED BY: ADN30 ATRCPT BVERS CHEKSTAB C CKTABA CLOSMG CMPMSG CMSGINI C CNVED4 COBFL COPYBF COPYMG C COPYSB CPDXMM CPYMEM CPYUPD C CRBMG CWBMG DATEBF DATELEN C DRFINI DRSTPL DUMPBF DXDUMP C DXMINI GETWIN GETTBH IDN30 C IFBGET IGETNTBI IGETRFEL IGETSC C IGETTDI INCTAB INVMRG IPKM C ISIZE IUPVS01 IUPM JSTNUM C LCMGDF LSTJPB MAKESTAB MINIMG C MSGINI MSGWRT NEMTBA NEMTBAX C NEMTBB NEMTBD NENUBD NEVN C NEWWIN NMSUB NUMMTB NVNWIN C NXTWIN OPENBF OPENMB OPENMG C PAD PADMSG PARUTG PKB C PKBS1 PKVS01 POSAPX RCSTPL C RDBFDX RDCMPS RDMEMM RDMEMS C RDMGSB RDMSGW RDMTBB RDMTBD C READDX READERME READLC READMG C READNS READSB READS3 REWNBF C RTRCPT SNTBBE SNTBDE STATUS C STBFDX STDMSG STNDRD STNTBIA C STRBTM STRCPT STSEQ TABENT C TABSUB TRYBUMP UFBCNT UFBCPY C UFBCUP UFBDMP UFBEVN UFBGET C UFBIN3 UFBINT UFBINX UFBMEM C UFBMEX UFBMMS UFBMNS UFBOVR C UFBPOS UFBQCD UFBQCP UFBREP C UFBRMS UFBSEQ UFBSTP UFBTAB C UFBTAM UFDUMP UPDS3 UPFTBV C UPTDD USRTPL WRCMPS WRDESC C WRDLEN WRDXTB WRITDX WRITLC C WRITSA WRITSB WTSTAT CODFLG C RDMTBF INITTBF STRTBFE GETCFMNG C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CALL ERRWRT(' ') CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') CALL ERRWRT(STR) CALL ERRWRT('***********BUFR ARCHIVE LIBRARY ABORT**************') CALL ERRWRT(' ') CALL BORT_EXIT END ./bufrlib.h0000644001370400056700000001237313440555365011567 0ustar jator2emc#include #include #include #include /* ** The following value must be identically defined in Fortran source ** file modv_NFILES.F */ #ifdef DYNAMIC_ALLOCATION # define NFILES 32 #else # define NFILES 32 #endif /* ** The following value must be identically defined in Fortran source ** file modv_MAXCD.F */ #ifdef DYNAMIC_ALLOCATION # define MAXCD 250 #else # define MAXCD 250 #endif /* ** On certain operating systems, the FORTRAN compiler appends an underscore ** to subprogram names in its object namespace. Therefore, on such systems, ** a matching underscore must be appended to any C language references to ** the same subprogram names so that the linker can correctly resolve such ** references across the C <-> FORTRAN interface at link time. This needs ** to be done for any subprogram that is either: ** 1) a C function, or ** 2) a FORTRAN subprogram called from C */ #ifdef UNDERSCORE #define arallocc arallocc_ #define ardllocc ardllocc_ #define bort bort_ #define bort_exit bort_exit_ #define cadn30 cadn30_ #define ccbfl ccbfl_ #define cmpia cmpia_ #define cmpstia1 cmpstia1_ #define cmpstia2 cmpstia2_ #define cobfl cobfl_ #define cpmstabs cpmstabs_ #define crbmg crbmg_ #define cwbmg cwbmg_ #define dlloctbf dlloctbf_ #define elemdx elemdx_ #define gets1loc gets1loc_ #define ichkstr ichkstr_ #define icvidx icvidx_ #define ifxy ifxy_ #define igetntbi igetntbi_ #define igetprm igetprm_ #define igettdi igettdi_ #define imrkopr imrkopr_ #define inittbf inittbf_ #define ipkm ipkm_ #define istdesc istdesc_ #define iupbs01 iupbs01_ #define iupm iupm_ #define nemtab nemtab_ #define nemtbb nemtbb_ #define nummtb nummtb_ #define numtbd numtbd_ #define pktdd pktdd_ #define rbytes rbytes_ #define restd restd_ #define sorttbf sorttbf_ #define srchtbf srchtbf_ #define stntbi stntbi_ #define strnum strnum_ #define strtbfe strtbfe_ #define stseq stseq_ #define uptdd uptdd_ #define wrdesc wrdesc_ #define wrdlen wrdlen_ #define openrb openrb_ #define openwb openwb_ #define openab openab_ #define backbufr backbufr_ #define cewind cewind_ #define closfb closfb_ #define crdbufr crdbufr_ #define cwrbufr cwrbufr_ #endif /* ** In order to ensure that the C <-> FORTRAN interface works properly (and ** portably!), the default size of an "INTEGER" declared in FORTRAN must be ** identical to that of an "int" declared in C. If this is not the case (e.g. ** some FORTRAN compilers, most notably AIX via the -qintsize= option, allow the ** sizes of INTEGERs to be definitively prescribed outside of the source code ** itself!), then the following conditional directive (or a variant of it) can ** be used to ensure that the size of an "int" in C remains identical to that ** of an "INTEGER" in FORTRAN. */ #ifdef F77_INTSIZE_8 typedef long f77int; #else typedef int f77int; #endif /* ** Declare prototypes for ANSI C compatibility. This should be done for any ** subprogram that is either: ** 1) a C function, or ** 2) a FORTRAN subprogram called from C */ void arallocc( void ); void ardllocc( void ); void bort( char *, f77int ); void bort_exit( void ); void cadn30( f77int *, char *, f77int ); void ccbfl( void ); int cmpia( const void *, const void * ); int cmpstia1( const void *, const void * ); int cmpstia2( const void *, const void * ); void cobfl( char *, char * ); void cpmstabs( f77int *, f77int *, char (*)[4], char (*)[12], char (*)[4], char (*)[14], char (*)[8], char (*)[120], f77int *, f77int *, char (*)[120], char (*)[8], f77int *, f77int *, f77int * ); void crbmg( char *, f77int *, f77int *, f77int * ); void cwbmg( char *, f77int *, f77int * ); void dlloctbf( void ); void elemdx( char *, f77int *, f77int ); void gets1loc( char *, f77int *, f77int *, f77int *, f77int *, f77int ); f77int ichkstr ( char *, char *, f77int *, f77int, f77int ); f77int icvidx ( f77int *, f77int *, f77int * ); f77int ifxy( char *, f77int ); f77int igetntbi( f77int *, char *, f77int ); f77int igetprm( char *, f77int ); f77int igettdi( f77int * ); f77int imrkopr( char *, f77int ); void inittbf( void ); void ipkm( char *, f77int *, f77int *, f77int ); f77int istdesc( f77int * ); f77int iupbs01 ( f77int *, char *, f77int ); f77int iupm ( char *, f77int *, f77int ); void nemtab( f77int *, char *, f77int *, char *, f77int *, f77int, f77int ); void nemtbb( f77int *, f77int *, char *, f77int *, f77int *, f77int *, f77int ); void nummtb( f77int *, char *, f77int * ); void numtbd( f77int *, f77int *, char *, char *, f77int *, f77int, f77int ); void pktdd( f77int *, f77int *, f77int *, f77int * ); f77int rbytes( char *, f77int *, f77int, f77int ); void restd( f77int *, f77int *, f77int *, f77int * ); void sorttbf( void ); void srchtbf( f77int *, f77int *, f77int *, f77int *, f77int *, char *, f77int *, f77int *, f77int * ); void stntbi( f77int *, f77int *, char *, char *, char *, f77int, f77int, f77int ); void strnum( char *, f77int *, f77int ); void strtbfe( f77int *, f77int *, char *, f77int *, f77int *, f77int * ); void stseq( f77int *, f77int *, f77int *, char *, char *, f77int *, f77int * ); void uptdd( f77int *, f77int *, f77int *, f77int * ); void wrdesc( f77int, f77int *, f77int * ); void wrdlen( void ); ./bufrlib.prm0000644001370400056700000000214013440555365012125 0ustar jator2emcC----------------------------------------------------------------------- C Maximum number of Section 3 FXY descriptors that can be C written into a BUFR message by the BUFRLIB software. PARAMETER ( MAXNC = 600 ) C----------------------------------------------------------------------- C Maximum number of entries in the internal string cache. PARAMETER ( MXS = 1000 ) C----------------------------------------------------------------------- C Maximum number of entries in the internal descriptor list cache. PARAMETER ( MXCNEM = 450 ) C----------------------------------------------------------------------- C Maximum number of 2-04 associated fields that can be in effect C at the same time for any given Table B descriptor. PARAMETER ( MXNAF = 3 ) C----------------------------------------------------------------------- C BUFRLIB "missing" value. The default value for BMISS is set C within subroutine BFRINI, but it can be modified by the user via C a subsequent call to subroutine SETBMISS. COMMON /BUFRBMISS/ BMISS REAL*8 BMISS C----------------------------------------------------------------------- ./bvers.f0000644001370400056700000000342313440555365011255 0ustar jator2emc SUBROUTINE BVERS (CVERSTR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: BVERS C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER STRING CONTAINING THE C VERSION NUMBER OF THE BUFR ARCHIVE LIBRARY SOFTWARE. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2011-09-26 J. ATOR -- UPDATED TO VERSION 10.0.1 C 2012-02-24 J. ATOR -- UPDATED TO VERSION 10.1.0 C 2012-10-12 J. ATOR -- UPDATED TO VERSION 10.2.0 C 2012-11-29 J. ATOR -- UPDATED TO VERSION 10.2.1 C 2012-12-04 J. ATOR -- UPDATED TO VERSION 10.2.2 C 2013-01-08 J. ATOR -- UPDATED TO VERSION 10.2.3 C 2013-01-09 J. ATOR -- UPDATED TO VERSION 10.2.4 C 2013-01-25 J. ATOR -- UPDATED TO VERSION 10.2.5 C 2014-11-12 J. ATOR -- UPDATED TO VERSION 11.0.0 C 2015-09-24 J. ATOR -- UPDATED TO VERSION 11.0.1 C 2016-02-12 J. ATOR -- UPDATED TO VERSION 11.0.2 C 2016-03-18 J. ATOR -- UPDATED TO VERSION 11.1.0 C 2016-05-10 J. ATOR -- UPDATED TO VERSION 11.2.0 C 2017-04-03 J. ATOR -- UPDATED TO VERSION 11.3.0 C C USAGE: CALL BVERS (CVERSTR) C C OUTPUT ARGUMENT LIST: C CVERSTR - CHARACTER*(*): VERSION STRING C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: WRDLEN C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) CVERSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF (LEN(CVERSTR).LT.8) GOTO 900 CVERSTR = '11.3.0' RETURN 900 CALL BORT('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE '// . 'FOR AT LEAST 8 CHARACTERS') END ./cadn30.f0000644001370400056700000000247713440555365011214 0ustar jator2emc SUBROUTINE CADN30( IDN, ADN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CADN30 C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE C FOR A DESCRIPTOR, THIS ROUTINE CALLS FUNCTION ADN30 AND STORES C ITS RETURN VALUE (I.E. THE ASCII-EQUIVALENT FXY VALUE) AS THE C ROUTINE OUTPUT VALUE. THIS MECHANISM (I.E. A FORTRAN SUBROUTINE C WRAPPER RETURNING ADN AS A CALL PARAMETER, RATHER THAN DIRECTLY C CALLING THE FORTRAN FUNCTION ADN30 FROM WITHIN A C ROUTINE) C ALLOWS SAFE AND PORTABLE (ALBEIT INDIRECT) ACCESS TO THE ADN30 C FUNCTION LOGIC FROM WITHIN A C ROUTINE. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CADN30( IDN, ADN ) C INPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE C C OUTPUT ARGUMENT LIST: C ADN - CHARACTER*(*): ASCII-CHARACTER FORM OF IDN C C REMARKS: C THIS ROUTINE CALLS: ADN30 C THIS ROUTINE IS CALLED BY: NUMMTB RESTD STSEQ C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) ADN CHARACTER*6 ADN30 ADN = ADN30( IDN, 6 ) RETURN END ./capit.f0000644001370400056700000000426513440555365011241 0ustar jator2emc SUBROUTINE CAPIT(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CAPIT C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE CAPITALIZES A STRING OF CHARACTERS. THIS C ENABLES THE USE OF MIXED CASE IN THE UNIT SECTION OF THE ASCII C BUFR TABLES. AN EXAMPLE: A PROGRAM WHICH GENERATES AN ASCII BUFR C TABLE FROM THE "MASTER TABLE B" MIGHT END UP COPYING SOME UNITS C FIELDS IN MIXED OR LOWER CASE. IF THE UNITS ARE 'CODE TABLE' OR C 'FLAG TABLE' OR CERTAIN OTHER UNIT DESIGNATIONS, THE TABLE WILL BE C PARSED INCORRECTLY, AND THE DATA READ OR INCORRECTLY AS A RESULT. C THIS MAKES SURE ALL UNIT DESIGNATIONS ARE SEEN BY THE PARSER IN C UPPER CASE TO AVOID THESE TYPES OF PROBLEMS. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR 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) C 2012-03-02 J. ATOR -- CHANGED NAME OF UPS ARRAY TO UPCS TO AVOID C NAMESPACE CONTENTION WITH NEW FUNCTION UPS C C USAGE: CALL CAPIT (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING POSSIBLY CONTAINING MIXED UPPER- C AND LOWER-CASE CHARACTERS C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): SAME STRING AS INPUT BUT NOW CONTAINING C ALL UPPER-CASE CHARACTERS C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CMPMSG CODFLG ELEMDX STBFDX C STDMSG STRCPT C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*26 UPCS,LWCS DATA UPCS/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA LWCS/'abcdefghijklmnopqrstuvwxyz'/ DO 20 I=1,LEN(STR) DO 10 J=1,26 IF(STR(I:I).EQ.LWCS(J:J)) THEN STR(I:I) = UPCS(J:J) GOTO 20 ENDIF 10 CONTINUE 20 CONTINUE RETURN END ./ccbfl.c0000644001370400056700000000153013440555365011177 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CCBFL C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS ROUTINE CLOSES (AND FLUSHES ANY REMAINING OUTPUT TO!) C ANY SYSTEM FILES THAT ARE STILL OPEN FROM ANY PREVIOUS CALLS TO BUFR C ARCHIVE LIBRARY SUBROUTINE COBFL. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CCBFL C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cobfl.h" void ccbfl( void ) { unsigned short i; for ( i = 0; i < 2; i++ ) { if ( pbf[i] != NULL ) fclose( pbf[i] ); } } ./cfe.h0000644001370400056700000000142513440555365010673 0ustar jator2emc#define MAX_MEANING_LEN 150 struct code_flag_entry { f77int iffxyn; /* Bitwise representation of FXY number to which this entry belongs. */ f77int ifval; /* Code figure or bit number. */ char ifmeaning[MAX_MEANING_LEN+1]; /* Meaning corresponding to ifval. */ f77int iffxynd; /* Bitwise representation of FXY number upon which this entry is dependent, if any. Set to (-1) if no dependency. */ f77int ifvald; /* Code figure or bit number upon which this entry is dependent, if any. Set to (-1) if no dependency. */ }; #ifdef IN_INITTBF struct code_flag_entry *cfe; /* will automatically initialize to NULL */ f77int mxmtbf; f77int nmtf; #else extern struct code_flag_entry *cfe; extern f77int mxmtbf; extern f77int nmtf; #endif ./chekstab.f0000644001370400056700000000655713440555365011733 0ustar jator2emc SUBROUTINE CHEKSTAB(LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CHEKSTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS THAT AN INTERNAL BUFR TABLE C REPRESENTATION IS SELF-CONSISTENT AND FULLY DEFINED. IF ANY ERRORS C ARE FOUND, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CHEKSTAB (LUN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTAB NEMTBB NEMTBD C THIS ROUTINE IS CALLED BY: MAKESTAB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD USE MODA_NMIKRP INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*24 UNIT CHARACTER*8 NEMO CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C THERE MUST BE ENTRIES IN TABLES A, B, AND D C ------------------------------------------- IF(NTBA(LUN).EQ.0) GOTO 900 IF(NTBB(LUN).EQ.0) GOTO 901 IF(NTBD(LUN).EQ.0) GOTO 902 C MAKE SURE EACH TABLE A ENTRY DEFINED AS A SEQUENCE C -------------------------------------------------- DO I=1,NTBA(LUN) NEMO = TABA(I,LUN)(4:11) CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) IF(TAB.NE.'D') GOTO 903 ENDDO C CHECK TABLE B CONTENTS C ---------------------- DO ITAB=1,NTBB(LUN) CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) ENDDO C CHECK TABLE D CONTNETS C ---------------------- DO ITAB=1,NTBD(LUN) CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) ENDDO C EXITS C ----- RETURN 900 CALL BORT . ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES') 901 CALL BORT . ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES') 902 CALL BORT . ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES') 903 WRITE(BORT_STR,'("BUFRLIB: CHEKSTAB - TABLE A ENTRY: ",A," NOT '// . 'DEFINED AS A SEQUENCE")') NEMO CALL BORT(BORT_STR) END ./chrtrna.f0000644001370400056700000000404413440555365011575 0ustar jator2emc SUBROUTINE CHRTRNA(STR,CHR,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CHRTRNA C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. THE DIFFERENCE C BETWEEN THIS SUBROUTINE AND BUFR ARCHIVE LIBRARY SUBROUTINE CHRTRN C IS THAT, IN THIS SUBROUTINE, THE INPUT CHARACTER ARRAY IS ASSUMED C TO BE IN ASCII; THUS, FOR CASES WHERE THE NATIVE MACHINE IS EBCDIC, C AN ASCII TO EBCDIC TRANSLATION IS DONE ON THE FINAL STRING BEFORE C IT IS OUTPUT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C C USAGE: CALL CHRTRNA (STR, CHR, N) C INPUT ARGUMENT LIST: C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY IN ASCII C N - INTEGER: NUMBER OF CHARACTERS TO COPY C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): CHARACTER STRING IN ASCII OR EBCDIC, C DEPENDING ON NATIVE MACHINE C C REMARKS: C THIS ROUTINE CALLS: IPKM IUPM C THIS ROUTINE IS CALLED BY: ICHKSTR C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) CHARACTER*(*) STR CHARACTER*1 CHR(N) C---------------------------------------------------------------------- C---------------------------------------------------------------------- C Loop on N characters of CHR DO I=1,N STR(I:I) = CHR(I) C If this is an EBCDIC machine, then translate the character C from ASCII -> EBCDIC. IF(IASCII.EQ.0) CALL IPKM(STR(I:I),1,IATOE(IUPM(STR(I:I),8))) ENDDO RETURN END ./chrtrn.f0000644001370400056700000000263713440555365011442 0ustar jator2emc SUBROUTINE CHRTRN(STR,CHR,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CHRTRN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF CHARACTERS C FROM A CHARACTER ARRAY INTO A CHARACTER STRING. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C C USAGE: CALL CHRTRN (STR, CHR, N) C INPUT ARGUMENT LIST: C CHR - CHARACTER*1: N-WORD CHARACTER ARRAY C N - INTEGER: NUMBER OF CHARACTERS TO COPY C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): CHARACTER STRING C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: None C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*1 CHR(N) C---------------------------------------------------------------------- C---------------------------------------------------------------------- DO I=1,N STR(I:I) = CHR(I) ENDDO RETURN END ./cktaba.f0000644001370400056700000002457313440555365011372 0ustar jator2emc SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CKTABA C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 C C ABSTRACT: THIS SUBROUTINE PARSES THE TABLE A MNEMONIC AND THE DATE C OUT OF SECTION 1 OF A BUFR MESSAGE PREVIOUSLY READ FROM UNIT LUNIT C USING BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR EQUIVALENT (AND NOW C STORED IN THE INTERNAL MESSAGE BUFFER, ARRAY MBAY IN MODULE C BITBUF). THE TABLE A MNEMONIC IS ASSOCIATED WITH THE BUFR C MESSAGE TYPE/SUBTYPE IN SECTION 1. IT ALSO FILLS IN THE MESSAGE C CONTROL WORD PARTITION ARRAYS IN MODULE MSGCWD. C C PROGRAM HISTORY LOG: C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR - CONSOLIDATED MESSAGE C DECODING LOGIC THAT HAD BEEN REPLICATED IN C READMG, READFT, READERME, RDMEMM AND READIBM C (CKTABA IS NOW CALLED BY THESE CODES); C LOGIC ENHANCED HERE TO ALLOW COMPRESSED AND C STANDARD BUFR MESSAGES TO BE READ C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THE SECTION 1 C MESSAGE SUBTYPE DOES NOT AGREE WITH THE C SECTION 1 MESSAGE SUBTYPE IN THE DICTIONARY C IF THE MESSAGE TYPE MNEMONIC IS NOT OF THE C FORM "NCtttsss", WHERE ttt IS THE BUFR TYPE C AND sss IS THE BUFR SUBTYPE (E.G., IN C "PREPBUFR" FILES); MODIFIED DATE C CALCULATIONS TO NO LONGER USE FLOATING C POINT ARITHMETIC SINCE THIS CAN LEAD TO C ROUND OFF ERROR AND AN IMPROPER RESULTING C DATE ON SOME MACHINES (E.G., NCEP IBM C FROST/SNOW), INCREASES PORTABILITY; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN; SUBSET DEFINED AS " " IF C IRET RETURNED AS 11 (BEFORE WAS UNDEFINED) 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 IUPBS01, IGETDATE AND GETLENS C 2006-04-14 J. ATOR -- ALLOW "FRtttsss" AND "FNtttsss" AS POSSIBLE C TABLE A MNEMONICS, WHERE ttt IS THE BUFR C TYPE AND sss IS THE BUFR SUBTYPE C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; C USE IUPBS3 AND ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CKTABA (LUN, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING CHECKED: C " " = IRET equal to 11 (see IRET below) C and not using Section 3 decoding C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING CHECKED, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = unrecognized Table A (message type) value C 11 = this is a BUFR table (dictionary) message C C REMARKS: C THIS ROUTINE CALLS: BORT DIGIT ERRWRT GETLENS C I4DY IGETDATE IUPB IUPBS01 C IUPBS3 NEMTBAX NUMTAB OPENBT C RDUSDX C THIS ROUTINE IS CALLED BY: RDMEMM READERME READMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_SC3BFR USE MODA_UNPTYP USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 SUBSET CHARACTER*2 CPFX(3) CHARACTER*1 TAB LOGICAL TRYBT, DIGIT DATA CPFX / 'NC', 'FR', 'FN' / DATA NCPFX / 3 / C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 TRYBT = .TRUE. JDATE = IGETDATE(MBAY(1,LUN),IYR,IMO,IDY,IHR) c .... Message type MTYP = IUPBS01(MBAY(1,LUN),'MTYP') c .... Message subtype MSBT = IUPBS01(MBAY(1,LUN),'MSBT') IF(MTYP.EQ.11) THEN c .... This is a BUFR table (dictionary) message. IRET = 11 c .... There's no need to proceed any further unless Section 3 is being c .... used for decoding. IF(ISC3(LUN).EQ.0) THEN SUBSET = " " GOTO 100 ENDIF ENDIF C PARSE SECTION 3 C --------------- CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) IAD3 = LEN0+LEN1+LEN2 c .... First descriptor (integer) KSUB = IUPB(MBAY(1,LUN),IAD3+8 ,16) c .... Second descriptor (integer) ISUB = IUPB(MBAY(1,LUN),IAD3+10,16) C LOCATE SECTION 4 C ---------------- IAD4 = IAD3+LEN3 C NOW, TRY TO GET "SUBSET" (MNEMONIC ASSOCIATED WITH TABLE A) FROM MSG C -------------------------------------------------------------------- C FIRST CHECK WHETHER SECTION 3 IS BEING USED FOR DECODING C -------------------------------------------------------- IF(ISC3(LUN).NE.0) THEN SUBSET = TAMNEM(LUN) c .... is SUBSET from Table A? CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) IF(INOD.GT.0) THEN c .... yes it is MBYT(LUN) = 8*(IAD4+4) MSGUNP(LUN) = 1 GOTO 10 ENDIF ENDIF C IF ISUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=0 C ---------------------------------------------------- c .... get SUBSET from ISUB 5 CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) c .... is SUBSET from Table A? CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) IF(INOD.GT.0) THEN c .... yes it is MBYT(LUN) = (IAD4+4) MSGUNP(LUN) = 0 GOTO 10 ENDIF C IF KSUB FROM SECTION 3 DEFINES TABLE A THEN MSGUNP=1 (standard) C --------------------------------------------------------------- c .... get SUBSET from KSUB CALL NUMTAB(LUN,KSUB,SUBSET,TAB,ITAB) c .... is SUBSET from Table A? CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) IF(INOD.GT.0) THEN c .... yes it is MBYT(LUN) = 8*(IAD4+4) MSGUNP(LUN) = 1 GOTO 10 ENDIF C OKAY, STILL NO "SUBSET", LETS MAKE IT "NCtttsss" (where ttt=MTYP C and sss=MSBT) AND SEE IF IT DEFINES TABLE A. IF NOT, THEN ALSO C TRY "FRtttsss" AND "FNtttsss". C ---------------------------------------------------------------- II=1 DO WHILE(II.LE.NCPFX) WRITE(SUBSET,'(A2,2I3.3)') CPFX(II),MTYP,MSBT c .... is SUBSET from Table A? CALL NEMTBAX(LUN,SUBSET,MTY1,MSB1,INOD) IF(INOD.GT.0) THEN c .... yes it is IF(KSUB.EQ.IBCT) THEN MBYT(LUN) = (IAD4+4) MSGUNP(LUN) = 0 ELSE MBYT(LUN) = 8*(IAD4+4) MSGUNP(LUN) = 1 ENDIF GOTO 10 ENDIF II=II+1 ENDDO C NOW WE HAVE A GENERATED "SUBSET", BUT IT STILL DOES NOT DEFINE C TABLE A - MAKE ONE LAST DESPERATE ATTEMPT - SEE IF AN EXTERNAL C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT IS DEFINED C IN OPENBT (ONLY POSSIBLE IF APPLICATION PROGRAM HAS AN IN-LINE C OPENBT OVERRIDING THE ONE IN THE BUFR ARCHIVE LIBRARY) C ------------------------------------------------------------------ IF(TRYBT) THEN TRYBT = .FALSE. IF(IPRT.GE.1) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ERRSTR = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL'// . ' BUFR TABLE VIA CALL TO IN-LINE OPENBT' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL OPENBT(LUNDX,MTYP) IF(LUNDX.GT.0) THEN c .... Good news, there is a unit (LUNDX) connected to a table file, c .... so store the table internally CALL RDUSDX(LUNDX,LUN) GOTO 5 ENDIF ENDIF C IF ALL ATTEMPTS TO DEFINE TABLE A FAIL SKIP GIVE UP C --------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE ('// . SUBSET // ') - RETURN WITH IRET = -1' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IRET = -1 GOTO 100 C CHECK THE VALIDITY OF THE MTYP/MSBT AND FOR COMPRESSION (MSGUNP=2) C ------------------------------------------------------------------ 10 IF(ISC3(LUN).EQ.0) THEN IF(MTYP.NE.MTY1) GOTO 900 IF(MSBT.NE.MSB1.AND.DIGIT(SUBSET(3:8))) GOTO 901 ENDIF IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) MSGUNP(LUN) = 2 C SET THE OTHER REQUIRED PARAMETERS IN MESSAGE CONTROL WORD PARTITION C ------------------------------------------------------------------- c .... Date for this message IDATE(LUN) = I4DY(JDATE) c .... Positional index of Table A mnem. INODE(LUN) = INOD c .... Number of subsets in this message MSUB(LUN) = IUPBS3(MBAY(1,LUN),'NSUB') c .... Number of subsets read so far from this message NSUB(LUN) = 0 IF(IRET.NE.11) THEN c .... Number of non-dictionary messages read so far from this file NMSG(LUN) = NMSG(LUN)+1 ENDIF C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH '// . '(SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') SUBSET,MTYP,MTY1 CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH '// . '(SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') SUBSET,MSBT,MSB1 CALL BORT(BORT_STR) END ./closbf.f0000644001370400056700000000505313440555365011405 0ustar jator2emc SUBROUTINE CLOSBF(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CLOSBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE IS CALLED IN ORDER TO TERMINATE BUFR C ARCHIVE LIBRARY SOFTWARE ACCESS TO A LOGICAL UNIT LUNIT FOR INPUT C OR OUTPUT OPERATIONS (PREVIOUSLY OPENED BY A FORTRAN "OPEN" ON THE C LOGICAL UNIT AND BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF). C CLOSBF MUST BE CALLED WHEN LUNIT IS CONNECTED TO A BUFR FILE OPEN C FOR OUTPUT IN ORDER TO PROPERLY CLOSE AND WRITE ANY CURRENT BUFR C MESSAGE WHICH MAY STILL EXIST IN INTERNAL MEMORY (AND MOST LIKELY C NOT BE FULL). IT IS NOT MANDATORY THAT CLOSBF BE CALLED WHEN LUNIT C IS CONNECTED TO A BUFR FILE OPEN FOR INPUT, BUT IT IS STILL A GOOD C IDEA TO DO SO. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 J. ATOR -- DON'T CLOSE LUNIT IF OPENED AS A NULL FILE C BY OPENBF {NULL(LUN) = 1 IN NEW COMMON C BLOCK /NULBFR/} (WAS IN DECODER VERSION) 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) C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C -- ADDED CALL TO CLOSFB TO CLOSE C FILES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CLOSBF (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C OUTPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: CLOSFB CLOSMG STATUS WTSTAT C THIS ROUTINE IS CALLED BY: COPYBF EXITBUFR MESGBF UFBINX C UFBMEM UFBMEX UFBTAB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_NULBFR INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.GT.0 .AND. IM.NE.0) CALL CLOSMG(LUNIT) IF(IL.NE.0 .AND. NULL(LUN).EQ.0) CALL CLOSFB(LUN) CALL WTSTAT(LUNIT,LUN,0,0) C CLOSE fortran UNIT IF NULL(LUN) = 0 C ----------------------------------- IF(NULL(LUN).EQ.0) CLOSE(LUNIT) RETURN END ./closmg.f0000644001370400056700000001356013440555365011423 0ustar jator2emc SUBROUTINE CLOSMG(LUNIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CLOSMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C ABS(LUNIN) HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT CLOSES A BUFR C MESSAGE PREVIOUSLY OPENED BY EITHER BUFR ARCHIVE LIBRARY C SUBROUTINES OPENMG OR OPENMB AND WRITES IT TO THE UNIT ABS(LUNIN). C SINCE OPENMG AND OPENMB NORMALLY CALL THIS INTERNALLY, IT IS NOT C CALLED TOO OFTEN FROM AN APPLICATION PROGRAM. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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-05-19 J. WOOLLEN -- CORRECTED A PROBLEM INTRODUCED IN A C PREVIOUS (MAY 2002) IMPLEMENTATION WHICH C PREVENTED THE DUMP CENTER TIME AND C INTITIATION TIME MESSAGES FROM BEING C WRITTEN OUT (THIS AFFECTED APPLICATION C PROGRAM BUFR_DUMPMD, IF IT WERE RECOMPILED, C IN THE DATA DUMPING PROCESS) 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-05-26 D. KEYSER -- ALLOWS OVERRIDE OF PREVIOUS LOGIC THAT HAD C ALWAYS WRITTEN OUT MESSAGE NUMBERS 1 AND 2 C EVEN WHEN THEY CONTAINED ZERO SUBSETS C (ASSUMED THESE ARE DUMMIES, CONTAINING ONLY C CENTER AND DUMP TIME) (NO OTHER EMPTY C MESSAGES WERE WRITTEN OUT), DONE BY PASSING C IN A NEGATIVE UNIT NUMBER ARGUMENT THE C FIRST TIME THIS ROUTINE IS CALLED BY AN C APPLICATION PROGRAM (ALL EMPTY MESSAGES ARE C SKIPPED) (ASSUMES DUMMY MESSAGES ARE NOT IN C INPUT FILE), NOTE: THIS REMAINS SET FOR THE C PARTICULAR FILE BEING WRITTEN TO EACH TIME C CLOSMG IS CALLED, REGARDLESS OF THE SIGN OF C THE UNIT NUMBER - THIS IS NECESSARY BECAUSE C THIS ROUTINE IS CALLED BY OTHER BUFRLIB C ROUTINES WHICH ALWAYS PASS IN A POSITIVE C UNIT NUMBER (THE APPLICATION PROGRAM SHOULD C ALWAYS CALL CLOSMG WITH A NEGATIVE UNIT C NUMBER IMMEDIATELY AFTER CALLING OPENBF FOR C THIS OUTPUT FILE IF THE INTENTION IS TO C NOT WRITE ANY EMPTY MESSAGES) C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CLOSMG (LUNIN) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C - IF LUNIN IS GREATER THAN ZERO, THEN MESSAGE NUMBER C 1 OR 2 IS WRITTEN OUT EVEN IF THE NUMBER OF C SUBSETS WRITTEN INTO THE MESSAGE IS ZERO (THIS C ALLOWS "DUMMY" MESSAGES CONTAINING DUMP CENTER AND C INITIATION TIME TO BE COPIED), MESSAGE NUMBERS 3 C AND HIGHER ARE NOT WRITTEN OUT IF THEY CONTAIN C ZERO SUBSETS C - IF LUNIN IS LESS THAN ZERO, THEN NO MESSAGES WITH C ZERO SUBSETS WRITTEN INTO THEM ARE WRITTEN OUT C FOR A PARTICULAR FILE BOTH IN THIS CALL AND IN ALL C SUBSEQUENT CALLS TO THIS ROUTINE BY AN APPLICATION C PROGRAM C C REMARKS: C THIS ROUTINE CALLS: BORT MSGWRT STATUS WRCMPS C WTSTAT C THIS ROUTINE IS CALLED BY: CLOSBF MAKESTAB OPENMB OPENMG C WRITSA C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_MSGLIM USE MODA_BITBUF INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- LUNIT = ABS(LUNIN) CALL STATUS(LUNIT,LUN,IL,IM) IF(LUNIT.NE.LUNIN) MSGLIM(LUN) = 0 IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.NE.0) THEN IF(NSUB(LUN).GT.0) THEN CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) ELSE IF(NSUB(LUN).EQ.0.AND.NMSG(LUN).LT.MSGLIM(LUN)) THEN CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) ELSE IF(NSUB(LUN).LT.0) THEN CALL WRCMPS(-LUNIT) ENDIF ENDIF CALL WTSTAT(LUNIT,LUN,IL,0) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') END ./cmpia.c0000644001370400056700000000227613440555365011227 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMPIA C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS ROUTINE DEFINES A COMPARISON BETWEEN TWO INTEGERS C FOR USE BY THE BINARY SEARCH FUNCTION BSEARCH. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CMPIA( PF1, PF2 ) C INPUT ARGUMENT LIST: C PF1 - INTEGER: FIRST INTEGER TO BE COMPARED C PF2 - INTEGER: SECOND INTEGER TO BE COMPARED C C OUTPUT ARGUMENT LIST: C CMPIA - INTEGER: RESULT OF COMPARISON: C -1 = PF1 is less than PF2 C 0 = PF1 is equal to PF2 C 1 = PF1 is greater than PF2 C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: NUMMTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" int cmpia( const void *pf1, const void *pf2 ) { f77int *mypf1 = ( f77int * ) pf1; f77int *mypf2 = ( f77int * ) pf2; if ( *mypf1 == *mypf2 ) return 0; return ( *mypf1 < *mypf2 ? -1 : 1 ); } ./cmpmsg.f0000644001370400056700000000324313440555365011422 0ustar jator2emc SUBROUTINE CMPMSG(CF) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMPMSG C PRGMMR: ATOR ORG: NP12 DATE: 2005-03-09 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR C MESSAGES CREATED BY FUTURE CALLS TO EITHER OF THE BUFR ARCHIVE C LIBRARY SUBROUTINES WRITSB OR WRITSA ARE TO BE COMPRESSED. C THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL C TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES C FOR CF ARE 'N' (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). C C PROGRAM HISTORY LOG: C 2005-03-09 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CMPMSG (CF) C INPUT ARGUMENT LIST: C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES C OUTPUT BY FUTURE CALLS TO WRITSB OR WRITSA ARE TO C BE COMPRESSED: C 'N' = 'NO' (THE DEFAULT) C 'Y' = 'YES' C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT C THIS ROUTINE IS CALLED BY: COPYSB WRITCP C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /MSGCMP/ CCMF CHARACTER*128 BORT_STR CHARACTER*1 CCMF, CF C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 CCMF = CF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: CMPMSG - INPUT ARGUMENT IS ",A1,'// . '", IT MUST BE EITHER Y OR N")') CF CALL BORT(BORT_STR) END ./cmpstia1.c0000644001370400056700000000377613440555365011665 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMPSTIA1 C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-13 C C ABSTRACT: THIS ROUTINE DEFINES A COMPARISON BETWEEN TWO ENTRIES IN C THE INTERNAL MEMORY STRUCTURE USED FOR STORING ASCII MASTER C CODE/FLAG TABLE INFORMATION. THE COMPARISON IS USED BY THE C BINARY SEARCH FUNCTIONS QSORT AND BSEARCH, AND IT DIFFERS FROM THE C LOGIC IN ROUTINE CMPSTIA2 BECAUSE IT COMPARES ALL OF THE IFFXY, C IFVAL, IFFXYD and IFVALD COMPONENTS OF THE STRUCTURE, WHEREAS C CMPSTIA2 ONLY COMPARES THE IFFXYN AND IFVAL COMPONENTS. C C PROGRAM HISTORY LOG: C 2017-11-13 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CMPSTIA1( PE1, PE2 ) C INPUT ARGUMENT LIST: C PE1 - FIRST STRUCTURE ENTRY TO BE COMPARED C PE2 - SECOND STRUCTURE ENTRY TO BE COMPARED C C OUTPUT ARGUMENT LIST: C CMPSTIA2 - INTEGER: RESULT OF COMPARISON: C -1 = PE1 is less than PE2 C 0 = PE1 is equal to PE2 C 1 = PE1 is greater than PE2 C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: SORTTBF SRCHTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" int cmpstia1( const void *pe1, const void *pe2 ) { struct code_flag_entry *mype1 = ( struct code_flag_entry * ) pe1; struct code_flag_entry *mype2 = ( struct code_flag_entry * ) pe2; if ( mype1->iffxyn == mype2->iffxyn ) { if ( mype1->ifval == mype2->ifval ) { if ( mype1->iffxynd == mype2->iffxynd ) { if ( mype1->ifvald == mype2->ifvald ) return 0; return ( mype1->ifvald < mype2->ifvald ? -1 : 1 ); } else { return ( mype1->iffxynd < mype2->iffxynd ? -1 : 1 ); } } else { return ( mype1->ifval < mype2->ifval ? -1 : 1 ); } } else { return ( mype1->iffxyn < mype2->iffxyn ? -1 : 1 ); } } ./cmpstia2.c0000644001370400056700000000336413440555365011657 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMPSTIA2 C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-13 C C ABSTRACT: THIS ROUTINE DEFINES A COMPARISON BETWEEN TWO ENTRIES IN C THE INTERNAL MEMORY STRUCTURE USED FOR STORING ASCII MASTER C CODE/FLAG TABLE INFORMATION. THE COMPARISON IS USED BY THE C BINARY SEARCH FUNCTION BSEARCH, AND IT DIFFERS FROM THE LOGIC IN C ROUTINE CMPSTIA1 BECAUSE IT ONLY COMPARES THE IFFXYN AND IFVAL C COMPONENTS OF THE STRUCTURE, WHEREAS CMPSTIA1 COMPARES ALL OF THE C COMPONENTS IFFXY, IFVAL, IFFXYD and IFVALD. C C PROGRAM HISTORY LOG: C 2017-11-13 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CMPSTIA2( PE1, PE2 ) C INPUT ARGUMENT LIST: C PE1 - FIRST STRUCTURE ENTRY TO BE COMPARED C PE2 - SECOND STRUCTURE ENTRY TO BE COMPARED C C OUTPUT ARGUMENT LIST: C CMPSTIA2 - INTEGER: RESULT OF COMPARISON: C -1 = PE1 is less than PE2 C 0 = PE1 is equal to PE2 C 1 = PE1 is greater than PE2 C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: SRCHTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" int cmpstia2( const void *pe1, const void *pe2 ) { struct code_flag_entry *mype1 = ( struct code_flag_entry * ) pe1; struct code_flag_entry *mype2 = ( struct code_flag_entry * ) pe2; if ( mype1->iffxyn == mype2->iffxyn ) { if ( mype1->ifval == mype2->ifval ) return 0; return ( mype1->ifval < mype2->ifval ? -1 : 1 ); } else { return ( mype1->iffxyn < mype2->iffxyn ? -1 : 1 ); } } ./cmsgini.f0000644001370400056700000001562713440555365011576 0ustar jator2emc SUBROUTINE CMSGINI(LUN,MESG,SUBSET,IDATE,NSUB,NBYT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CMSGINI C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT C IN COMPRESSED BUFR. THE ACTUAL LENGTH OF SECTION 4 (CONTAINING C COMPRESSED DATA) IS ALREADY KNOWN. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR 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; LEN3 INITIALIZED AS C ZERO (BEFORE WAS UNDEFINED WHEN FIRST C REFERENCED) C 2004-08-18 J. ATOR -- ADDED COMMON /MSGSTD/ AND OTHER LOGIC TO C ALLOW OPTION OF CREATING A SECTION 3 THAT IS C FULLY WMO-STANDARD; IMPROVED DOCUMENTATION; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13; C REMOVED STANDARDIZATION LOGIC FOR SECTION 3 C C USAGE: CALL CMSGINI (LUN, MESG, SUBSET, IDATE, NSUB, NBYT) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING WRITTEN C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING WRITTEN, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C NSUB - INTEGER: NUMBER OF SUBSETS, STORED IN SECTION 3 OF C BUFR MESSAGE BEING WRITTEN C NBYT - INTEGER: ACTUAL LENGTH (IN BYTES) OF "COMPRESSED DATA C PORTION" OF SECTION 4 (I.E. ALL OF SECTION 4 EXCEPT C FOR THE FIRST FOUR BYTES) C C OUTPUT ARGUMENT LIST: C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE C NBYT - INTEGER: ACTUAL LENGTH OF BUFR MESSAGE (IN BYTES) UP C TO THE POINT IN SECTION 4 WHERE COMPRESSED DATA ARE C TO BE WRITTEN C C REMARKS: C THIS ROUTINE CALLS: BORT I4DY NEMTAB NEMTBA C PKB PKC C THIS ROUTINE IS CALLED BY: WRCMPS 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' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET CHARACTER*4 BUFR CHARACTER*1 TAB DIMENSION MESG(*) DATA BUFR/'BUFR'/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE C --------------------------------------------------- c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) CALL NEMTAB(LUN,SUBSET,ISUB,TAB,IRET) IF(IRET.EQ.0) GOTO 900 C DATE CAN BE YYMMDDHH OR YYYYMMDDHH C ---------------------------------- JDATE = I4DY(IDATE) MCEN = MOD(JDATE/10**8,100)+1 MEAR = MOD(JDATE/10**6,100) MMON = MOD(JDATE/10**4,100) MDAY = MOD(JDATE/10**2,100) MOUR = MOD(JDATE ,100) MMIN = 0 c .... DK: Don't think this can happen, because IDATE=0 is returned c as 2000000000 by I4DY meaning MCEN would be 21 IF(MCEN.EQ.1) GOTO 901 IF(MEAR.EQ.0) MCEN = MCEN-1 IF(MEAR.EQ.0) MEAR = 100 C INITIALIZE THE MESSAGE C ---------------------- MBIT = 0 C SECTION 0 C --------- CALL PKC(BUFR , 4 , MESG,MBIT) C NOTE THAT THE ACTUAL SECTION 0 LENGTH WILL BE COMPUTED AND C STORED BELOW; FOR NOW, WE ARE REALLY ONLY INTERESTED IN C ADVANCING MBIT BY THE CORRECT AMOUNT, SO WE'LL JUST STORE C A DEFAULT VALUE OF 0. CALL PKB( 0 , 24 , MESG,MBIT) CALL PKB( 3 , 8 , MESG,MBIT) C SECTION 1 C --------- LEN1 = 18 CALL PKB(LEN1 , 24 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) CALL PKB( 3 , 8 , MESG,MBIT) CALL PKB( 7 , 8 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) CALL PKB(MTYP , 8 , MESG,MBIT) CALL PKB(MSBT , 8 , MESG,MBIT) CALL PKB( 29 , 8 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) CALL PKB(MEAR , 8 , MESG,MBIT) CALL PKB(MMON , 8 , MESG,MBIT) CALL PKB(MDAY , 8 , MESG,MBIT) CALL PKB(MOUR , 8 , MESG,MBIT) CALL PKB(MMIN , 8 , MESG,MBIT) CALL PKB(MCEN , 8 , MESG,MBIT) C SECTION 3 C --------- LEN3 = 10 CALL PKB(LEN3 , 24 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) CALL PKB(NSUB , 16 , MESG,MBIT) CALL PKB( 192 , 8 , MESG,MBIT) CALL PKB(ISUB , 16 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) C SECTION 4 C --------- C STORE THE TOTAL LENGTH OF SECTION 4. C REMEMBER THAT THE INPUT VALUE OF NBYT ONLY CONTAINS THE C LENGTH OF THE "COMPRESSED DATA PORTION" OF SECTION 4, SO C WE NEED TO ADD FOUR BYTES TO THIS NUMBER IN ORDER TO C ACCOUNT FOR THE TOTAL LENGTH OF SECTION 4. CALL PKB((NBYT+4) , 24 , MESG,MBIT) CALL PKB( 0 , 8 , MESG,MBIT) C THE ACTUAL "COMPRESSED DATA PORTION" OF SECTION 4 WILL C BE FILLED IN LATER BY SUBROUTINE WRCMPS. C SECTION 5 C --------- C THIS SECTION WILL BE FILLED IN LATER BY SUBROUTINE WRCMPS. C RETURN WITH THE CORRECT NEW MESSAGE BYTE COUNT C ---------------------------------------------- C NOW, NOTING THAT MBIT CURRENTLY POINTS TO THE LAST BIT OF C THE FOURTH BYTE OF SECTION 4, THEN WE HAVE: C (TOTAL LENGTH OF BUFR MESSAGE (IN SECTION 0)) = C (LENGTH OF MESSAGE UP THROUGH FOURTH BYTE OF SECTION 4) C + (LENGTH OF "COMPRESSED DATA PORTION" OF SECTION 4) C + (LENGTH OF SECTION 5) MBYT = . MBIT/8 . + NBYT . + 4 C NOW, MAKE NBYT POINT TO THE CURRENT LOCATION OF MBIT C (I.E. THE BYTE AFTER WHICH TO ACTUALLY BEGIN WRITING THE C COMPRESSED DATA INTO SECTION 4). NBYT = MBIT/8 C NOW, STORE THE TOTAL LENGTH OF THE BUFR MESSAGE (IN SECTION 0). MBIT = 32 CALL PKB(MBYT,24,MESG,MBIT) C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE '// . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBSET CALL BORT(BORT_STR) 901 CALL BORT . ('BUFRLIB: CMSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') END ./cnved4.f0000644001370400056700000001045713440555365011324 0ustar jator2emc SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CNVED4 C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE READS AN INPUT BUFR MESSAGE ENCODED USING C BUFR EDITION 3 AND OUTPUTS AN EQUIVALENT BUFR MESSAGE ENCODED USING C BUFR EDITION 4. THE OUTPUT MESSAGE WILL BE SLIGHTLY LONGER THAN THE C INPUT MESSAGE, SO THE USER MUST ALLOW FOR ENOUGH SPACE WITHIN THE C MSGOT ARRAY. NOTE THAT MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2009-08-12 J. ATOR -- ALLOW SILENT RETURN (INSTEAD OF BORT RETURN) C IF MSGIN IS ALREADY ENCODED USING EDITION 4 C C USAGE: CALL CNVED4 (MSGIN, LMSGOT, MSGOT) C INPUT ARGUMENT LIST: C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE ENCODED C USING BUFR EDITION 3 C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE MSGOT ARRAY C C OUTPUT ARGUMENT LIST: C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE C NOW ENCODED USING BUFR EDITION 4 C C REMARKS: C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. C C THIS ROUTINE CALLS: BORT GETLENS IUPBS01 MVB C NMWRD PKB C THIS ROUTINE IS CALLED BY: MSGWRT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MSGIN(*), MSGOT(*) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(IUPBS01(MSGIN,'BEN').EQ.4) THEN C The input message is already encoded using edition 4, so just C copy it from MSGIN to MSGOT and then return. NMW = NMWRD(MSGIN) IF(NMW.GT.LMSGOT) GOTO 900 DO I = 1, NMW MSGOT(I) = MSGIN(I) ENDDO RETURN ENDIF C Get some section lengths and addresses from the input message. CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5) IAD2 = LEN0 + LEN1 IAD4 = IAD2 + LEN2 + LEN3 LENM = IUPBS01(MSGIN,'LENM') C Check for overflow of the output array. Note that the new C edition 4 message will be a total of 3 bytes longer than the C input message (i.e. 4 more bytes in Section 1, but 1 fewer C byte in Section 3). LENMOT = LENM + 3 IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 LEN1OT = LEN1 + 4 LEN3OT = LEN3 - 1 C Write Section 0 of the new message into the output array. CALL MVB ( MSGIN, 1, MSGOT, 1, 4 ) IBIT = 32 CALL PKB ( LENMOT, 24, MSGOT, IBIT ) CALL PKB ( 4, 8, MSGOT, IBIT ) C Write Section 1 of the new message into the output array. CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'BMT'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'OGCE'), 16, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'GSES'), 16, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'USN'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'ISC2')*128, 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MTYP'), 8, MSGOT, IBIT ) C Set a default of 255 for the international subcategory. CALL PKB ( 255, 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MSBT'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MTV'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MTVL'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'YEAR'), 16, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MNTH'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'DAYS'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'HOUR'), 8, MSGOT, IBIT ) CALL PKB ( IUPBS01(MSGIN,'MINU'), 8, MSGOT, IBIT ) C Set a default of 0 for the second. CALL PKB ( 0, 8, MSGOT, IBIT ) C Copy Section 2 (if it exists) through the next-to-last byte C of Section 3 from the input array to the output array. CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LEN2+LEN3-1 ) C Store the length of the new Section 3. IBIT = ( LEN0 + LEN1OT + LEN2 ) * 8 CALL PKB ( LEN3OT, 24, MSGOT, IBIT ) C Copy Section 4 and Section 5 from the input array to the C output array. IBIT = IBIT + ( LEN3OT * 8 ) - 24 CALL MVB ( MSGIN, IAD4+1, MSGOT, (IBIT/8)+1, LENM-IAD4 ) RETURN 900 CALL BORT('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) '// . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./cobfl.c0000644001370400056700000000606313440555365011221 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COBFL C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS ROUTINE OPENS A SPECIFIED SYSTEM FILE FOR READING C OR WRITING VIA THE BUFR ARCHIVE LIBRARY C I/O INTERFACE. THERE C CAN BE AT MOST TWO SYSTEM FILES OPEN AT ANY GIVEN TIME (ONE FOR C READING/INPUT AND ONE FOR WRITING/OUTPUT). IF A CALL TO THIS C ROUTINE IS MADE FOR EITHER READING/INPUT OR WRITING/OUTPUT AND C SUCH A FILE IS ALREADY OPEN TO THE BUFR ARCHIVE LIBRARY C I/O C INTERFACE, THEN THAT FILE WILL BE CLOSED BEFORE OPENING THE C NEW ONE. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL COBFL( BFL, IO ) C INPUT ARGUMENT LIST: C BFL - CHARACTER*(*): SYSTEM FILE TO BE OPENED. INCLUSION C OF DIRECTORY PREFIXES OR OTHER LOCAL FILESYSTEM C NOTATION IS ALLOWED UP TO 500 TOTAL CHARACTERS. C IO - CHARACTER: FLAG INDICATING HOW BFL IS TO BE OPENED C FOR USE WITH THE C I/O INTERFACE: C 'r' = READING (INPUT) C 'w' = WRITING (OUTPUT) C C REMARKS: C THIS ROUTINE CALLS: BORT WRDLEN C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #define IN_COBFL #include "cobfl.h" #define MXFNLEN 500 void cobfl( char *bfl, char *io ) { char lbf[MXFNLEN+1]; char lio; char errstr[129]; char foparg[3] = " b"; /* 3rd character will automatically initialize to NULL */ unsigned short i, j; /* ** Copy the input arguments into local variables and check them for validity. ** This is especially important in case either of the arguments was passed in ** as a string literal by the calling program or else doesn't have a trailing ** NULL character. */ for ( i = 0; ( ! isspace( bfl[i] ) && ! iscntrl( bfl[i] ) ); i++ ) { if ( i == MXFNLEN ) { sprintf( errstr, "BUFRLIB: COBFL - INPUT FILENAME CONTAINS" " MORE THAN %d CHARACTERS", MXFNLEN ); bort( errstr, ( f77int ) strlen( errstr ) ); } lbf[i] = bfl[i]; } lbf[i] = '\0'; lio = io[0]; if ( ( foparg[0] = (char) tolower( lio ) ) == 'r' ) { j = 0; } else if ( foparg[0] == 'w' ) { j = 1; } else { sprintf( errstr, "BUFRLIB: COBFL - SECOND ARGUMENT WAS (%c)," " WHICH IS AN ILLEGAL VALUE", lio ); bort( errstr, ( f77int ) strlen( errstr ) ); } /* ** If a file of this type is already open, then close it before ** opening the new one. */ if ( pbf[j] != NULL ) fclose( pbf[j] ); /* ** Open the requested file. */ if ( ( pbf[j] = fopen( lbf, foparg ) ) == NULL ) { sprintf( errstr, "BUFRLIB: COBFL - COULD NOT OPEN FILE %s", lbf ); bort( errstr, ( f77int ) strlen( errstr ) ); } /* ** Call wrdlen to initialize some important information about the ** local machine, just in case it hasn't already been called. */ wrdlen( ); return; } ./cobfl.h0000644001370400056700000000020213440555365011213 0ustar jator2emc#ifdef IN_COBFL FILE *pbf[2]; /* each element will automatically initialize to NULL */ #else extern FILE *pbf[2]; #endif ./codflg.f0000644001370400056700000000351113440555365011370 0ustar jator2emc SUBROUTINE CODFLG(CF) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CODFLG C PRGMMR: ATOR ORG: NP12 DATE: 2017-10-13 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT CODE C AND FLAG TABLE INFORMATION SHOULD BE INCLUDED WHEN READING IN C BUFR MASTER TABLE INFORMATION DURING ALL FUTURE INTERNAL CALLS C TO BUFR ARCHIVE LIBRARY FUNCTION IREADMT. THIS SUBROUTINE CAN BE C CALLED AT ANY TIME AFTER THE FIRST CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE OPENBF, AND THE POSSIBLE VALUES FOR CF ARE 'N' (= 'NO', C WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). C C PROGRAM HISTORY LOG: C 2017-10-13 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CODFLG (CF) C INPUT ARGUMENT LIST: C CF - CHARACTER*1: FLAG INDICATING WHETHER CODE AND FLAG C TABLE INFORMATION SHOULD BE INCLUDED WHEN READING IN C BUFR MASTER TABLE INFORMATION DURING FUTURE INTERNAL C CALLS TO FUNCTION IREADMT: C 'N' = 'NO' (THE DEFAULT) C 'Y' = 'YES' C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /TABLEF/ CDMF CHARACTER*128 BORT_STR CHARACTER*1 CDMF, CF C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 CDMF = CF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: CODFLG - INPUT ARGUMENT IS ",A1,'// . '", IT MUST BE EITHER Y OR N")') CF CALL BORT(BORT_STR) END ./conwin.f0000644001370400056700000000730613440555365011435 0ustar jator2emc SUBROUTINE CONWIN(LUN,INC1,INC2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CONWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SEARCHES CONSECUTIVE SUBSET BUFFER SEGMENTS C FOR AN ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE C (I.E. AN ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ C FROM OR WRITTEN TO A DATA SUBSET). IF A CONDITIONAL ELEMENT IS C FOUND AND IT CONFORMS TO THE CONDITION, THEN THE INTERNAL SUBSET C BUFFER INDICES OF THE "WINDOW" (SEE BELOW REMARKS) ARE RETURNED TO C THE CALLER FOR PROCESSING. C C THE FOUR CONDITIONS WHICH CAN BE EXERCISED ARE: C '<' - LESS THAN C '>' - GREATER THAN C '=' - EQUAL C '!' - NOT EQUAL C C EACH CONDITION IN A STRING IS APPLIED TO ONE ELEMENT, AND ALL C CONDITIONS ARE 'AND'ED TO EVALUATE AN OUTCOME. FOR EXAMPLE, IF THE C CONDITION STRING IS: "POB<500 TOB>30 TQM<4" THEN THE ONLY LEVELS OF C DATA READ OR WRITTEN ARE THOSE WITH PRESSURE LT 500 MB, TEMPERATURE C GT 30 DEG, AND TEMPERATURE QUALITY MARK < 4. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2010-04-27 J. WOOLLEN -- CORRECT LOGICAL FLAW AND ADD DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CONWIN (LUN, INC1, INC2) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INC1 - INTEGER: SUBSET BUFFER START INDEX C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX C C OUTPUT ARGUMENT LIST: C INC1 - INTEGER: SUBSET BUFFER START INDEX C INC2 - INTEGER: SUBSET BUFFER ENDING INDEX C C REMARKS: C C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. C C FUNCTION CONWIN WORKS WITH FUNCTION INVCON TO IDENTIFY SUBSET C BUFFER SEGMENTS WHICH CONFORM TO THE SET OF CONDITIONS. C C THIS ROUTINE CALLS: GETWIN INVCON C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) C---------------------------------------------------------------------- C---------------------------------------------------------------------- C SPECIAL CASE C ------------ IF(NCON.EQ.0) THEN c .... There are no condition nodes in the string INC1 = 1 INC2 = NVAL(LUN) GOTO 100 ENDIF C EVALUATE CONDITIONS TO SEE IF ANY MORE CASES C -------------------------------------------- 15 CALL GETWIN(NODC(1),LUN,INC1,INC2) IF(INC1.GT.0) THEN DO NC=1,NCON ICON = INVCON(NC,LUN,INC1,INC2) IF(ICON.EQ.0) GOTO 15 ENDDO ENDIF C EXIT C ---- 100 RETURN END ./copybf.f0000644001370400056700000000667513440555365011432 0ustar jator2emc SUBROUTINE COPYBF(LUNIN,LUNOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COPYBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES AN ENTIRE BUFR FILE FROM LOGICAL C UNIT LUNIN TO LOGICAL UNIT LUNOT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 RDMSGW AND NMWRD C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE C USE READMG AND COPYMG TO COPY FILE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL COPYBF (LUNIN, LUNOT) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C INPUT FILES: C UNIT "LUNIN" - BUFR FILE C C OUTPUT FILES: C UNIT "LUNOT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT CLOSBF IUPBS01 MSGWRT C OPENBF RDMSGW STATUS WRDLEN C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) C --------------------------------------------------------------- CALL WRDLEN C CHECK BUFR FILE STATUSES C ------------------------ CALL STATUS(LUNIN,LUN,IL,IM) IF(IL.NE.0) GOTO 900 CALL STATUS(LUNOT,LUN,IL,IM) IF(IL.NE.0) GOTO 901 C CONNECT THE FILES FOR READING/WRITING TO THE C-I-O INTERFACE C ------------------------------------------------------------ CALL OPENBF(LUNIN,'INX',LUNIN) CALL OPENBF(LUNOT,'OUX',LUNIN) C READ AND COPY A BUFR FILE ON UNIT LUNIN TO UNIT LUNOT C ----------------------------------------------------- 1 CALL RDMSGW(LUNIN,MGWA,IER) IF(IER.EQ.0) THEN CALL MSGWRT(LUNOT,MGWA,IUPBS01(MGWA,'LENM')) GOTO 1 ENDIF C FREE UP THE FILE CONNECTIONS FOR THE TWO FILES C ---------------------------------------------- CALL CLOSBF(LUNIN) CALL CLOSBF(LUNOT) C EXITS C ----- RETURN 900 CALL BORT . ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') 901 CALL BORT . ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') END ./copymg.f0000644001370400056700000001135013440555365011430 0ustar jator2emc SUBROUTINE COPYMG(LUNIN,LUNOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COPYMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM LOGICAL C UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT C VIA A PREVIOUS CALL TO OPENBF. THE MESSAGE COPIED FROM LOGICAL C UNIT LUNIN WILL BE THE ONE MOST RECENTLY READ USING BUFR ARCHIVE C LIBRARY SUBROUTINE READMG. THE OUTPUT FILE MUST HAVE NO CURRENTLY C OPEN MESSAGES. ALSO, BOTH FILES MUST HAVE BEEN OPENED TO THE BUFR C INTERFACE WITH IDENTICAL BUFR TABLES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE 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 IUPBS01 C 2009-06-26 J. ATOR -- USE IOK2CPY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL COPYMG (LUNIN, LUNOT) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT C NEMTBA STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUSES C ----------------------- CALL STATUS(LUNIN,LIN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 CALL STATUS(LUNOT,LOT,IL,IM) IF(IL.EQ.0) GOTO 903 IF(IL.LT.0) GOTO 904 IF(IM.NE.0) GOTO 905 C MAKE SURE BOTH FILES HAVE THE SAME TABLES C ----------------------------------------- SUBSET = TAG(INODE(LIN)) c .... Given SUBSET, returns MTYP,MSBT,INOD CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) IF(INODE(LIN).NE.INOD) THEN IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 ENDIF C EVERYTHING OKAY, COPY A MESSAGE C ------------------------------- MBYM = IUPBS01(MBAY(1,LIN),'LENM') CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT C ----------------------------------------------------------------- NMSG (LOT) = NMSG(LOT) + 1 NSUB (LOT) = MSUB(LIN) MSUB (LOT) = MSUB(LIN) IDATE(LOT) = IDATE(LIN) INODE(LOT) = INOD C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 904 CALL BORT('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 905 CALL BORT('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN '// . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') 906 CALL BORT('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST '// . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') END ./copysb.f0000644001370400056700000001711013440555365011431 0ustar jator2emc SUBROUTINE COPYSB(LUNIN,LUNOT,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: COPYSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A PACKED DATA SUBSET, INTACT, FROM C LOGICAL UNIT LUNIN, OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR C ARCHIVE LIBRARY SUBROUTINE OPENBF, TO LOGICAL UNIT LUNOT, OPENED C FOR OUTPUT VIA A PREVIOUS CALL TO OPENBF. THE BUFR MESSAGE MUST C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED C OR UNCOMPRESSED. ALSO, BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A C BUFR MESSAGE WITHIN MEMORY FOR UNIT LUNOT. EACH CALL TO COPYSB C ADVANCES THE POINTER TO THE BEGINNING OF THE NEXT SUBSET IN BOTH C THE INPUT AND OUTPUT FILES, UNLESS INPUT PARAMETER LUNOT IS .LE. C ZERO, IN WHICH CASE THE OUTPUT POINTER IS NOT ADVANCED. THE C COMPRESSION STATUS OF THE OUTPUT SUBSET/BUFR MESSAGE WILL ALWAYS C MATCH THAT OF THE INPUT SUBSET/BUFR MESSAGE {I.E., IF INPUT MESSAGE C IS UNCOMPRESSED(COMPRESSED) OUTPUT MESSAGE WILL BE UNCOMPRESSED C (COMPRESSED)}. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES 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-09-16 J. WOOLLEN -- NOW WRITES OUT COMPRESSED SUBSET/MESSAGE IF C INPUT SUBSET/MESSAGE IS COMPRESSED (BEFORE C COULD ONLY WRITE OUT UNCOMPRESSED SUBSET/ C MESSAGE REGARDLESS OF COMPRESSION STATUS OF C INPUT SUBSET/MESSAGE) C 2009-06-26 J. ATOR -- USE IOK2CPY C 2014-11-03 J. ATOR -- HANDLE OVERSIZED (>65530 BYTE) SUBSETS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL COPYSB ( LUNIN, LUNOT, IRET ) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the input C BUFR message C C REMARKS: C THIS ROUTINE CALLS: BORT CMPMSG CPYUPD GETLENS C IOK2CPY MESGBC READSB STATUS C UFBCPY UPB WRITSB C THIS ROUTINE IS CALLED BY: ICOPYSB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUSES C ----------------------- CALL STATUS(LUNIN,LIN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(LUNOT.GT.0) THEN CALL STATUS(LUNOT,LOT,IL,IM) IF(IL.EQ.0) GOTO 903 IF(IL.LT.0) GOTO 904 IF(IM.EQ.0) GOTO 905 IF(INODE(LIN).NE.INODE(LOT)) THEN IF( (TAG(INODE(LIN)).NE.TAG(INODE(LOT))) .OR. . (IOK2CPY(LIN,LOT).NE.1) ) GOTO 906 ENDIF ENDIF C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- IF(NSUB(LIN).EQ.MSUB(LIN)) THEN IRET = -1 GOTO 100 ENDIF C CHECK COMPRESSION STATUS OF INPUT MESSAGE, OUTPUT MESSAGE WILL MATCH C -------------------------------------------------------------------- CALL MESGBC(-LUNIN,MEST,ICMP) IF(ICMP.EQ.1) THEN C ------------------------------------------------------- C THIS BRANCH IS FOR COMPRESSED INPUT/OUTPUT MESSAGES C ------------------------------------------------------- C READ IN AND UNCOMPRESS SUBSET, THEN COPY IT TO COMPRESSED OUTPUT MSG C -------------------------------------------------------------------- CALL READSB(LUNIN,IRET) IF(LUNOT.GT.0) THEN CALL UFBCPY(LUNIN,LUNOT) CALL CMPMSG('Y') CALL WRITSB(LUNOT) CALL CMPMSG('N') ENDIF GOTO 100 ELSE IF(ICMP.EQ.0) THEN C ------------------------------------------------------- C THIS BRANCH IS FOR UNCOMPRESSED INPUT/OUTPUT MESSAGES C ------------------------------------------------------- C COPY THE SUBSET TO THE OUTPUT MESSAGE AND/OR RESET THE POINTERS C --------------------------------------------------------------- IBIT = (MBYT(LIN))*8 CALL UPB(NBYT,16,MBAY(1,LIN),IBIT) IF (NBYT.GT.65530) THEN C This is an oversized subset, so we can't rely on the value C of NBYT as being the true size (in bytes) of the subset. IF ( (NSUB(LIN).EQ.0) .AND. (MSUB(LIN).EQ.1) ) THEN C But it's also the first and only subset in the message, C so we can determine its true size in a different way. CALL GETLENS(MBAY(1,LIN),4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) NBYT = LEN4 - 4 ELSE C We have no way to easily determine the true size of this C oversized subset. IRET = -1 GOTO 100 ENDIF ENDIF IF(LUNOT.GT.0) CALL CPYUPD(LUNOT,LIN,LOT,NBYT) MBYT(LIN) = MBYT(LIN) + NBYT NSUB(LIN) = NSUB(LIN) + 1 ELSE GOTO 907 ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 904 CALL BORT('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 905 CALL BORT('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 906 CALL BORT('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST '// . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') 907 WRITE(BORT_STR,'("BUFRLIB: COPYSB - INVALID COMPRESSION '// . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// . 'ROUTINE MESGBC")') ICMP CALL BORT(BORT_STR) END ./cpbfdx.f0000644001370400056700000000603213440555365011401 0ustar jator2emc SUBROUTINE CPBFDX(LUD,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CPBFDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES BUFR TABLE (DICTIONARY) MESSAGES C FROM ONE LOCATION TO ANOTHER WITHIN INTERNAL MEMORY (ARRAYS IN C MODULE MSGCWD AND 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 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY) C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CPBFDX (LUD, LUN) C INPUT ARGUMENT LIST: C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR INPUT TABLE LOCATION C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR OUTPUT TABLE LOCATION C C REMARKS: C THIS ROUTINE CALLS: DXINIT C THIS ROUTINE IS CALLED BY: MAKESTAB READDX WRDXTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_TABABD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C INITIALIZE THE DICTIONARY TABLE PARTITION C ----------------------------------------- CALL DXINIT(LUN,0) C COPY ONE TABLE PARTITION TO ANOTHER C ----------------------------------- c .... Positional index for Table A mnem. INODE(LUN) = INODE(LUD) c .... Set the number of Table A entries NTBA(LUN) = NTBA(LUD) c .... Set the number of Table B entries NTBB(LUN) = NTBB(LUD) c .... Set the number of Table D entries NTBD(LUN) = NTBD(LUD) c .... Copy Table A entries DO I=1,NTBA(LUD) c .... Message type IDNA(I,LUN,1) = IDNA(I,LUD,1) c .... Message subtype IDNA(I,LUN,2) = IDNA(I,LUD,2) c .... Table A entries TABA(I,LUN) = TABA(I,LUD) c .... Pointer indices into internal tbl MTAB(I,LUN) = MTAB(I,LUD) ENDDO c .... Copy Table B entries DO I=1,NTBB(LUD) c .... Integer repr. of FXY descr. IDNB(I,LUN) = IDNB(I,LUD) c .... Table B entries TABB(I,LUN) = TABB(I,LUD) ENDDO c .... Copy Table D entries DO I=1,NTBD(LUD) c .... Integer repr. of FXY descr. IDND(I,LUN) = IDND(I,LUD) c .... Table B entries TABD(I,LUN) = TABD(I,LUD) ENDDO RETURN END ./cpdxmm.f0000644001370400056700000001171613440555365011430 0ustar jator2emc SUBROUTINE CPDXMM( LUNIT ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CPDXMM C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO MODULE MSGMEM. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C REPLACED FORTRAN BACKSPACE WITH C BACKBUFR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CPDXMM (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C REMARKS: C C THE FOLLOWING VALUES ARE STORED WITHIN MODULE MSGMEM BY THIS C SUBROUTINE: C C LDXM = number of array words filled within MDX C C MDX(I=1,LDXM) = DX dictionary messages for use in decoding C data messages stored within MSGS array (in C MODULE MSGMEM) C C NDXM = number of DX dictionary messages within MDX C C IPDXM(I=1,NDXM) = pointer to first word of (I)th message C within MDX C C NDXTS = number of DX dictionary tables represented by C messages within MDX C C IFDXTS(J=1,NDXTS) = sequential number of first message C within MDX which is part of (J)th C dictionary table C C ICDXTS(J=1,NDXTS) = count of consecutive messages within MDX C (beginning with IFDXTS(J)) which C constitute (J)th dictionary table C C IPMSGS(J=1,NDXTS) = sequential number of first data message C within MSGS array (in MODULE MSGMEM) C to which (J)th dictionary table applies C C LDXTS = current dictionary table that is in scope C (i.e. a number between 1 and NDXTS) C C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IUPBS3 C NMWRD RDMSGW C THIS ROUTINE IS CALLED BY: UFBMEM C Not normally called by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA USE MODA_MSGMEM INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT CHARACTER*128 ERRSTR LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( NDXTS .GE. MXDXTS ) GOTO 900 ICT = 0 DONE = .FALSE. CALL STATUS(LUNIT,LUN,IL,IM) C Read a complete dictionary table from LUNIT, as a set of one or C more DX dictionary messages. DO WHILE ( .NOT. DONE ) CALL RDMSGW ( LUNIT, MGWA, IER ) IF ( IER .EQ. -1 ) THEN C Don't abort for an end-of-file condition, since it may be C possible for a file to end with dictionary messages. C Instead, backspace the file pointer and let the calling C routine diagnose the end-of-file condition and deal with C it as it sees fit. CALL BACKBUFR(LUN) DONE = .TRUE. ELSE IF ( IER .EQ. -2 ) THEN GOTO 901 ELSE IF ( IDXMSG(MGWA) .NE. 1 ) THEN C This is a non-DX dictionary message. Assume we've reached C the end of the dictionary table, and backspace LUNIT so that C the next read (e.g. in the calling routine) will get this C same message. CALL BACKBUFR(LUN) DONE = .TRUE. ELSE IF ( IUPBS3(MGWA,'NSUB') .EQ. 0 ) THEN C This is a DX dictionary message, but it doesn't contain any C actual dictionary information. Assume we've reached the end C of the dictionary table. DONE = .TRUE. ELSE C Store this message into MODULE MSGMEM. ICT = ICT + 1 IF ( ( NDXM + ICT ) .GT. MXDXM ) GOTO 902 IPDXM(NDXM+ICT) = LDXM + 1 LMEM = NMWRD(MGWA) IF ( ( LDXM + LMEM ) .GT. MXDXW ) GOTO 903 DO J = 1, LMEM MDX(LDXM+J) = MGWA(J) ENDDO LDXM = LDXM + LMEM ENDIF ENDDO C Update the table information within MODULE MSGMEM. IF ( ICT .GT. 0 ) THEN IFDXTS(NDXTS+1) = NDXM + 1 ICDXTS(NDXTS+1) = ICT IPMSGS(NDXTS+1) = MSGP(0) + 1 NDXM = NDXM + ICT NDXTS = NDXTS + 1 IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A)') . 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', NDXTS, . ' CONSISTING OF ', ICT, ' MESSAGES' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ENDIF RETURN 900 CALL BORT('BUFRLIB: CPDXMM - MXDXTS OVERFLOW') 901 CALL BORT('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR') 902 CALL BORT('BUFRLIB: CPDXMM - MXDXM OVERFLOW') 903 CALL BORT('BUFRLIB: CPDXMM - MXDXW OVERFLOW') END ./cpmstabs.c0000644001370400056700000000665113440555365011753 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CPMSTABS C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: IF DYNAMIC MEMORY ALLOCATION IS BEING USED, THEN WE CAN'T C DIRECTLY ACCESS THE FORTRAN MODULE MSTABS ARRAYS FROM WITHIN C, SO C THIS ROUTINE IS CALLED WITHIN BUFR ARCHIVE LIBRARY SUBROUTINE C IREADMT TO COPY THE RELEVANT INFORMATION FROM THESE FORTRAN ARRAYS C TO NEW ARRAYS FOR USE WITHIN C. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CPMSTABS ( PNMTB, PIBFXYN, PCBSCL, PCBSREF, PCBBW, C PCBUNIT, PCBMNEM, PCBELEM, C PNMTD, PIDFXYN, PCDSEQ, PCDMNEM, PNDELEM, C PIDEFXY, MAXCD) C INPUT ARGUMENT LIST: C PMTBB - INTEGER: NUMBER OF ENTRIES IN MASTER TABLE B ARRAYS C PIBFXYN(*) - INTEGER: BIT-WISE REPRESENTATIONS OF FXY NUMBERS C PCBSCL(*) - CHARACTER*4: SCALE FACTORS C PCBCSREF(*)- CHARACTER*12: REFERENCE VALUES C PCBBW(*) - CHARACTER*4: BIT WIDTHS C PCBUNIT(*) - CHARACTER*14: UNITS C PCBMNEM(*) - CHARACTER*8: MNEMONICS C PCBELEM(*) - CHARACTER*120: ELEMENT NAMES C PMTBD - INTEGER: NUMBER OF ENTRIES IN MASTER TABLE D ARRAYS C PIDFXYN(*) - INTEGER: BIT-WISE REPRESENTATIONS OF FXY NUMBERS C PCDSEQ(*) - CHARACTER*120: SEQUENCE NAMES C PCDMNEM(*) - CHARACTER*8: MNEMONICS C PNDELEM(*) - INTEGER: NUMBER OF ELEMENTS STORED FOR PCDSEQ C PIDEFXY(*,*)- INTEGER: BIT-WISE REPRESENTATIONS OF FXY NUMBERS C FOR ELEMENTS IN PNDELEM C MAXCD - INTEGER: MAXIMUM NUMBER OF ELEMENTS PER PCDSEQ; C USED BY THE SUBROUTINE WHEN CALLING FUNCTION ICVIDX C C REMARKS: C THIS ROUTINE CALLS: ICVIDX C THIS ROUTINE IS CALLED BY: IREADMT C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #ifdef DYNAMIC_ALLOCATION #include "bufrlib.h" #include "mstabs.h" void cpmstabs( f77int *pnmtb, f77int *pibfxyn, char (*pcbscl)[4], char (*pcbsref)[12], char (*pcbbw)[4], char (*pcbunit)[14], char (*pcbmnem)[8], char (*pcbelem)[120], f77int *pnmtd, f77int *pidfxyn, char (*pcdseq)[120], char (*pcdmnem)[8], f77int *pndelem, f77int *pidefxy, f77int *maxcd ) { f77int ii, jj, idx; MSTABS_BASE(nmtb) = *pnmtb; for ( ii = 0; ii < *pnmtb; ii++ ) { MSTABS_BASE(ibfxyn)[ii] = pibfxyn[ii]; for ( jj = 0; jj < 4; jj++ ) { MSTABS_BASE(cbscl)[ii][jj] = pcbscl[ii][jj]; MSTABS_BASE(cbbw)[ii][jj] = pcbbw[ii][jj]; } for ( jj = 0; jj < 8; jj++ ) { MSTABS_BASE(cbmnem)[ii][jj] = pcbmnem[ii][jj]; } for ( jj = 0; jj < 12; jj++ ) { MSTABS_BASE(cbsref)[ii][jj] = pcbsref[ii][jj]; } for ( jj = 0; jj < 14; jj++ ) { MSTABS_BASE(cbunit)[ii][jj] = pcbunit[ii][jj]; } for ( jj = 0; jj < 120; jj++ ) { MSTABS_BASE(cbelem)[ii][jj] = pcbelem[ii][jj]; } } MSTABS_BASE(nmtd) = *pnmtd; for ( ii = 0; ii < *pnmtd; ii++ ) { MSTABS_BASE(idfxyn)[ii] = pidfxyn[ii]; MSTABS_BASE(ndelem)[ii] = pndelem[ii]; for ( jj = 0; jj < pndelem[ii]; jj++ ) { idx = icvidx( &ii, &jj, maxcd ); MSTABS_BASE(idefxy)[idx] = pidefxy[idx]; } for ( jj = 0; jj < 8; jj++ ) { MSTABS_BASE(cdmnem)[ii][jj] = pcdmnem[ii][jj]; } for ( jj = 0; jj < 120; jj++ ) { MSTABS_BASE(cdseq)[ii][jj] = pcdseq[ii][jj]; } } } #endif ./cpymem.f0000644001370400056700000001342013440555365011424 0ustar jator2emc SUBROUTINE CPYMEM(LUNOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CPYMEM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A BUFR MESSAGE, INTACT, FROM C INTERNAL MEMORY, STORED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE UFBMEM, TO LOGICAL UNIT LUNOT, OPENED FOR OUTPUT VIA A C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE C MESSAGE COPIED FROM INTERNAL MEMORY WILL BE THE ONE MOST RECENTLY C READ INTO THE MESSAGE BUFFER (ARRAY MBAY IN MODULE BITBUF) C USING BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM OR READMM. THE OUTPUT C FILE MUST HAVE NO CURENTLY OPEN MESSAGES. ALSO, THE INTERNAL BUFR C TABLES ASSOCIATED WITH THE INPUT MESSAGE MUST BE IDENTICAL TO THE C BUFR TABLES USED TO OPEN LUNOT TO THE BUFR INTERFACE. THIS C SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE COPYMG C EXCEPT THE INPUT MESSAGE IS FROM INTERNAL MEMORY NOT FROM A C PHYSICAL BUFR FILE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2005-11-29 J. ATOR -- USE IUPBS01 C 2009-06-26 J. ATOR -- USE IOK2CPY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL CPYMEM (LUNOT) C INPUT ARGUMENT LIST: C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IOK2CPY IUPBS01 MSGWRT C NEMTBA STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_MSGMEM USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUSES C ----------------------- CALL STATUS(MUNIT,LIN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 CALL STATUS(LUNOT,LOT,IL,IM) IF(IL.EQ.0) GOTO 903 IF(IL.LT.0) GOTO 904 IF(IM.NE.0) GOTO 905 C MAKE SURE BOTH FILES HAVE THE SAME TABLES C ----------------------------------------- SUBSET = TAG(INODE(LIN)) c .... Given SUBSET, returns MTYP,MSBT,INOD CALL NEMTBA(LOT,SUBSET,MTYP,MSBT,INOD) IF(INODE(LIN).NE.INOD) THEN IF(IOK2CPY(LIN,LOT).NE.1) GOTO 906 ENDIF C EVERYTHING OKAY, COPY A MESSAGE C ------------------------------- MBYM = IUPBS01(MBAY(1,LIN),'LENM') CALL MSGWRT(LUNOT,MBAY(1,LIN),MBYM) C SET THE MESSAGE CONTROL WORDS FOR PARTITION ASSOCIATED WITH LUNOT C ----------------------------------------------------------------- NMSG (LOT) = NMSG(LOT) + 1 NSUB (LOT) = MSUB(LIN) MSUB (LOT) = MSUB(LIN) IDATE(LOT) = IDATE(LIN) INODE(LOT) = INOD C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// . ' BUFR MESSAGES IN INTERNAL MEMORY IS CLOSED, IT MUST BE OPEN '// . 'FOR INPUT') 901 CALL BORT('BUFRLIB: CPYMEM - LOGICAL UNIT NO. ASSOC. WITH INPUT'// . ' BUFR MESSAGES IN INTERNAL MEMORY OPEN FOR OUTPUT, MUST BE '// . ' OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE') 903 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 904 CALL BORT('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 905 CALL BORT('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN '// . 'OUTPUT BUFR FILE, A MESSAGE IS OPEN') 906 CALL BORT('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL '// . 'MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL TABLES '// . '(DIFFERENT HERE)') END ./cpyupd.f0000644001370400056700000001450113440555365011437 0ustar jator2emc SUBROUTINE CPYUPD(LUNIT,LIN,LUN,IBYT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CPYUPD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A SUBSET FROM ONE MESSAGE BUFFER C (ARRAY MBAY IN MODULE BITBUF) TO ANOTHER AND/OR RESETS THE C POINTERS. IF THE SUBSET WILL NOT FIT INTO THE OUTPUT MESSAGE, OR C IF THE SUBSET BYTE COUNT EXCEEDS 65530 (SUFFICIENTLY CLOSE TO THE C 16-BIT BYTE COUNTER UPPER LIMIT OF 65535), THEN THAT MESSAGE IS C FLUSHED TO LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE C COPIED SUBSET. ANY SUBSET WITH BYTE COUNT > 65530 WILL BE WRITTEN C INTO ITS OWN ONE-SUBSET MESSAGE. IF THE SUBSET TO BE COPIED IS C LARGER THAN THE MAXIMUM MESSAGE LENGTH, THEN A CALL IS ISSUED TO C BUFR ARCHIVE LIBRARY SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES 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 2009-03-23 J. ATOR -- USE MSGFULL C 2014-10-27 J. WOOLLEN -- ACCOUNT FOR SUBSETS WITH BYTE COUNT > 65530 C (THESE MUST BE WRITTEN INTO THEIR OWN C ONE-SUBSET MESSAGE) C 2014-10-27 D. KEYSER -- FOR CASE ABOVE, DO NOT WRITE "CURRENT" C MESSAGE IF IT CONTAINS ZERO SUBSETS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- FIX MISSING DECLARATION OF COMMON /QUIET/ C C USAGE: CALL CPYUPD (LUNIT, LIN, LUN, IBYT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LIN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR INPUT MESSAGE LOCATION C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR OUTPUT MESSAGE LOCATION C IBYT - INTEGER: NUMBER OF BYTES OCCUPIED BY THIS SUBSET C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT IUPB MSGFULL C MSGINI MSGWRT MVB PKB C THIS ROUTINE IS CALLED BY: COPYSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 COMMON /QUIET / IPRT CHARACTER*128 BORT_STR, ERRSTR LOGICAL MSGFULL C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK WHETHER THE NEW SUBSET SHOULD BE WRITTEN INTO THE CURRENTLY C OPEN MESSAGE C ----------------------------------------------------------------- IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT) . .OR. . ((IBYT.GT.65530).AND.(NSUB(LUN).GT.0))) THEN c NO it should not, either because: c 1) it doesn't fit, c -- OR -- c 2) it has byte count > 65530 (sufficiently close to the c upper limit for the 16 bit byte counter placed at the c beginning of each subset), AND the current message has c at least one subset in it, c SO write the current message out and create a new one to c hold the current subset CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) CALL MSGINI(LUN) ENDIF IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) GOTO 900 C TRANSFER SUBSET FROM ONE MESSAGE TO THE OTHER C --------------------------------------------- C Note that we want to append the data for this subset to the end C of Section 4, but the value in MBYT(LUN) already includes the C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin C writing at the point 3 bytes prior to the byte currently pointed C to by MBYT(LUN). CALL MVB(MBAY(1,LIN),MBYT(LIN)+1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) C UPDATE THE SUBSET AND BYTE COUNTERS C -------------------------------------- MBYT(LUN) = MBYT(LUN) + IBYT NSUB(LUN) = NSUB(LUN) + 1 LBIT = (NBY0+NBY1+NBY2+4)*8 CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) LBYT = NBY0+NBY1+NBY2+NBY3 NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) LBIT = LBYT*8 CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) C IF THE SUBSET BYTE COUNT IS > 65530, THEN GIVE IT ITS OWN ONE-SUBSET C MESSAGE (CANNOT HAVE ANY OTHER SUBSETS IN THIS MESSAGE BECAUSE THEIR C BEGINNING WOULD BE BEYOND THE UPPER LIMIT OF 65535 IN THE 16-BIT C BYTE COUNTER, MEANING THEY COULD NOT BE LOCATED!) C -------------------------------------------------------------------- IF(IBYT.GT.65530) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I7,A,A)') . 'BUFRLIB: CPYUPD - SUBSET HAS BYTE COUNT = ',IBYT,' > UPPER ', . 'LIMIT OF 65535' CALL ERRWRT(ERRSTR) CALL ERRWRT('>>>>>>>WILL BE COPIED INTO ITS OWN MESSAGE<<<<<<<<') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) CALL MSGINI(LUN) ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: CPYUPD - THE LENGTH OF THIS SUBSET '// . 'EXCEEDS THE MAXIMUM MESSAGE LENGTH (",I6,")")') MAXBYT CALL BORT(BORT_STR) END ./crbmg.c0000644001370400056700000001053713440555365011227 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CRBMG C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS ROUTINE READS THE NEXT BUFR MESSAGE FROM THE SYSTEM C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA BUFR ARCHIVE LIBRARY C ROUTINE COBFL. ANY BUFR EDITION 0 OR EDITION 1 MESSAGES THAT ARE C READ ARE AUTOMATICALLY CONVERTED TO BUFR EDITION 2. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CRBMG( BMG, MXMB, NMB, IRET ) C INPUT ARGUMENT LIST: C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED C BY THE ROUTINE TO ENSURE THAT IT DOES NOT OVERFLOW C THE BMG ARRAY C C OUTPUT ARGUMENT LIST: C BMG - CHARACTER*1: ARRAY CONTAINING BUFR MESSAGE C NMB - INTEGER: SIZE (IN BYTES) OF BUFR MESSAGE IN BMG C IRET - INTEGER: RETURN CODE: C 0 = normal return C 1 = overflow of BMG array C 2 = "7777" indicator not found in expected location C -1 = end-of-file encountered while reading C -2 = I/O error encountered while reading C C REMARKS: C THIS ROUTINE CALLS: BORT GETS1LOC ICHKSTR IPKM C IUPBS01 IUPM RBYTES C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cobfl.h" void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) { f77int i1 = 1, i2 = 2, i3 = 3, i4 = 4, i24 = 24; f77int wkint[2]; f77int iben, isbyt, iwid; char errstr[129]; unsigned short i, nsecs; unsigned int lsec; /* ** Make sure that a file is open for reading. */ if ( pbf[0] == NULL ) { sprintf( errstr, "BUFRLIB: CRBMG - NO FILE IS OPEN FOR READING" ); bort( errstr, ( f77int ) strlen( errstr ) ); } /* ** Initialize the first 4 characters of the output array to blanks. */ if ( *mxmb < 4 ) { *iret = 1; return; } strncpy( bmg, " ", 4); /* ** Look for the start of the next BUFR message. */ while ( ichkstr( "BUFR", bmg, &i4, 4, 4 ) != 0 ) { memmove( bmg, &bmg[1], 3 ); if ( ( *iret = rbytes( bmg, mxmb, 3, 1 ) ) != 0 ) return; } /* ** Read the next 4 bytes and determine the BUFR edition number that was used ** to encode the message. */ if ( ( *iret = rbytes( bmg, mxmb, 4, 4 ) ) != 0 ) return; memcpy( wkint, bmg, 8 ); iben = iupbs01( wkint, "BEN", 3 ); if ( iben >= 2 ) { /* ** Get the length of the BUFR message. */ *nmb = iupbs01( wkint, "LENM", 4 ); /* ** Read the remainder of the BUFR message. */ if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; } else { /* ** Read the remainder of the BUFR message and then convert it to BUFR ** edition 2. The message length isn't encoded in Section 0, so we need ** to compute it by unpacking and summing the lengths of the individual ** sections. */ lsec = 4; /* length of Section 0 */ /* ** Get the length of Section 1 and add it to the total. */ gets1loc( "LEN1", &iben, &isbyt, &iwid, &wkint[0], 4 ); *nmb = lsec + iupm( &bmg[lsec+isbyt-1], &iwid, 3 ); /* ** Read up through the end of Section 1. */ if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; /* ** Is there a Section 2? */ gets1loc( "ISC2", &iben, &isbyt, &iwid, &wkint[0], 4 ); nsecs = iupm( &bmg[lsec+isbyt-1], &iwid, 1 ) + 2; /* ** Read up through the end of Section 4. */ for ( i = 1; i <= nsecs; i++ ) { if ( ( *iret = rbytes( bmg, mxmb, *nmb, 3 ) ) != 0 ) return; lsec = iupm( &bmg[*nmb], &i24, 3 ); if ( ( *iret = rbytes( bmg, mxmb, *nmb+3, lsec-3 ) ) != 0 ) return; *nmb += lsec; } /* ** Read Section 5. */ if ( ( *iret = rbytes( bmg, mxmb, *nmb, 4 ) ) != 0 ) return; *nmb += 4; /* ** Expand Section 0 from 4 bytes to 8 bytes, then encode the message length ** and new edition number (i.e. 2) into the new (expanded) Section 0. */ if ( *nmb + 4 > *mxmb ) { *iret = 1; return; } memmove( &bmg[8], &bmg[4], *nmb-4 ); *nmb += 4; ipkm( &bmg[4], &i3, nmb, 3 ); ipkm( &bmg[7], &i1, &i2, 1 ); } /* ** Check that the "7777" is in the expected location. */ *iret = ( ( ichkstr( "7777", &bmg[*nmb-4], &i4, 4, 4 ) == 0 ) ? 0 : 2 ); return; } ./cread.c0000644001370400056700000000763413440555365011217 0ustar jator2emc/*C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CREAD C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 C C ABSTRACT: CREAD IS A PACKAGE OF C LANGUAGE I/O ROUTINES WHICH C ARE DESIGNED TO OPERATE BUFRLIB INPUT AND OUTPUT C FUNCTIONS IN A LESS RESTRICTIVE WAY COMPARED TO C THOSE AVAILABLE IN STANDARD FORTRAN IMPLEMENTATIONS. C THE PACKAGE CONSISTS OF THREE FILE OPEN ROUTINES, C ONE FILE CLOSE ROUTINE, TWO FILE POSITIONING C ROUTINES, ONE READ BUFR AND ONE WRITE BUFR ROUTINE. C ARRAYS OF FILE CONNECTION DESCRIPTORS AND FILE C POSITION POINTERS PROVIDE THE CONNECTION TO THE C BUFRLIB INTERNAL FILE STATUS INDICATORS. THE C BUFRLIB FILE CONNECTION INDEX LUN, OBTAINED BY C CALLS TO STATUS, IS USED TO REFERENCE THE CREAD C DESCRIPTOR AND POINTER ARRAYS. C C PROGRAM HISTORY LOG: C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR C 2014-11-07 J. ATOR -- ALLOW DYNAMIC ALLOCATION OF CERTAIN ARRAYS C C USAGE: CALL openrb(nfile,ufile) - open ufile for binary reading C CALL openwb(nfile,ufile) - open ufile for binary writing C CALL openab(nfile,ufile) - open ufile for binary appending C CALL backbufr(nfile) - backspace file nfile 1 message C CALL cewind(nfile) - rewind file nfile to beginning C CALL closfb(nfile) - disconnect file nfile from c C CALL crdbufr(nfile,bufr,maxbyt) - read next bufr message from file nfile into bufr C CALL cwrbufr(nfile,bufr,nwrd) - write bufr message from bufr into file nfile C C INPUT ARGUMENTS: c nfile - integer bufrlib file connection index C ufile - full file path/filename c bufr - in crdbufr: char array to read a bufr message into c maxbyt - in crdbufr: maximum number of bytes allowed to read c bufr - in cwrbufr: integer array to write a bufr message from c nwrd - in cwrbufr: number of words to write for bufr message C C OUTPUT ARGUMENTS: c crdbufr - return code from reading c -3 - sec0 message length > maxbyt c -2 - error reading bufr message c -1 - no more more messages in file c 0 - read a bufr message C C REMARKS: C THIS ROUTINE CALLS: IUPBS01 C C THIS ROUTINE IS CALLED BY: C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cread.h" void openrb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "rb " ); } void openwb (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "wb " ); } void openab (nfile,ufile) f77int *nfile; char *ufile; { pb[*nfile] = fopen( ufile , "a+b" ); } void backbufr (nfile ) f77int *nfile; { fsetpos(pb[*nfile],&lstpos[*nfile]);} void cewind (nfile ) f77int *nfile; { rewind(pb[*nfile]); } void closfb (nfile ) f77int *nfile; { fclose(pb[*nfile]); } f77int crdbufr (nfile,bufr,mxbyt) f77int *nfile; f77int *mxbyt; char *bufr; { f77int nbyt; f77int nb; f77int wkint[2]; fpos_t nxtpos; fgetpos(pb[*nfile],&lstpos[*nfile]); nb = sizeof(*bufr); bufr[0]=bufr[1]; while ( strncmp(bufr,"BUFR",4)!=0) { memmove(bufr,&bufr[1],3); if(fread(bufr+3,nb,1,pb[*nfile])!=1) return -1; } fgetpos(pb[*nfile],&nxtpos); if(fread(bufr+4,nb,4,pb[*nfile])!=4) return -1; memcpy(wkint,bufr,8); nbyt=iupbs01(wkint,"LENM",4)-8; if(nbyt+8>*mxbyt) {fsetpos(pb[*nfile],&nxtpos);return -3;}; if(fread(bufr+8,nb,nbyt,pb[*nfile])!=nbyt) {fsetpos(pb[*nfile],&nxtpos);return -2;}; if(strncmp(bufr+nbyt+4,"7777",4)!=0) {fsetpos(pb[*nfile],&nxtpos);return -2;}; return 0; } void cwrbufr (nfile,bufr,nwrd) f77int *nfile; f77int *nwrd; f77int *bufr; { f77int nb; nb = sizeof(*bufr); fwrite(bufr,nb,*nwrd,pb[*nfile]); } ./cread.h0000644001370400056700000000115113440555365011210 0ustar jator2emc/* ** The arrays in this header are dimensioned one larger than NFILES because ** of the difference in array indexing between Fortran and C. In each of the ** CREAD functions, the value passed in for nfile will be a Fortran index ** ranging from 1 to NFILES, so we need to allow for this same range of ** values in C, which would otherwise expect the array indices to range ** from 0 to NFILES-1. */ #ifdef DYNAMIC_ALLOCATION # ifdef IN_ARALLOCC FILE **pb; fpos_t *lstpos; # else extern FILE **pb; extern fpos_t *lstpos; # endif #else FILE *pb[NFILES+1]; fpos_t lstpos[NFILES+1]; #endif ./cwbmg.c0000644001370400056700000000266413440555365011236 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: CWBMG C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS ROUTINE WRITES A SPECIFIED NUMBER OF BYTES TO THE C SYSTEM FILE MOST RECENTLY OPENED FOR WRITING/OUTPUT VIA BUFR C ARCHIVE LIBRARY ROUTINE COBFL. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL CWBMG( BMG, NMB, IRET ) C INPUT ARGUMENT LIST: C BMG - CHARACTER*1: ARRAY CONTAINING BYTES TO BE WRITTEN C NMB - INTEGER: NUMBER OF BYTES WITHIN BMG TO BE WRITTEN C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = I/O error occurred while writing C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cobfl.h" void cwbmg( char *bmg, f77int *nmb, f77int *iret ) { char errstr[129]; /* ** Make sure that a file is open for writing. */ if ( pbf[1] == NULL ) { sprintf( errstr, "BUFRLIB: CWBMG - NO FILE IS OPEN FOR WRITING" ); bort( errstr, ( f77int ) strlen( errstr ) ); } /* ** Write the BUFR message to the file. */ *iret = ( ( fwrite( bmg, 1, *nmb, pbf[1] ) == *nmb ) ? 0 : -1 ); return; } ./datebf.f0000644001370400056700000001343413440555365011364 0ustar jator2emc SUBROUTINE DATEBF(LUNIT,MEAR,MMON,MDAY,MOUR,IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DATEBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST C NON-DICTIONARY BUFR MESSAGE IN LOGICAL UNIT LUNIT, REGARDLESS OF C THE NUMBER OF SUBSETS IN THE MESSAGE. LUNIT SHOULD NOT BE C PREVIOUSLY OPENED TO THE BUFR INTERFACE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT C 1998-08-31 J. WOOLLEN -- MODIFIED TO CORRECT AN ERROR WHICH LEAD TO C THE YEAR BEING RETURNED IN "MEAR" AS 2- C DIGIT YEAR WHEN A 4-DIGIT YEAR WAS C REQUESTED VIA A PRIOR CALL TO DATELEN (THE C CENTER DATE RETURNED IN "IDATE", IN THE C FORM YYYYMMDDHH, WAS CORRECT IN THE C PREVIOUS VERSION OF THIS ROUTINE C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRCT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC C FUNCTION ICHAR WITH THE NCEP W3LIB C- C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER C USE FLOATING POINT ARITHMETIC SINCE THIS C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER C RESULTING DATE ON SOME MACHINES (E.G., NCEP C IBM FROST/SNOW), INCREASES PORTABILITY; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY C TO EBCDIC MACHINES C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE C INFORMATION (IN CASE IT HAS NOT YET BEEN C CALLED), THIS ROUTINE DOES NOT REQUIRE IT C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES C THAT DO REQUIRE IT C 2005-11-29 J. ATOR -- USE IGETDATE, IUPBS01 AND RDMSGW C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE C THE C FILE WITHOUT CLOSING THE FORTRAN FILE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL DATEBF (LUNIT, MEAR, MMON, MDAY, MOUR, IDATE) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C MEAR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON C DATELEN() VALUE C MMON - INTEGER: SECTION 1 MONTH MM C MDAY - INTEGER: SECTION 1 DAY DD C MOUR - INTEGER: SECTION 1 HOUR HH C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE IN C FORMAT OF EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON C DATELEN() VALUE; OR -1 IF SECTION 1 DATE COULD NOT BE C LOCATED C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE C RDMSGW STATUS WRDLEN C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) C --------------------------------------------------------------- CALL WRDLEN IDATE = -1 C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) C ----------------------------------------------------------- CALL STATUS(LUNIT,LUN,JL,JM) IF(JL.NE.0) GOTO 900 CALL OPENBF(LUNIT,'INX',LUNIT) C READ TO A DATA MESSAGE AND PICK OUT THE DATE C -------------------------------------------- 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.LT.0) GOTO 100 IF(IDXMSG(MGWA).EQ.1) GOTO 1 IDATE = IGETDATE(MGWA,MEAR,MMON,MDAY,MOUR) 100 IF(IPRT.GE.1 .AND. IDATE.EQ.-1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: DATEBF - SECTION 1 DATE COULD NOT BE '// . 'LOCATED - RETURN WITH IDATE = -1' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- CALL CLOSBF(LUNIT) RETURN 900 CALL BORT . ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') END ./datelen.f0000644001370400056700000000510213440555365011544 0ustar jator2emc SUBROUTINE DATELEN(LEN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DATELEN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE LENGTH OF DATE-TIME C VALUES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR C ARCHIVE LIBRARY SUBROUTINES WHICH READ BUFR MESSAGES (E.G. READMG, C READERME, ETC.). POSSIBLE VALUES ARE "8" (WHICH IS THE DEFAULT) C AND "10". C C PROGRAM HISTORY LOG: C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN READMG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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 C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE C INFORMATION (IN CASE IT HAS NOT YET BEEN C CALLED), THIS ROUTINE DOES NOT REQUIRE IT C BUT IT MAY SOMEDAY CALL OTHER ROUTINES THAT C DO REQUIRE IT C C USAGE: CALL DATELEN (LEN) C INPUT ARGUMENT LIST: C LEN - INTEGER: LENGTH OF DATE-TIME VALUES TO BE OUTPUT BY C READ SUBROUTINES: * C 8 = YYMMDDHH (2-digit year) C 10 = YYYYMMDDHH (4-digit year) C C REMARKS: C THIS ROUTINE CALLS: BORT WRDLEN C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /DATELN/ LENDAT CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) C --------------------------------------------------------------- CALL WRDLEN IF(LEN.NE.8 .AND. LEN.NE.10) GOTO 900 LENDAT = LEN C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: DATELEN - INPUT ARGUMENT IS",I4," - '// . 'IT MUST BE EITHER 8 OR 10")') LEN CALL BORT(BORT_STR) END ./digit.f0000644001370400056700000000271113440555365011233 0ustar jator2emc LOGICAL FUNCTION DIGIT(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DIGIT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS LOGICAL FUNCTION TESTS THE CHARACTERS IN A STRING TO C DETERMINE IF THEY ARE ALL DIGITS ('0','1','2','3','4','5','6','7', C '8' OR '9'). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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) C 2007-01-19 J. ATOR -- SIMPLIFIED LOGIC C 2009-03-23 J. ATOR -- FIXED MINOR BUG CAUSED BY TYPO C C USAGE: DIGIT (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING C C OUTPUT ARGUMENT LIST: C DIGIT - LOGICAL: TRUE IF ALL CHARACTERS IN STR ARE DIGITS C ('0' - '9'), OTHERWISE FALSE C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CKTABA NUMBCK STNTBIA C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR DIGIT = .FALSE. DO I=1,LEN(STR) IF( LLT(STR(I:I),'0') .OR. LGT(STR(I:I),'9') ) GOTO 100 ENDDO DIGIT = .TRUE. C EXIT C ---- 100 RETURN END ./dlloctbf.c0000644001370400056700000000160413440555365011721 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DLLOCTBF C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-03 C C ABSTRACT: THIS ROUTINE FREES THE SPACE THAT WAS PREVIOUSLY ALLOCATED C BY SUBPROGRAM INITTBF FOR STORING CODE/FLAG TABLE INFORMATION INTO C AN INTERNAL MEMORY STRUCTURE. THE STRUCTURE POINTER IS THEN RESET, C WHICH ALLOWS FOR A POTENTIAL RE-ALLOCATION OF MEMORY IN THE FUTURE. C C PROGRAM HISTORY LOG: C 2017-11-03 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL DLLOCTBF C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: EXITBUFR C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" void dlloctbf( void ) { free ( cfe ); cfe = NULL; } ./drfini.f0000644001370400056700000000731313440555365011411 0ustar jator2emc SUBROUTINE DRFINI(LUNIT,MDRF,NDRF,DRFTAG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DRFINI C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE INITIALIZES DELAYED REPLICATION FACTORS C AND EXPLICITLY ALLOCATES A CORRESPONDING AMOUNT OF SPACE IN THE C INTERNAL SUBSET ARRAYS, THEREBY ALLOWING THE SUBSEQUENT USE OF BUFR C ARCHIVE LIBRARY SUBROUTINE UFBSEQ TO WRITE DATA DIRECTLY INTO C DELAYED REPLICATION SEQUENCES. NOTE THAT THIS SAME TYPE OF C INITIALIZATION IS DONE IMPLICTLY WITHIN BUFR ARCHIVE LIBRARY C SUBROUTINE UFBINT FOR DELAYED REPLICATION SEQUENCES WHICH APPEAR C ONLY ONE TIME WITHIN AN OVERALL SUBSET DEFINITION. HOWEVER, BY C USING SUBROUTINE DRFINI ALONG WITH A SUBSEQUENT CALL TO SUBROUTINE C UFBSEQ, IT IS ACTUALLY POSSIBLE TO HAVE MULTIPLE OCCURRENCES OF A C PARTICULAR DELAYED REPLICATION SEQUENCE WITHIN A SINGLE OVERALL C SUBSET DEFINITION. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2005-03-04 J. ATOR -- UPDATED DOCUMENTATION C 2014-09-08 J. ATOR -- INCREASE NDRF LIMIT FROM 100 TO 200 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2018-06-07 J. ATOR -- INCREASE NDRF LIMIT FROM 200 TO 2000 C C USAGE: CALL DRFINI (LUNIT, MDRF, NDRF, DRFTAG) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C MDRF - INTEGER: ARRAY OF DELAYED REPLICATION FACTORS, C IN ONE-TO-ONE CORRESPONDENCE WITH THE NUMBER OF C OCCURRENCES OF DRFTAG WITHIN THE OVERALL SUBSET C DEFINITION, AND EXPLICITLY DEFINING HOW MUCH SPACE C (I.E. HOW MANY REPLICATIONS) TO ALLOCATE WITHIN C EACH SUCCESSIVE OCCURRENCE C NDRF - INTEGER: NUMBER OF DELAYED REPLICATION FACTORS C WITHIN MDRF C DRFTAG - CHARACTER*(*): SEQUENCE MNEMONIC, BRACKETED BY C APPROPRIATE DELAYED REPLICATION NOTATION C (E.G. {}, () OR <>) C C REMARKS: C THIS ROUTINE CALLS: BORT STATUS USRTPL C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) DRFTAG CHARACTER*128 BORT_STR DIMENSION MDRF(NDRF) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(NDRF.GT.2000) GOTO 900 CALL STATUS(LUNIT,LUN,IL,IM) C COMFORM THE TEMPLATES TO THE DELAYED REPLICATION FACTORS C -------------------------------------------------------- M = 0 N = 0 10 DO N=N+1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1 .AND. TAG(NODE).EQ.DRFTAG) THEN M = M+1 CALL USRTPL(LUN,N,MDRF(M)) GOTO 10 ENDIF ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: DRFINI - THE NUMBER OF DELAYED '// . 'REPLICATION FACTORS (",I5,") EXCEEDS THE LIMIT (2000)")') NDRF CALL BORT(BORT_STR) END ./drstpl.f0000644001370400056700000000710213440555365011442 0ustar jator2emc SUBROUTINE DRSTPL(INOD,LUN,INV1,INV2,INVN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DRSTPL C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE IS CALLED BY BUFR ARCHIVE LIBRARY SUBROUTINE C UFBRW WHENEVER IT CAN'T FIND A MNEMONIC IT WANTS TO WRITE WITHIN THE C CURRENT SUBSET BUFFER. IT LOOKS FOR THE MNEMONIC WITHIN ANY C UNEXPANDED "DRS" (STACK) OR "DRB" (1-BIT DELAYED REPLICATION) C SEQUENCES INSIDE OF THE PORTION OF THE SUBSET BUFFER BOUNDED BY THE C INDICES INV1 AND INV2. IF FOUND, IT EXPANDS THE APPLICABLE "DRS" OR C "DRB" SEQUENCE TO THE POINT WHERE THE MNEMONIC IN QUESTION NOW C APPEARS IN THE SUBSET BUFFER, AND IN DOING SO IT WILL ALSO RETURN C A NEW VALUE FOR INV2. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" (LATER REMOVED, UNKNOWN C WHEN) C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL DRSTPL (INOD, LUN, INV1, INV2, INVN) C C INPUT ARGUMENT LIST: C INOD - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET C BUFFER CURRENTLY BEING PROCESSED BY UFBRW C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET C BUFFER CURRENTLY BEING PROCESSED BY UFBRW C C OUTPUT ARGUMENT LIST: C INVN - INTEGER: LOCATION INDEX OF INOD WITHIN SUBSET BUFFER: C 0 = NOT FOUND C INV2 - INTEGER: IF INVN = 0, THEN INV2 IS UNCHANGED FROM ITS C INPUT VALUE. OTHERWISE, IT CONTAINS THE REDEFINED C ENDING INDEX OF THE PORTION OF THE SUBSET BUFFER C CURRENTLY BEING PROCESSED BY UFBRW, SINCE EXPANDING A C DELAYED REPLICATION SEQUENCE WILL HAVE NECESSARILY C INCREASED THE SIZE OF THIS BUFFER. C C REMARKS: C THIS ROUTINE CALLS: INVWIN NEWWIN USRTPL C THIS ROUTINE IS CALLED BY: UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- 1 NODE = INOD 2 NODE = JMPB(NODE) IF(NODE.EQ.0) GOTO 100 IF(TYP(NODE).EQ.'DRS' .OR. TYP(NODE).EQ.'DRB') THEN INVN = INVWIN(NODE,LUN,INV1,INV2) IF(INVN.GT.0) THEN CALL USRTPL(LUN,INVN,1) CALL NEWWIN(LUN,INV1,INV2) INVN = INVWIN(INOD,LUN,INVN,INV2) IF(INVN.GT.0) GOTO 100 GOTO 1 ENDIF ENDIF GOTO 2 C EXIT C ---- 100 RETURN END ./dumpbf.f0000644001370400056700000001547313440555365011421 0ustar jator2emc SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DUMPBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-12-11 C C ABSTRACT: THIS SUBROUTINE RETURNS THE SECTION 1 DATE IN THE FIRST C TWO NON-DICTIONARY BUFR MESSAGES IN LOGICAL UNIT LUNIT WHICH C CONTAIN ZERO SUBSETS. NORMALLY, THESE "DUMMY" MESSAGES APPEAR C ONLY IN DATA DUMP FILES AND ARE IMMEDIATELY AFTER THE DICTIONARY C MESSAGES. THEY CONTAIN A DUMP "CENTER TIME" AND A DUMP FILE C "PROCESSING TIME", RESPECTIVELY. LUNIT SHOULD NOT BE PREVIOUSLY C OPENED TO THE BUFR INTERFACE. C C PROGRAM HISTORY LOG: C 1996-12-11 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-12-17 J. WOOLLEN -- CORRECTED ERROR IN DUMP DATE READER C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT C 2003-05-19 M. SHIREY -- REPLACED CALLS TO FORTRAN INSRINSIC C FUNCTION ICHAR WITH THE NCEP W3LIB C- C FUNCTION MOVA2I BECAUSE ICHAR DOES NOT WORK C PROPERLY ON SOME MACHINES (E.G., IBM FROST/ C SNOW) (NOTE: ON 2003-??-??, MOVA2I WAS C ADDED TO THE BUFRLIB AS A FORTRAN FUNCTION) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER C USE FLOATING POINT ARITHMETIC SINCE THIS C CAN LEAD TO ROUND OFF ERROR AND AN IMPROPER C RESULTING DATE ON SOME MACHINES (E.G., NCEP C IBM FROST/SNOW), INCREASES PORTABILITY; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY C TO EBCDIC MACHINES C 2004-12-20 D. KEYSER -- CALLS WRDLEN TO INITIALIZE LOCAL MACHINE C INFORMATION (IN CASE IT HAS NOT YET BEEN C CALLED), THIS ROUTINE DOES NOT REQUIRE IT C BUT 2004-08-18 CHANGE CALLS OTHER ROUTINES C THAT DO REQUIRE IT C 2005-11-29 J. ATOR -- USE IUPBS01, IGETDATE, GETLENS AND RDMSGW C 2009-03-23 J. ATOR -- USE IDXMSG, IUPBS3 AND ERRWRT C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE C THE C FILE WITHOUT CLOSING THE FORTRAN FILE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL DUMPBF (LUNIT, JDATE, JDUMP) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C JDATE - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE C FIRST NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS C (NORMALLY THE DATA DUMP CENTER TIME IN A DATA DUMP C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED C JDUMP - INTEGER: 5-WORD ARRAY CONTAINING THE YEAR C (YYYY OR YY, DEPENDING ON DATELEN() VALUE), C MONTH, DAY, HOUR AND MINUTE FROM SECTION 1 OF THE C SECOND NON-DICTIONARY BUFR MESSAGE WITH ZERO SUBSETS C (NORMALLY THE FILE PROCESSING TIME IN A DATA DUMP C FILE); OR 5*-1 IF THIS COULD NOT BE LOCATED C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT IDXMSG IGETDATE C IUPBS01 IUPBS3 RDMSGW STATUS C WRDLEN C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT DIMENSION JDATE(5),JDUMP(5) CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CALL SUBROUTINE WRDLEN TO INITIALIZE SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE (IN CASE IT HAS NOT YET BEEN CALLED) C --------------------------------------------------------------- CALL WRDLEN DO I=1,5 JDATE(I) = -1 JDUMP(I) = -1 ENDDO C SEE IF THE FILE IS ALREADY OPEN TO BUFR INTERFACE (A NO-NO) C ----------------------------------------------------------- CALL STATUS(LUNIT,LUN,JL,JM) IF(JL.NE.0) GOTO 900 call openbf(lunit,'INX',lunit) C READ PAST ANY DICTIONARY MESSAGES C --------------------------------- 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.LT.0) GOTO 200 IF(IDXMSG(MGWA).EQ.1) GOTO 1 C DUMP CENTER YY,MM,DD,HH,MM IS IN THE FIRST EMPTY MESSAGE C -------------------------------------------------------- C i.e. the first message containing zero subsets IF(IUPBS3(MGWA,'NSUB').NE.0) GOTO 200 IGD = IGETDATE(MGWA,JDATE(1),JDATE(2),JDATE(3),JDATE(4)) JDATE(5) = IUPBS01(MGWA,'MINU') C DUMP CLOCK YY,MM,DD,HH,MM IS IN THE SECOND EMPTY MESSAGE C -------------------------------------------------------- C i.e. the second message containing zero subsets CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.LT.0) GOTO 200 IF(IUPBS3(MGWA,'NSUB').NE.0) GOTO 200 IGD = IGETDATE(MGWA,JDUMP(1),JDUMP(2),JDUMP(3),JDUMP(4)) JDUMP(5) = IUPBS01(MGWA,'MINU') call closbf(lunit) GOTO 100 200 IF(IPRT.GE.1 .AND. (JDATE(1).EQ.-1.OR.JDUMP(1).EQ.-1)) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') IF(JDATE(1).EQ.-1) THEN ERRSTR = 'BUFRLIB: DUMPBF - FIRST EMPTY BUFR MESSAGE '// . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// . 'JDATE = 4*-1' CALL ERRWRT(ERRSTR) ENDIF IF(JDUMP(1).EQ.-1) THEN ERRSTR = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE '// . 'SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH '// . 'JDUMP = 4*-1' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT . ('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') END ./dxdump.f0000644001370400056700000002352513440555365011442 0ustar jator2emc SUBROUTINE DXDUMP(LUNIT,LDXOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DXDUMP C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: THIS SUBROUTINE WRITES, TO LOGICAL UNIT LDXOT, AN ASCII C COPY OF THE BUFR DICTIONARY TABLE INFORMATION ASSOCIATED WITH C THE BUFR FILE DEFINED BY LOGICAL UNIT LUNIT. IT IS ESPECIALLY C USEFUL FOR DETERMINING THE CONTENTS OF ARCHIVE BUFR FILES WHICH C MAY HAVE SUCH INFORMATION EMBEDDED AS DX MESSAGES AT THE FRONT C OF THE FILE. THE OUTPUT FILE WILL BE IN A FORMAT SUITABLE FOR C SUBSEQUENT INPUT AS A USER-DEFINED DICTIONARY TABLES FILE TO C BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND IN THAT SENSE THIS C SUBROUTINE CAN BE VIEWED AS THE LOGICAL INVERSE OF BUFR ARCHIVE C LIBRARY SUBROUTINE RDUSDX. NOTE THAT THE BUFR FILE ASSOCIATED C WITH LOGICAL UNIT LUNIT MUST HAVE ALREADY BEEN IDENTIFIED TO C THE BUFR ARCHIVE LIBRARY SOFTWARE VIA A PRIOR CALL TO OPENBF. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C 2007-01-19 J. ATOR -- CORRECTED OUTPUT FOR REFERENCE VALUES C LONGER THAN 8 DIGITS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL DXDUMP (LUNIT, LDXOT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LDXOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT FILE C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE WITH EMBEDDED DX DICTIONARY MESSAGES C C OUTPUT FILES: C UNIT "LDXOT" - ASCII VERSION OF DX DICTIONARY INFORMATION, IN C FORMAT SUITABLE FOR SUBSEQUENT INPUT TO OPENBF C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTBD STATUS STRSUC C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD USE MODA_NMIKRP INCLUDE 'bufrlib.prm' COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) CHARACTER*80 CARD,CARDI1,CARDI2,CARDI3,CARDI4 CHARACTER*20 CMSTR CHARACTER*10 WRK3 CHARACTER*8 WRK1,WRK2 CHARACTER*6 ADN CHARACTER*3 TYPS CHARACTER*1 REPS LOGICAL TBSKIP, TDSKIP, XTRCI1 DATA CARDI1( 1:40) . /'| | | '/ DATA CARDI1(41:80) . /' |'/ DATA CARDI2( 1:40) . /'| | '/ DATA CARDI2(41:80) . /' |'/ DATA CARDI3( 1:40) . /'| | | | | '/ DATA CARDI3(41:80) . /' |-------------|'/ DATA CARDI4( 1:40) . /'|---------------------------------------'/ DATA CARDI4(41:80) . /'---------------------------------------|'/ C----------------------------------------------------------------------- TBSKIP(ADN) = ((ADN.EQ.'063000').OR.(ADN.EQ.'063255').OR. . (ADN.EQ.'031000').OR.(ADN.EQ.'031001').OR. . (ADN.EQ.'031002')) TDSKIP(ADN) = ((ADN.EQ.'360001').OR.(ADN.EQ.'360002').OR. . (ADN.EQ.'360003').OR.(ADN.EQ.'360004')) C----------------------------------------------------------------------- C DETERMINE LUN FROM LUNIT. CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE C DESCRIPTOR DEFINITION SECTION. CARD=CARDI4 CARD( 1: 1)='.' CARD(80:80)='.' WRITE (LDXOT,'(A)') CARD CARD=CARDI4 CARD( 2: 2)=' ' CARD(79:79)=' ' CARD(15:64)=' USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D ' WRITE (LDXOT,'(A)') CARD WRITE (LDXOT,'(A)') CARDI4 CARD=CARDI1 CARD( 3:10)='MNEMONIC' CARD(14:19)='NUMBER' CARD(23:33)='DESCRIPTION' WRITE (LDXOT,'(A)') CARD CARD=CARDI4 CARD(12:12)='|' CARD(21:21)='|' WRITE (LDXOT,'(A)') CARD C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR C DEFINITION CARDS. WRITE (LDXOT,'(A)') CARDI1 XTRCI1=.FALSE. DO N=1,NTBD(LUN) IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN CARD=CARDI1 CARD( 3:10)=TABD(N,LUN)( 7:14) CARD(14:19)=TABD(N,LUN)( 1: 6) CARD(23:77)=TABD(N,LUN)(16:70) C CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC. C IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE C LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA C CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE C THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS. DO NA=1,NTBA(LUN) IF(TABA(NA,LUN)(4:11).EQ.TABD(N,LUN)(7:14)) THEN CARD(14:14)='A' IF(NA.EQ.NTBA(LUN)) XTRCI1=.TRUE. GOTO 10 END IF END DO 10 WRITE (LDXOT,'(A)') CARD IF(XTRCI1) THEN WRITE (LDXOT,'(A)') CARDI1 XTRCI1=.FALSE. END IF END IF END DO C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR C DEFINITION CARDS. WRITE (LDXOT,'(A)') CARDI1 DO N=1,NTBB(LUN) IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN CARD=CARDI1 CARD( 3:10)=TABB(N,LUN)( 7:14) CARD(14:19)=TABB(N,LUN)( 1: 6) CARD(23:77)=TABB(N,LUN)(16:70) WRITE (LDXOT,'(A)') CARD END IF END DO WRITE (LDXOT,'(A)') CARDI1 C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE C SEQUENCE DEFINITION SECTION. WRITE (LDXOT,'(A)') CARDI4 CARD=CARDI2 CARD( 3:10)='MNEMONIC' CARD(14:21)='SEQUENCE' WRITE (LDXOT,'(A)') CARD CARD=CARDI4 CARD(12:12)='|' WRITE (LDXOT,'(A)') CARD C CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE C DEFINITION CARDS. WRITE (LDXOT,'(A)') CARDI2 DO N=1,NTBD(LUN) IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN CARD=CARDI2 CARD( 3:10)=TABD(N,LUN)( 7:14) IC = 14 C GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR, C AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO C THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR. CALL NEMTBD(LUN,N,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) IF(NSEQ.GT.0) THEN DO NC=1,NSEQ CMSTR=' ' ICMS=0 CALL STRSUC(NEM(NC,1),WRK2,NCH) IF(IRP(NC,1).NE.0) THEN C ADD THE OPENING REPLICATION TAG. ICMS=ICMS+1 CMSTR(ICMS:ICMS)=REPS(IRP(NC,1),1) END IF CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) ICMS=ICMS+NCH IF(IRP(NC,1).NE.0) THEN C ADD THE CLOSING REPLICATION TAG. ICMS=ICMS+1 CMSTR(ICMS:ICMS)=REPS(IRP(NC,1),2) END IF IF(KRP(NC,1).NE.0) THEN C ADD THE FIXED REPLICATION COUNT. WRK1=' ' WRITE (WRK1,'(I3)') KRP(NC,1) CALL STRSUC(WRK1,WRK2,NCH) CMSTR(ICMS+1:ICMS+NCH)=WRK2(1:NCH) ICMS=ICMS+NCH END IF C WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT C INTO THE CURRENT SEQUENCE DEFINITION CARD? IF NOT, THEN C WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A C NEW ONE TO HOLD THIS CHILD. IF(IC.GT.(79-ICMS)) THEN WRITE (LDXOT,'(A)') CARD CARD=CARDI2 CARD( 3:10)=TABD(N,LUN)( 7:14) IC = 14 END IF CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS) C NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH C CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE C READABILITY). IC=IC+ICMS+2 END DO WRITE (LDXOT,'(A)') CARD WRITE (LDXOT,'(A)') CARDI2 END IF END IF END DO C CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE C ELEMENT DEFINITION SECTION. WRITE (LDXOT,'(A)') CARDI4 CARD=CARDI3 CARD( 3:10)='MNEMONIC' CARD(14:17)='SCAL' CARD(21:29)='REFERENCE' CARD(35:37)='BIT' CARD(41:45)='UNITS' WRITE (LDXOT,'(A)') CARD CARD=CARDI4 CARD(12:12)='|' CARD(19:19)='|' CARD(33:33)='|' CARD(39:39)='|' CARD(66:66)='|' WRITE (LDXOT,'(A)') CARD C CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT C DEFINITION CARDS. WRITE (LDXOT,'(A)') CARDI3 DO N=1,NTBB(LUN) IF(.NOT.TBSKIP(TABB(N,LUN)(1:6))) THEN CARD=CARDI3 CARD( 3:10)=TABB(N,LUN)( 7:14) CARD(41:64)=TABB(N,LUN)(71:94) C ADD THE SCALE FACTOR. CALL STRSUC(TABB(N,LUN)(96:98),WRK2,NCH) CARD(17-NCH+1:17)=WRK2 IF(TABB(N,LUN)(95:95).EQ.'-') CARD(17-NCH:17-NCH)='-' C ADD THE REFERENCE VALUE. CALL STRSUC(TABB(N,LUN)(100:109),WRK3,NCH) CARD(31-NCH+1:31)=WRK3 IF(TABB(N,LUN)(99:99).EQ.'-') CARD(31-NCH:31-NCH)='-' C ADD THE BIT WIDTH. CALL STRSUC(TABB(N,LUN)(110:112),WRK2,NCH) CARD(37-NCH+1:37)=WRK2 WRITE (LDXOT,'(A)') CARD END IF END DO WRITE (LDXOT,'(A)') CARDI3 C CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD. CARD=CARDI4 CARD( 1: 1)='`' CARD(80:80)='''' WRITE (LDXOT,'(A)') CARD RETURN 900 CALL BORT('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') END ./dxinit.f0000644001370400056700000001024713440555365011435 0ustar jator2emc SUBROUTINE DXINIT(LUN,IOI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DXINIT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE INITIALIZES THE INTERNAL ARRAYS C (IN MODULE TABABD) HOLDING THE DICTIONARY TABLE. IT THEN C INITIALIZES THE TABLE WITH APRIORI TABLE B AND D ENTRIES C (OPTIONAL). 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 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY) C 2009-03-23 J. ATOR -- REMOVE INITIALIZATION OF COMMON /MSGCWD/ C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL DXINIT (LUN, IOI) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IOI - INTEGER: SWITCH: C 0 = do not initialize the table with apriori C Table B and D entries C else = initialize the table with apriori Table B C and D entries C C REMARKS: C THIS ROUTINE CALLS: ADN30 IFXY PKTDD C THIS ROUTINE IS CALLED BY: CPBFDX OPENBF RDBFDX RDUSDX C READERME READS3 C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) CHARACTER*8 INIB(6,5),INID(5) CHARACTER*6 ADN30 CHARACTER*3 TYPS CHARACTER*1 REPS DATA INIB /'------','BYTCNT ','BYTES ','+0','+0','16', . '------','BITPAD ','NONE ','+0','+0','1 ', . '031000','DRF1BIT ','NUMERIC','+0','+0','1 ', . '031001','DRF8BIT ','NUMERIC','+0','+0','8 ', . '031002','DRF16BIT','NUMERIC','+0','+0','16'/ DATA NINIB /5/ DATA INID /' ', . 'DRP16BIT', . 'DRP8BIT ', . 'DRPSTAK ', . 'DRP1BIT '/ DATA NINID /5/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CLEAR OUT A TABLE PARTITION C --------------------------- NTBA(LUN) = 0 DO I=1,NTBA(0) TABA(I,LUN) = ' ' MTAB(I,LUN) = 0 ENDDO NTBB(LUN) = 0 DO I=1,NTBB(0) TABB(I,LUN) = ' ' ENDDO NTBD(LUN) = 0 DO I=1,NTBD(0) TABD(I,LUN) = ' ' c .... This zeroes the counter in TABD array, IRET returns as 0 and c is not tested CALL PKTDD(I,LUN,0,IRET) ENDDO IF(IOI.EQ.0) GOTO 100 C INITIALIZE TABLE WITH APRIORI TABLE B AND D ENTRIES C --------------------------------------------------- INIB(1,1) = ADN30(IBCT,6) INIB(1,2) = ADN30(IPD4,6) DO I=1,NINIB NTBB(LUN) = NTBB(LUN)+1 IDNB(I,LUN) = IFXY(INIB(1,I)) TABB(I,LUN)( 1: 6) = INIB(1,I) TABB(I,LUN)( 7: 70) = INIB(2,I) TABB(I,LUN)( 71: 94) = INIB(3,I) TABB(I,LUN)( 95: 98) = INIB(4,I) TABB(I,LUN)( 99:109) = INIB(5,I) TABB(I,LUN)(110:112) = INIB(6,I) ENDDO DO I=2,NINID N = NTBD(LUN)+1 IDND(N,LUN) = IDNR(I,1) TABD(N,LUN)(1: 6) = ADN30(IDNR(I,1),6) TABD(N,LUN)(7:70) = INID(I) c .... DK: what if IRET = -1 ??? CALL PKTDD(N,LUN,IDNR(1,1),IRET) c .... DK: what if IRET = -1 ??? CALL PKTDD(N,LUN,IDNR(I,2),IRET) NTBD(LUN) = N ENDDO C EXIT C ---- 100 RETURN END ./dxmini.f0000644001370400056700000001313013440555365011420 0ustar jator2emc SUBROUTINE DXMINI(LUN,MBAY,MBYT,MB4,MBA,MBB,MBD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: DXMINI C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE INITIALIZES A BUFR TABLE (DICTIONARY) C MESSAGE, WRITING ALL THE PRELIMINARY INFORMATION INTO SECTIONS 0, C 1, 3, 4. BUFR ARCHIVE LIBRARY SUBROUTINE WRDXTB WILL WRITE THE C ACTUAL TABLE INFORMATION INTO THE MESSAGE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION C WRITTEN IN SECTION 0 FROM 2 TO 3 C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 C C USAGE: CALL DXMINI (LUN, MBAY, MBYT, MB4, MBA, MBB, MBD) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C MBAY - INTEGER: (MXMSGLD4)-WORD PACKED BINARY ARRAY C CONTAINING BUFR MESSAGE C MBYT - INTEGER: LENGTH OF BUFR MESSAGE (BYTES) C MB4 - INTEGER: BYTE NUMBER IN MESSAGE OF FIRST BYTE IN C SECTION 4 C MBA - INTEGER: BYTE NUMBER IN MESSAGE OF FOURTH BYTE IN C SECTION 4 C MBB - INTEGER: BYTE NUMBER IN MESSAGE OF FIFTH BYTE IN C SECTION 4 C MBD - INTEGER: BYTE NUMBER IN MESSAGE OF SIXTH BYTE IN C SECTION 4 C C REMARKS: C ARGUMENT LUN IS NOT REFERENCED IN THIS SUBROUTINE. IT IS LEFT C HERE IN CASE AN APPLICATION PROGRAM CALLS THIS SUBROUTINE. C C THIS ROUTINE CALLS: BORT IUPM PKB PKC C THIS ROUTINE IS CALLED BY: WRDXTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MXMSGL INCLUDE 'bufrlib.prm' COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*128 BORT_STR CHARACTER*56 DXSTR DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- c .... The local message subtype is set to the version number of the c local tables (here = 1) MSBT = IDXV C INITIALIZE THE MESSAGE C ---------------------- MBIT = 0 DO I=1,MXMSGLD4 MBAY(I) = 0 ENDDO C For dictionary messages, the Section 1 date is simply zeroed out. C (Note that there is logic in function IDXMSG which relies on this!) IH = 0 ID = 0 IM = 0 IY = 0 c Dictionary messages get type 11 (see WMO Table A) MTYP = 11 NSUB = 1 IDXS = IDXV+1 LDXS = NXSTR(IDXS) NBY0 = 8 NBY1 = 18 NBY2 = 0 NBY3 = 7 + NXSTR(IDXS) + 1 NBY4 = 7 NBY5 = 4 MBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 IF(MOD(NBY3,2).NE.0) GOTO 900 C SECTION 0 C --------- CALL PKC('BUFR' , 4 , MBAY,MBIT) CALL PKB( MBYT , 24 , MBAY,MBIT) CALL PKB( 3 , 8 , MBAY,MBIT) C SECTION 1 C --------- CALL PKB( NBY1 , 24 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) CALL PKB( 3 , 8 , MBAY,MBIT) CALL PKB( 7 , 8 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) CALL PKB( MTYP , 8 , MBAY,MBIT) CALL PKB( MSBT , 8 , MBAY,MBIT) CALL PKB( 29 , 8 , MBAY,MBIT) CALL PKB( IDXV , 8 , MBAY,MBIT) CALL PKB( IY , 8 , MBAY,MBIT) CALL PKB( IM , 8 , MBAY,MBIT) CALL PKB( ID , 8 , MBAY,MBIT) CALL PKB( IH , 8 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) C SECTION 3 C --------- CALL PKB( NBY3 , 24 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) CALL PKB( 1 , 16 , MBAY,MBIT) CALL PKB( 2**7 , 8 , MBAY,MBIT) DO I=1,LDXS CALL PKB(IUPM(DXSTR(IDXS)(I:I),8),8,MBAY,MBIT) ENDDO CALL PKB( 0 , 8 , MBAY,MBIT) C SECTION 4 C --------- MB4 = MBIT/8+1 CALL PKB(NBY4 , 24 , MBAY,MBIT) CALL PKB( 0 , 8 , MBAY,MBIT) MBA = MBIT/8+1 CALL PKB( 0 , 8 , MBAY,MBIT) MBB = MBIT/8+1 CALL PKB( 0 , 8 , MBAY,MBIT) MBD = MBIT/8+1 CALL PKB( 0 , 8 , MBAY,MBIT) IF(MBIT/8+NBY5.NE.MBYT) GOTO 901 C EXITS C ----- RETURN 900 CALL BORT . ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') 901 WRITE(BORT_STR,'("BUFRLIB: DXMINI - NUMBER OF BYTES STORED FOR '// . 'A MESSAGE (",I6,") IS NOT THE SAME AS FIRST CALCULATED, MBYT '// . '(",I6)') MBIT/8+NBY5,MBYT CALL BORT(BORT_STR) END ./elemdx.f0000644001370400056700000001241713440555365011415 0ustar jator2emc SUBROUTINE ELEMDX(CARD,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ELEMDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE DECODES THE SCALE FACTOR, REFERENCE VALUE, C BIT WIDTH AND UNITS (I.E., THE "ELEMENTS") FROM A TABLE B MNEMONIC C DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A USER-SUPPLIED BUFR C DICTIONARY TABLE FILE IN CHARACTER FORMAT BY BUFR ARCHIVE LIBRARY C SUBROUTINE RDUSDX. THESE DECODED VALUES ARE THEN ADDED TO THE C ALREADY-EXISTING ENTRY FOR THAT MNEMONIC WITHIN THE INTERNAL BUFR C TABLE B ARRAY TABB(*,LUN) IN MODULE 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2007-01-19 J. ATOR -- ADDED EXTRA ARGUMENT FOR CALL TO JSTCHR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL ELEMDX (CARD, LUN) C INPUT ARGUMENT LIST: C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: BORT2 CAPIT JSTCHR JSTNUM C NEMTAB C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*80 CARD CHARACTER*24 UNIT CHARACTER*11 REFR,REFR_ORIG CHARACTER*8 NEMO CHARACTER*4 SCAL,SCAL_ORIG CHARACTER*3 BITW,BITW_ORIG CHARACTER*1 SIGN,TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CAPTURE THE VARIOUS ELEMENTS CHARACTERISTICS C -------------------------------------------- NEMO = CARD( 3:10) SCAL = CARD(14:17) REFR = CARD(21:31) BITW = CARD(35:37) UNIT = CARD(41:64) c .... Make sure the units are all capitalized CALL CAPIT(UNIT) C FIND THE ELEMENT TAG IN TABLE B C ------------------------------- C Note that an entry for this mnemonic should already exist within C the internal BUFR Table B array TABB(*,LUN). We now need to C retrieve the positional index for that entry within TABB(*,LUN) C so that we can access the entry and then add the scale factor, C reference value, bit width, and units to it. CALL NEMTAB(LUN,NEMO,IDSN,TAB,IELE) IF(TAB.NE.'B') GOTO 900 C LEFT JUSTIFY AND STORE CHARACTERISTICS C -------------------------------------- CALL JSTCHR(UNIT,IRET) IF(IRET.NE.0) GOTO 904 TABB(IELE,LUN)(71:94) = UNIT SCAL_ORIG=SCAL CALL JSTNUM(SCAL,SIGN,IRET) IF(IRET.NE.0) GOTO 901 TABB(IELE,LUN)(95:95) = SIGN TABB(IELE,LUN)(96:98) = SCAL REFR_ORIG=REFR CALL JSTNUM(REFR,SIGN,IRET) IF(IRET.NE.0) GOTO 902 TABB(IELE,LUN)( 99: 99) = SIGN TABB(IELE,LUN)(100:109) = REFR BITW_ORIG=BITW CALL JSTNUM(BITW,SIGN,IRET) IF(IRET.NE.0 ) GOTO 903 IF(SIGN.EQ.'-') GOTO 903 TABB(IELE,LUN)(110:112) = BITW C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE B ENTRY '// . '(UNDEFINED, TAB=",A,")")') NEMO,TAB CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"PARSED SCALE VALUE (=",A,") IS NOT '// . 'NUMERIC")') SCAL_ORIG CALL BORT2(BORT_STR1,BORT_STR2) 902 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"PARSED REFERENCE VALUE (=",A,") IS NOT '// . 'NUMERIC")') REFR_ORIG CALL BORT2(BORT_STR1,BORT_STR2) 903 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"PARSED BIT WIDTH VALUE (=",A,") IS NOT '// . 'NUMERIC")') BITW_ORIG CALL BORT2(BORT_STR1,BORT_STR2) 904 WRITE(BORT_STR1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"UNITS FIELD IS EMPTY")') CALL BORT2(BORT_STR1,BORT_STR2) END ./errwrt.f0000644001370400056700000000427113440555365011463 0ustar jator2emc SUBROUTINE ERRWRT(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ERRWRT C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-04-21 C C ABSTRACT: THIS SUBROUTINE WRITES A GIVEN ERROR OR OTHER DIAGNOSTIC C MESSAGE TO A USER-SPECIFIED LOGICAL UNIT. AS DISTRIBUTED WITHIN C THE BUFR ARCHIVE LIBRARY, THIS SUBROUTINE WILL WRITE ANY SUCH C MESSAGES TO STANDARD OUTPUT; HOWEVER, APPLICATION PROGRAMS MAY C SUBSTITUTE AN IN-LINE VERSION OF ERRWRT (OVERRIDING THIS ONE) IN C ORDER TO DEFINE AN ALTERNATE DESTINATION FOR SUCH MESSAGES. C C PROGRAM HISTORY LOG: C 2009-04-21 J. ATOR -- ORIGINAL AUTHOR C 2012-11-15 D. KEYSER -- USE FORMATTED PRINT C C USAGE: CALL ERRWRT (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): ERROR MESSAGE TO BE PRINTED TO C STANDARD OUTPUT (DEFAULT) OR TO ANOTHER DESTINATION C (IF SPECIFIED BY THE USER APPLICATION VIA AN IN-LINE C REPLACEMENT FOR THIS SUBROUTINE) C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: BORT BORT2 CKTABA CPDXMM C CPYUPD DATEBF DUMPBF HOLD4WLC C IGETPRM INVCON INVTAG INVWIN C IREADMT JSTNUM MAKESTAB MAXOUT C MRGINV MSGUPD MSGWRT NVNWIN C OPENBF OPENBT PKTDD RDBFDX C RDMEMM RDMEMS READDX READERME C READLC READMG READS3 STRNUM C STRSUC UFBEVN UFBIN3 UFBINT C UFBMEM UFBMEX UFBOVR UFBREP C UFBRMS UFBRW UFBSEQ UFBSTP C UFBTAB UFBTAM USRTPL VALX C WRDLEN MTFNAM C Can also be called by application C programs using an in-line version. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR PRINT'(1X,A)',STR RETURN END ./exitbufr.f0000644001370400056700000000341613440555365011766 0ustar jator2emc SUBROUTINE EXITBUFR C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: EXITBUFR C PRGMMR: ATOR ORG: NCEP DATE: 2015-03-02 C C ABSTRACT: THIS SUBROUTINE FREES ALL DYNAMICALLY-ALLOCATED MEMORY, C CLOSES ALL LOGICAL UNITS THAT ARE OPEN TO THE BUFR ARCHIVE LIBRARY, C AND RESETS THE LIBRARY TO ALL OF ITS DEFAULT SETTINGS AS THOUGH IT C HAD NEVER BEEN CALLED. THIS ALLOWS AN APPLICATION PROGRAM TO C POTENTIALLY RE-ALLOCATE MEMORY ALL OVER AGAIN WITHIN THE BUFR C ARCHIVE LIBRARY VIA A NEW SUBSEQUENT SERIES OF CALLS TO C SUBROUTINES ISETPRM AND OPENBF. C C NOTE THAT ONCE THIS SUBROUTINE IS CALLED, THE ENTIRE BUFR ARCHIVE C LIBRARY IS UNUSABLE FOR THE REMAINDER OF THE LIFE OF THE C APPLICATION PROGRAM, UNLESS AND UNTIL SUBROUTINE OPENBF IS C CALLED TO ONCE AGAIN DYNAMICALLY ALLOCATE NEW ARRAY SPACE. C C PROGRAM HISTORY LOG: C 2015-03-02 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL EXITBUFR C C REMARKS: C THIS ROUTINE CALLS: ARDLLOCF CLOSBF DLLOCTBF C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_STBFR USE MODA_IFOPBF USE MODA_S01CM INCLUDE 'bufrlib.prm' COMMON /TABLEF/ CDMF CHARACTER*1 CDMF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Close any logical units that are open to the library. DO JJ = 1, NFILES IF ( IOLUN(JJ) .NE. 0 ) CALL CLOSBF( ABS(IOLUN(JJ)) ) END DO C Deallocate all allocated memory. CALL ARDLLOCF IF ( CDMF .EQ. 'Y' ) CALL DLLOCTBF C Reset the library. NS01V = 0 IFOPBF = 0 RETURN END ./fstag.f0000644001370400056700000000543513440555365011245 0ustar jator2emc SUBROUTINE FSTAG ( LUN, UTAG, NUTAG, NIN, NOUT, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: FSTAG C PRGMMR: J. ATOR ORG: NP12 DATE: 2014-10-02 C C ABSTRACT: THIS SUBROUTINE FINDS THE (NUTAG)th OCCURRENCE OF MNEMONIC C UTAG WITHIN THE CURRENT OVERALL SUBSET DEFINITION, STARTING FROM C PARAMETER #(NIN) WITHIN THE SUBSET. THE SUBROUTINE SEARCHES FORWARD C FROM NIN IF NUTAG IS POSITIVE OR ELSE BACKWARD IF NUTAG IS NEGATIVE. C C PROGRAM HISTORY LOG: C 2014-10-02 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL FSTAG (LUN, UTAG, NUTAG, NIN, NOUT, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C UTAG - CHARACTER*(*): MNEMONIC C NUTAG - INTEGER: ORDINAL OCCURRENCE OF UTAG TO SEARCH FOR C WITHIN THE OVERALL SUBSET DEFINITION, COUNTING FROM C PARAMETER #(NIN) WITHIN THE SUBSET. THE SUBROUTINE C WILL SEARCH IN A FORWARD DIRECTION FROM PARAMETER C #(NIN) IF NUTAG IS POSITIVE OR ELSE IN A BACKWARD C DIRECTION IF NUTAG IS NEGATIVE. C NIN - INTEGER: LOCATION WITHIN THE OVERALL SUBSET DEFINITION C FROM WHICH TO BEGIN SEARCHING FOR UTAG. C C OUTPUT ARGUMENT LIST: C NOUT - INTEGER: LOCATION OF (NUTAG)th OCCURRENCE OF UTAG C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = REQUESTED MNEMONIC COULD NOT BE FOUND, OR SOME C OTHER ERROR OCCURRED C C REMARKS: C THIS ROUTINE CALLS: PARSTR C THIS ROUTINE IS CALLED BY: GETTAGPR GETTAGRE GETVALNB NEMSPECS C SETVALNB UFDUMP C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*10 TGS(15) CHARACTER*(*) UTAG DATA MAXTG /15/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Confirm that there is only one mnemonic in the input string. CALL PARSTR( UTAG, TGS, MAXTG, NTG, ' ', .TRUE. ) IF ( NTG .NE .1 ) RETURN C Starting from NIN, search either forward or backward for the C (NUTAG)th occurrence of UTAG. IF ( NUTAG .EQ. 0 ) RETURN ISTEP = ISIGN( 1, NUTAG ) ITAGCT = 0 NOUT = NIN + ISTEP DO WHILE ( ( NOUT .GE. 1 ) .AND. ( NOUT .LE. NVAL(LUN) ) ) IF ( TGS(1) .EQ. TAG(INV(NOUT,LUN)) ) THEN ITAGCT = ITAGCT + 1 IF ( ITAGCT .EQ. IABS(NUTAG) ) THEN IRET = 0 RETURN ENDIF ENDIF NOUT = NOUT + ISTEP ENDDO RETURN END ./getabdb.f0000644001370400056700000000442713440555365011531 0ustar jator2emc SUBROUTINE GETABDB(LUNIT,TABDB,ITAB,JTAB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETABDB C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE RETURNS INTERNAL TABLE B AND TABLE D C INFORMATION FOR LOGICAL UNIT LUNIT IN A PRE-DEFINED ASCII FORMAT. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ADDED TO BUFR ARCHIVE LIBRARY (WAS IN-LINED C IN PROGRAM NAMSND) C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL GETABDB( LUNIT, TABDB, ITAB, JTAB ) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C ITAB - INTEGER: DIMENSIONED SIZE OF TABDB ARRAY C C OUTPUT ARGUMENT LIST: C TABDB - CHARACTER*128: (JTAB)-WORD ARRAY OF INTERNAL TABLE B C AND TABLE D INFORMATION C JTAB - INTEGER: NUMBER OF ENTRIES STORED WITHIN TABDB C C REMARKS: C THIS ROUTINE CALLS: NEMTBD STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD USE MODA_NMIKRP INCLUDE 'bufrlib.prm' CHARACTER*128 TABDB(*) CHARACTER*8 NEMO C----------------------------------------------------------------------- C----------------------------------------------------------------------- JTAB = 0 C MAKE SURE THE FILE IS OPEN C -------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) RETURN C WRITE OUT THE TABLE D ENTRIES FOR THIS FILE C ------------------------------------------- DO I=1,NTBD(LUN) NEMO = TABD(I,LUN)(7:14) CALL NEMTBD(LUN,I,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) DO J=1,NSEQ,10 JTAB = JTAB+1 IF(JTAB.LE.ITAB) THEN WRITE(TABDB(JTAB),1) NEMO,(NEM(K,1),K=J,MIN(J+9,NSEQ)) 1 FORMAT('D ',A8,10(1X,A10)) ENDIF ENDDO ENDDO C ADD THE TABLE B ENTRIES C ----------------------- DO I=1,NTBB(LUN) JTAB = JTAB+1 IF(JTAB.LE.ITAB) THEN WRITE(TABDB(JTAB),2) TABB(I,LUN)(7:14),TABB(I,LUN)(71:112) 2 FORMAT('B ',A8,1X,A42) ENDIF ENDDO RETURN END ./getbmiss.f0000644001370400056700000000244713440555365011756 0ustar jator2emc REAL*8 FUNCTION GETBMISS() C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETBMISS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 C C ABSTRACT: GETBMISS RETURNS THE CURRENT VALUE OF "BMISS" WHICH DENOTES C MISSING VALUES BOTH FOR READING FROM BUFR FILES AND FOR C WRITING TO BUFR FILES. THIS MISSING VALUE IS SET TO A C DEFAULT VALUE OF 10E10 IN SUBROUTINE BFRINI, BUT APPLICATION C PROGRAMS MAY SET IT TO A DIFFERENT VALUE VIA A CALL TO C SUBROUTINE SETBMISS. C C PROGRAM HISTORY LOG: C 2012-10-05 J. ATOR -- ORIGINAL AUTHOR C C USAGE: GETBMISS() C C INPUT ARGUMENTS: C C OUTPUT ARGUMENTS: C GETBMISS - REAL*8: CURRENT VALUE OF BUFR ARCHIVE LIBRARY MISSING C VALUE "BMISS" C C REMARKS: C THIS ROUTINE CALLS: OPENBF C C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' c----------------------------------------------------------------------- c----------------------------------------------------------------------- CALL OPENBF(0,'FIRST',0) GETBMISS = BMISS RETURN END ./getcfmng.f0000644001370400056700000002155013440555365011727 0ustar jator2emc SUBROUTINE GETCFMNG ( LUNIT, NEMOI, IVALI, NEMOD, IVALD, . CMEANG, LNMNG, IRET ) C*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETCFMNG C PRGMMR: ATOR ORG: NCEP DATE: 2018-01-11 C C ABSTRACT: THIS ROUTINE CAN BE CALLED AT ANY TIME AFTER A BUFR MESSAGE C HAS BEEN READ INTO MEMORY VIA SUBROUTINE READMG, READERME OR C EQUIVALENT, AND IT CAN BE CALLED FOR ANY CODE OR FLAG TABLE MNEMONIC C DEFINED WITHIN THAT MESSAGE. IT SEARCHES FOR THE SPECIFIED MNEMONIC C AND ASSOCIATED VALUE (CODE FIGURE OR BIT NUMBER) WITHIN THE INTERNAL C MEMORY STRUCTURE FOR STORING CODE/FLAG TABLE INFORMATION, AND IF C FOUND RETURNS THE ASSOCIATED MEANING AS A CHARACTER STRING. THE C SEARCH MAY ALSO OPTIONALLY INCLUDE A SPECIFIED SECOND MNEMONIC C AND ASSOCIATED VALUE UPON WHICH THE FIRST MNEMONIC AND ITS C ASSOCIATED VALUE DEPEND, FOR CASES SUCH AS, E.G. WHEN THE MEANING C OF AN ORIGINATING SUBCENTER VALUE DEPENDS ON THE IDENTITY OF THE C ORIGINATING CENTER. C C NOTE THAT THIS ROUTINE CAN ONLY BE CALLED FOR MNEMONICS WHICH ARE C DEFINED WITHIN THE MESSAGE THAT WAS MOST RECENTLY READ INTO MEMORY. C IN MOST CASES THIS MEANS THAT THE MNEMONIC MUST BE CONTAINED WITHIN C THE SUBSET DEFINITION (SECTION 3) OF THAT MESSAGE. THE ONLY C EXCEPTIONS TO THIS RULE ARE FOR ORIGINATING CENTERS, ORIGINATING C SUBCENTERS, DATA TYPES AND DATA SUBTYPES, SINCE THOSE CAN ALSO BE C CONTAINED WITHIN THE IDENTIFICATION SECTION (SECTION 1) OF A BUFR C MESSAGE. IN ANY CASE, IF THE SEARCH IS UNSUCCESSFUL, AND IF THERE C WAS NO OPTIONAL SECOND MNEMONIC AND ASSOCIATED VALUE SPECIFIED ON C INPUT, THE ROUTINE WILL RE-SEARCH THE TABLE TO CHECK WHETHER THE C MEANING OF THE FIRST MNEMONIC AND ASSOCIATED VALUE MAY INDEED DEPEND C ON THE VALUE OF ONE OR MORE OTHER POSSIBLE SECOND MNEMONICS. IF SO, C THOSE POSSIBLE MNEMONICS ARE RETURNED ALONG WITH A SPECIAL RETURN C CODE SO THAT THE CALLING ROUTINE MAY EXAMINE THEM AND POSSIBLY ISSUE C ANOTHER SUBSEQUENT CALL TO THIS SAME ROUTINE WITH SPECIFIED VALUES C FOR THE SECOND MNEMONIC AND ASSOCIATED VALUE. C C PROGRAM HISTORY LOG: C 2018-01-11 J. ATOR -- ORIGINAL AUTHOR C 2018-01-11 J. ATOR -- ADD SPECIAL HANDLING FOR DATA TYPES AND C SUBTYPES IN SECTION 1 C C USAGE: CALL GETCFMNG ( LUNIT, NEMOI, IVALI, NEMOD, IVALD, C CMEANG, LNMNG, IRET ) C C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C NEMOI - CHARACTER*(*): MNEMONIC TO SEARCH FOR C IVALI - INTEGER: VALUE (CODE FIGURE OR BIT NUMBER) ASSOCIATED C WITH NEMOI C NEMOD - CHARACTER*(*): OPTIONAL SECOND MNEMONIC UPON WHICH THE C VALUES NEMOI AND IVALI DEPEND; SET TO ALL BLANK C CHARACTERS IF THE MEANINGS OF NEMOI AND IVALI DO NOT C DEPEND ON THE VALUE OF ANY OTHER MNEMONIC C IVALD - INTEGER: VALUE (CODE FIGURE OR BIT NUMBER) ASSOCIATED C WITH NEMOD; SET TO (-1) WHENEVER NEMOD IS SET TO ALL C BLANK CHARACTERS C C OUTPUT ARGUMENT LIST: C CMEANG - CHARACTER*(*): IF THE INITIAL SEARCH OF THE TABLE WAS C SUCCESSFUL, THEN THIS STRING CONTAINS THE MEANING C CORRESPONDING TO NEMOI AND IVALI (AND TO NEMOD AND C IVALD, IF SPECIFIED). HOWEVER, IF THE INITIAL SEARCH C WAS UNSUCCESSFUL, *AND* IF NO OPTIONAL SECOND MNEMONIC C AND ASSOCIATED VALUE WERE SPECIFIED ON INPUT, *AND* IF C THE SECOND SEARCH OF THE TABLE DETERMINED THAT THE C MEANING OF THE FIRST MNEMONIC AND ASSOCIATED VALUE C INDEED DEPENDS ON ONE OR MORE OTHER POSSIBLE SECOND C MNEMONICS, THEN THOSE POSSIBLE SECOND MNEMONICS C ARE RETURNED WITHIN THIS STRING, AS A SERIES OF IRET C SUCCESSIVE 8-BYTE SUBSTRINGS C LNMNG - INTEGER: LENGTH OF STRING RETURNED IN MEANING C IRET - RETURN CODE: C 0 = MEANING FOUND AND STORED IN CMEANG STRING C -1 = MEANING NOT FOUND C >0 = MEANING NOT FOUND, *AND* NEMOD AND IVALD WERE C NOT SPECIFIED ON INPUT, *AND* THE MEANING OF C NEMOI AND IVALI DEPENDS ON THE VALUE OF ONE OF C THE MNEMONICS STORED IN THE FIRST IRET 8-BYTE C SUBSTRINGS OF THE CMEANG STRING C C REMARKS: C THIS ROUTINE CALLS: BORT IFXY IREADMT NEMTAB C NUMTBD PARSTR SRCHTBF STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' COMMON /TABLEF/ CDMF CHARACTER*(*) NEMOI, NEMOD, CMEANG CHARACTER*128 BORT_STR CHARACTER*8 NEMO CHARACTER*1 CDMF, TAB DIMENSION IFXYD(10) C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS ( LUNIT, LUN, IL, IM ) IF ( IL .EQ. 0 ) GOTO 900 IF ( IL .GT. 0 ) GOTO 901 IF ( IM .EQ. 0 ) GOTO 902 C* Make sure the appropriate code/flag information has already been C* read into internal memory. IF ( CDMF .NE. 'Y' ) GOTO 903 ITMP = IREADMT ( LUN ) C* Check the validity of the input mnemonic(s). Include special C* handling for originating centers, originating subcenters, data C* types and data subtypes, since those can be reported in C* Section 1 of a BUFR message as well as in Section 3, so if a C* user requests those mnemonics we can't necessarily assume they C* came from within Section 3. LCMG = LEN ( CMEANG ) IF ( NEMOI(1:4) .EQ. 'GSES' ) THEN IF ( ( NEMOD(1:6) .EQ. 'GCLONG' ) .OR. . ( NEMOD(1:4) .EQ. 'OGCE' ) .OR. . ( NEMOD(1:5) .EQ. 'ORIGC' ) ) THEN IFXYI = IFXY ( '001034' ) IFXYD(1) = IFXY ( '001035' ) ELSE LNMNG = MIN ( 24, LCMG ) IF ( LNMNG .EQ. 24 ) THEN IRET = 3 CMEANG(1:24) = 'GCLONG OGCE ORIGC ' ELSE IRET = -1 END IF RETURN END IF ELSE IF ( NEMOI(1:6) .EQ. 'GCLONG' ) THEN IFXYI = IFXY ( '001031' ) IFXYD(1) = (-1) ELSE IF ( NEMOI(1:4) .EQ. 'OGCE' ) THEN IFXYI = IFXY ( '001033' ) IFXYD(1) = (-1) ELSE IF ( NEMOI(1:5) .EQ. 'ORIGC' ) THEN IFXYI = IFXY ( '001035' ) IFXYD(1) = (-1) ELSE IF ( ( NEMOI(1:7) .EQ. 'TABLASS' ) .OR. + ( NEMOI(1:7) .EQ. 'TABLASL' ) ) THEN IF ( ( NEMOD(1:6) .EQ. 'TABLAT' ) ) THEN IF ( NEMOI(1:7) .EQ. 'TABLASS' ) THEN IFXYI = IFXY ( '055021' ) ELSE IFXYI = IFXY ( '055022' ) ENDIF IFXYD(1) = IFXY ( '055020' ) ELSE LNMNG = MIN ( 8, LCMG ) IF ( LNMNG .EQ. 8 ) THEN IRET = 1 CMEANG(1:8) = 'TABLAT ' ELSE IRET = -1 END IF RETURN END IF ELSE IF ( NEMOI(1:6) .EQ. 'TABLAT' ) THEN IFXYI = IFXY ( '055020' ) IFXYD(1) = (-1) ELSE CALL PARSTR ( NEMOI, NEMO, 1, NTG, ' ', .TRUE. ) CALL NEMTAB ( LUN, NEMO, IFXYI, TAB, N ) IF ( ( N .EQ. 0 ) .OR. ( TAB .NE. 'B' ) ) GOTO 904 IF ( ( TABB ( N, LUN )(71:74) .NE. 'CODE' ) .AND. . ( TABB ( N, LUN )(71:74) .NE. 'FLAG' ) ) GOTO 905 IF ( NEMOD(1:1) .NE. ' ' ) THEN CALL PARSTR ( NEMOD, NEMO, 1, NTG, ' ', .TRUE. ) CALL NEMTAB ( LUN, NEMO, IFXYD(1), TAB, N ) IF ( ( N .EQ. 0 ) .OR. ( TAB .NE. 'B' ) ) GOTO 904 IF ( ( TABB ( N, LUN )(71:74) .NE. 'CODE' ) .AND. . ( TABB ( N, LUN )(71:74) .NE. 'FLAG' ) ) GOTO 905 ELSE IFXYD(1) = (-1) END IF END IF C* Search the internal table for the requested meaning. CALL SRCHTBF ( IFXYI, IVALI, IFXYD, 10, IVALD, . CMEANG, LCMG, LNMNG, IRET ) IF ( IRET .LE. 0 ) RETURN C* The meaning of this value is dependent on the value of another C* mnemonic in the report. IRET2 = IRET LNMNG = 0 IRET = 0 DO II = 1, IRET2 CALL NUMTBD ( LUN, IFXYD(II), NEMO, TAB, IERBD ) IF ( ( IERBD .GT. 0 ) .AND. ( TAB .EQ. 'B' ) .AND. . ( LCMG .GE. ( LNMNG + 8 ) ) ) THEN IRET = IRET + 1 CMEANG(LNMNG+1:LNMNG+8) = NEMO LNMNG = LNMNG + 8 END IF END DO IF ( IRET .EQ. 0 ) IRET = -1 RETURN 900 CALL BORT('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: GETCFMNG - A MESSAGE MUST BE OPEN IN '// . 'INPUT BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// . 'FIRST CALL SUBROUTINE CODFLG WITH INPUT ARGUMENT SET TO Y') 904 WRITE(BORT_STR,'("BUFRLIB: GETCFMNG - MNEMONIC ",A,'// . '" NOT FOUND IN TABLE B")') NEMO CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: GETCFMNG - MNEMONIC ",A,'// . '" IS NOT A CODE OR FLAG TABLE")') NEMO CALL BORT(BORT_STR) END ./getlens.f0000644001370400056700000000501713440555365011576 0ustar jator2emc SUBROUTINE GETLENS(MBAY,LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETLENS C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS ALL OF THE INDIVIDUAL C SECTION LENGTHS OF THE BUFR MESSAGE STORED IN ARRAY MBAY, UP TO A C SPECIFIED POINT. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR C EDITION 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING C "BUFR") MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL GETLENS (MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C LL - INTEGER: NUMBER OF LAST SECTION FOR WHICH THE LENGTH C IS TO BE UNPACKED. IN OTHER WORDS, SETTING LL = N C MEANS TO UNPACK THE LENGTHS OF SECTIONS 0 THROUGH N C (I.E. LEN0, LEN1,...,LEN(N)). ANY SECTION LENGTHS C THAT ARE NOT UNPACKED ARE RETURNED WITH A DEFAULT C VALUE OF -1. C C OUTPUT ARGUMENT LIST: C LEN0 - LENGTH OF SECTION 0 (= -1 IF NOT UNPACKED) C LEN1 - LENGTH OF SECTION 1 (= -1 IF NOT UNPACKED) C LEN2 - LENGTH OF SECTION 2 (= -1 IF NOT UNPACKED) C LEN3 - LENGTH OF SECTION 3 (= -1 IF NOT UNPACKED) C LEN4 - LENGTH OF SECTION 4 (= -1 IF NOT UNPACKED) C LEN5 - LENGTH OF SECTION 5 (= -1 IF NOT UNPACKED) C C REMARKS: C THIS ROUTINE CALLS: IUPB IUPBS01 C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 COPYSB C IUPBS3 MSGWRT STBFDX STNDRD C UPDS3 WRDXTB WRITLC C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- LEN0 = -1 LEN1 = -1 LEN2 = -1 LEN3 = -1 LEN4 = -1 LEN5 = -1 IF(LL.LT.0) RETURN LEN0 = IUPBS01(MBAY,'LEN0') IF(LL.LT.1) RETURN LEN1 = IUPBS01(MBAY,'LEN1') IF(LL.LT.2) RETURN IAD2 = LEN0 + LEN1 LEN2 = IUPB(MBAY,IAD2+1,24) * IUPBS01(MBAY,'ISC2') IF(LL.LT.3) RETURN IAD3 = IAD2 + LEN2 LEN3 = IUPB(MBAY,IAD3+1,24) IF(LL.LT.4) RETURN IAD4 = IAD3 + LEN3 LEN4 = IUPB(MBAY,IAD4+1,24) IF(LL.LT.5) RETURN LEN5 = 4 RETURN END ./getntbe.f0000644001370400056700000000457513440555365011575 0ustar jator2emc SUBROUTINE GETNTBE ( LUNT, IFXYN, LINE, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETNTBE C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE GETS THE FIRST LINE OF THE NEXT ENTRY IN C THE SPECIFIED ASCII MASTER TABLE B OR MASTER TABLE D FILE. THIS C LINE CONTAINS, AMONG OTHER THINGS, THE FXY NUMBER CORRESPONDING TO C THIS ENTRY. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL GETNTBE ( LUNT, IFXYN, LINE, IRET ) C INPUT ARGUMENT LIST: C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING MASTER TABLE B OR MASTER TABLE D INFORMATION C C OUTPUT ARGUMENT LIST: C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR C NEXT TABLE ENTRY C LINE - CHARACTER*(*): FIRST LINE OF NEXT TABLE ENTRY C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = end-of-file encountered while reading C from LUNT C -2 = I/O error encountered while reading C from LUNT C C REMARKS: C THIS ROUTINE CALLS: BORT2 IGETNTBL IGETFXY IFXY C PARSTR C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD RDMTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) LINE CHARACTER*128 BORT_STR1, BORT_STR2 CHARACTER*20 TAGS(4) CHARACTER*6 ADSC C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Get the first line of the next entry in the file. IRET = IGETNTBL ( LUNT, LINE ) IF ( IRET .EQ. 0 ) THEN C The first field within this line should contain the C FXY number. CALL PARSTR ( LINE(1:20), TAGS, 4, NTAG, '|', .FALSE. ) IF ( NTAG .LT. 1 ) GOTO 900 IF ( IGETFXY ( TAGS(1), ADSC ) .NE. 0 ) GOTO 900 C Store the bit-wise representation of the FXY number. IFXYN = IFXY ( ADSC ) ENDIF RETURN 900 BORT_STR1 = 'BUFRLIB: GETNTBE - CARD BEGINNING WITH: ' // . LINE(1:20) BORT_STR2 = ' HAS BAD OR MISSING FXY NUMBER' CALL BORT2(BORT_STR1,BORT_STR2) END ./gets1loc.f0000644001370400056700000001454413440555365011663 0ustar jator2emc SUBROUTINE GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETS1LOC C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE RETURNS THE LOCATION (I.E. STARTING BYTE C AND BIT WIDTH) OF A SPECIFIED VALUE WITHIN SECTION 1 OF A BUFR C MESSAGE ENCODED ACCORDING TO A SPECIFIED BUFR EDITION. IT WILL C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE C VALUE FOR WHICH THE LOCATION IS TO BE DETERMINED IS SPECIFIED VIA C THE MNEMONIC S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'YCEN' AND 'CENT' C C USAGE: GETS1LOC ( S1MNEM, IBEN, ISBYT, IWID, IRET ) C INPUT ARGUMENT LIST: C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE WHOSE C LOCATION WITHIN SECTION 1 IS TO BE DETERMINED: C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 C 'BMT' = BUFR MASTER TABLE C 'OGCE' = ORIGINATING CENTER C 'GSES' = ORIGINATING SUBCENTER C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 3 OR 4 MESSAGES!) C 'USN' = UPDATE SEQUENCE NUMBER C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: C 0 = SECTION 2 ABSENT C 1 = SECTION 2 PRESENT C 'MTYP' = DATA CATEGORY C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MSBT' = DATA SUBCATEGORY (LOCAL) C 'MTV' = VERSION NUMBER OF MASTER TABLE C 'MTVL' = VERSION NUMBER OF LOCAL TABLES C 'YCEN' = YEAR OF CENTURY (1-100) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, C 21 FOR YEARS 2001-2100) C (NOTE: THIS VALUE *MAY* BE PRESENT IN C BUFR EDITION 2 AND 3 MESSAGES, C BUT IT IS NEVER PRESENT IN ANY C BUFR EDITION 4 MESSAGES!) C 'YEAR' = YEAR (4-DIGIT) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MNTH' = MONTH C 'DAYS' = DAY C 'HOUR' = HOUR C 'MINU' = MINUTE C 'SECO' = SECOND C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES!) C IBEN - INTEGER: BUFR EDITION NUMBER C C C OUTPUT ARGUMENT LIST: C ISBYT - INTEGER: NUMBER OF STARTING BYTE WITHIN SECTION 1 C WHICH CONTAINS VALUE CORRESPONDING TO S1MNEM C (NOTE: ISBYT IS ALWAYS RETURNED AS 18 WHENEVER C S1MNEM = 'CENT' AND IBEN = 2 OR 3; IN SUCH C CASES IT IS THEN UP TO THE CALLING ROUTINE C TO DETERMINE WHETHER THIS LOCATION ACTUALLY C CONTAINS A VALID CENTURY VALUE!) C IWID - INTEGER: WIDTH (IN BITS) OF VALUE CORRESPONDING C TO S1MNEM C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = THE INPUT S1MNEM MNEMONIC IS INVALID FOR C BUFR EDITION IBEN C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CRBMG IUPBS01 PKBS1 C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) S1MNEM C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 IWID = 8 IF(S1MNEM.EQ.'LEN1') THEN ISBYT = 1 IWID = 24 ELSE IF(S1MNEM.EQ.'BMT') THEN ISBYT = 4 ELSE IF(S1MNEM.EQ.'OGCE') THEN IF(IBEN.EQ.3) THEN ISBYT = 6 ELSE C Note that this location is actually the same for both C Edition 2 *and* Edition 4 of BUFR! ISBYT = 5 IWID = 16 ENDIF ELSE IF(S1MNEM.EQ.'GSES') THEN IF(IBEN.EQ.3) THEN ISBYT = 5 ELSE IF(IBEN.EQ.4) THEN ISBYT = 7 IWID = 16 ELSE IRET = -1 ENDIF ELSE IF(S1MNEM.EQ.'USN') THEN IF(IBEN.EQ.4) THEN ISBYT = 9 ELSE ISBYT = 7 ENDIF ELSE IF(S1MNEM.EQ.'ISC2') THEN IWID = 1 IF(IBEN.EQ.4) THEN ISBYT = 10 ELSE ISBYT = 8 ENDIF ELSE IF(S1MNEM.EQ.'MTYP') THEN IF(IBEN.EQ.4) THEN ISBYT = 11 ELSE ISBYT = 9 ENDIF ELSE IF(S1MNEM.EQ.'MSBTI') THEN IF(IBEN.EQ.4) THEN ISBYT = 12 ELSE IRET = -1 ENDIF ELSE IF(S1MNEM.EQ.'MSBT') THEN IF(IBEN.EQ.4) THEN ISBYT = 13 ELSE ISBYT = 10 ENDIF ELSE IF(S1MNEM.EQ.'MTV') THEN IF(IBEN.EQ.4) THEN ISBYT = 14 ELSE ISBYT = 11 ENDIF ELSE IF(S1MNEM.EQ.'MTVL') THEN IF(IBEN.EQ.4) THEN ISBYT = 15 ELSE ISBYT = 12 ENDIF ELSE IF(S1MNEM.EQ.'YEAR') THEN IF(IBEN.EQ.4) THEN ISBYT = 16 IWID = 16 ELSE IRET = -1 ENDIF ELSE IF(S1MNEM.EQ.'YCEN') THEN IF(IBEN.LT.4) THEN ISBYT = 13 ELSE IRET = -1 ENDIF ELSE IF(S1MNEM.EQ.'CENT') THEN IF(IBEN.LT.4) THEN ISBYT = 18 ELSE IRET = -1 ENDIF ELSE IF(S1MNEM.EQ.'MNTH') THEN IF(IBEN.EQ.4) THEN ISBYT = 18 ELSE ISBYT = 14 ENDIF ELSE IF(S1MNEM.EQ.'DAYS') THEN IF(IBEN.EQ.4) THEN ISBYT = 19 ELSE ISBYT = 15 ENDIF ELSE IF(S1MNEM.EQ.'HOUR') THEN IF(IBEN.EQ.4) THEN ISBYT = 20 ELSE ISBYT = 16 ENDIF ELSE IF(S1MNEM.EQ.'MINU') THEN IF(IBEN.EQ.4) THEN ISBYT = 21 ELSE ISBYT = 17 ENDIF ELSE IF(S1MNEM.EQ.'SECO') THEN IF(IBEN.EQ.4) THEN ISBYT = 22 ELSE IRET = -1 ENDIF ELSE IRET = -1 ENDIF RETURN END ./gettagpr.f0000644001370400056700000000514613440555365011755 0ustar jator2emc SUBROUTINE GETTAGPR ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETTAGPR C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 C C ABSTRACT: GIVEN A MNEMONIC CORRESPONDING TO A CHILD DESCRIPTOR C WITHIN A PARENT SEQUENCE, THIS SUBROUTINE RETURNS THE MNEMONIC C CORRESPONDING TO THE PARENT SEQUENCE. A SUBSET DEFINITION MUST C ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE READSB OR EQUIVALENT (FOR INPUT FILES) OR TO C SUBROUTINE OPENMB OR EQUIVALENT (FOR OUTPUT FILES). IF THERE IS C MORE THAN ONE OCCURRENCE OF THE CHILD DESCRIPTOR WITHIN THE C OVERALL SUBSET DEFINITION, THIS SUBROUTINE WILL RETURN THE PARENT C MNEMONIC CORRESPONDING TO THE (NTAGCH)th OCCURRENCE OF THE CHILD, C COUNTING FROM THE BEGINNING OF THE OVERALL SUBSET DEFINITION. C C PROGRAM HISTORY LOG: C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR C 2014-10-02 J. ATOR -- MODIFIED TO USE FSTAG C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL GETTAGPR (LUNIT, TAGCH, NTAGCH, TAGPR, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C TAGCH - CHARACTER*(*): MNEMONIC CORRESPONDING TO CHILD C DESCRIPTOR C NTAGCH - INTEGER: ORDINAL OCCURRENCE OF TAGCH FOR WHICH C TAGPR IS TO BE RETURNED, COUNTING FROM THE C BEGINNING OF THE OVERALL SUBSET DEFINITION C C OUTPUT ARGUMENT LIST: C TAGPR - CHARACTER*(*): MNEMONIC CORRESPONDING TO PARENT C SEQUENCE DESCRIPTOR C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = PARENT MNEMONIC COULD NOT BE FOUND, OR SOME C OTHER ERROR OCCURRED C C REMARKS: C THIS ROUTINE CALLS: FSTAG STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) TAGCH, TAGPR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Get LUN from LUNIT. CALL STATUS( LUNIT, LUN, IL, IM ) IF ( IL .EQ. 0 ) RETURN IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN C Get TAGPR from the (NTAGCH)th occurrence of TAGCH. CALL FSTAG( LUN, TAGCH, NTAGCH, 1, NCH, IRET ) IF ( IRET .NE. 0 ) RETURN TAGPR = TAG(JMPB(INV(NCH,LUN))) RETURN END ./gettagre.f0000644001370400056700000000555013440555365011741 0ustar jator2emc SUBROUTINE GETTAGRE ( LUNIT, TAGI, NTAGI, TAGRE, NTAGRE, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETTAGRE C PRGMMR: J. ATOR ORG: NP12 DATE: 2016-06-07 C C ABSTRACT: GIVEN A MNEMONIC WITHIN A SUBSET CURRENTLY OPEN FOR C READING, THIS SUBROUTINE CHECKS WHETHER THE MNEMONIC REFERENCES C ANOTHER ELEMENT WITHIN THE SAME SUBSET VIA AN INTERNAL BITMAP, AND C IF SO RETURNS THE REFERENCED MNEMONIC AND ITS LOCATION. IF THERE C IS MORE THAN ONE OCCURRENCE OF THE INPUT MNEMONIC WITHIN THE OVERALL C SUBSET DEFINITION, THE SUBROUTINE WILL RETURN THE MNEMONIC REFERRED C TO BY THE (NTAGI)th OCCURRENCE OF THE INPUT MNEMONIC, COUNTING FROM C THE BEGINNING OF THE OVERALL SUBSET DEFINITION. A SUBSET DEFINITION C MUST ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE READSB OR EQUIVALENT. C C PROGRAM HISTORY LOG: C 2016-06-07 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL GETTAGRE (LUNIT, TAGI, NTAGI, TAGRE, NTAGRE, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C TAGI - CHARACTER*(*): MNEMONIC C NTAGI - INTEGER: ORDINAL OCCURRENCE OF TAGI FOR WHICH TAGRE C IS TO BE RETURNED, COUNTING FROM THE BEGINNING OF C THE OVERALL SUBSET DEFINITION C C OUTPUT ARGUMENT LIST: C TAGRE - CHARACTER*(*): MNEMONIC REFERRED TO BY TAGI VIA AN C INTERNAL BITMAP C NTAGRE - INTEGER: ORDINAL OCCURRENCE OF TAGRE REFERRED TO BY C (NTAGI)th OCCURRENCE OF TAGI, COUNTING FROM THE C BEGINNING OF THE OVERALL SUBSET DEFINITIION. C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = COULD NOT FIND TAGRE C C REMARKS: C THIS ROUTINE CALLS: FSTAG STATUS STRSUC C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) TAGI, TAGRE CHARACTER*10 TAGTMP C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Get LUN from LUNIT. CALL STATUS( LUNIT, LUN, IL, IM ) IF ( IL .EQ. 0 ) RETURN IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN C Get TAGRE and NTAGRE from the (NTAGI)th occurrence of TAGI. CALL FSTAG( LUN, TAGI, NTAGI, 1, NI, IRET ) IF ( IRET .NE. 0 ) RETURN NRE = NRFELM(NI,LUN) IF ( NRE .GT. 0 ) THEN IRET = 0 TAGRE = TAG(INV(NRE,LUN)) CALL STRSUC( TAGRE, TAGTMP, LTRE ) NTAGRE = 0 DO II = 1, NRE IF ( TAG(INV(II,LUN))(1:LTRE) .EQ. TAGRE(1:LTRE) ) THEN NTAGRE = NTAGRE + 1 END IF END DO END IF RETURN END ./gettbh.f0000644001370400056700000000577213440555365011422 0ustar jator2emc SUBROUTINE GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETTBH C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE READS AND PARSES THE HEADER LINES FROM TWO C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES CONTAINING C EITHER MASTER TABLE B OR MASTER TABLE D INFORMATION. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) C C INPUT ARGUMENT LIST: C LUNS - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING STANDARD TABLE INFORMATION C LUNL - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING LOCAL TABLE INFORMATION C TAB - CHARACTER*1: TABLE TYPE ('B' OR 'D') C C OUTPUT ARGUMENT LIST: C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM C STANDARD ASCII FILE C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM C LOCAL ASCII FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IGETNTBL PARSTR VALX C THIS ROUTINE IS CALLED BY: RDMTBB RDMTBD RDMTBF C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*128 BORT_STR CHARACTER*40 HEADER CHARACTER*30 TAGS(5), LABEL CHARACTER*3 CFTYP CHARACTER*2 CTTYP CHARACTER*1 TAB LOGICAL BADLABEL C----------------------------------------------------------------------- C Statement function to check for bad header line label: BADLABEL ( LABEL ) = ( ( INDEX ( LABEL, CTTYP ) .EQ. 0 ) .OR. . ( INDEX ( LABEL, CFTYP ) .EQ. 0 ) ) C----------------------------------------------------------------------- CTTYP = TAB // ' ' C Read and parse the header line of the standard file. CFTYP = 'STD' IF ( IGETNTBL ( LUNS, HEADER ) .NE. 0 ) GOTO 900 CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) IF ( NTAG .LT. 3 ) GOTO 900 IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 IMT = VALX ( TAGS(2) ) IMTV = VALX ( TAGS(3) ) C Read and parse the header line of the local file. CFTYP = 'LOC' IF ( IGETNTBL ( LUNL, HEADER ) .NE. 0 ) GOTO 900 CALL PARSTR ( HEADER, TAGS, 5, NTAG, '|', .FALSE. ) IF ( NTAG .LT. 4 ) GOTO 900 IF ( BADLABEL ( TAGS(1) ) ) GOTO 900 IMT2 = VALX ( TAGS(2) ) IOGCE = VALX ( TAGS(3) ) ILTV = VALX ( TAGS(4) ) C Verify that both files are for the same master table. IF ( IMT .NE. IMT2 ) GOTO 901 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: GETTBH - BAD OR MISSING HEADER '// . 'WITHIN ",A," TABLE ",A)') CFTYP, TAB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: GETTBH - MASTER TABLE NUMBER '// . 'MISMATCH BETWEEN STD AND LOC TABLE ",A)') TAB CALL BORT(BORT_STR) END ./getvalnb.f0000644001370400056700000000670513440555365011744 0ustar jator2emc REAL*8 FUNCTION GETVALNB ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETVALNB C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-09-12 C C ABSTRACT: THIS FUNCTION SHOULD ONLY BE CALLED WHEN A BUFR FILE IS C OPENED FOR INPUT, AND A SUBSET DEFINITION MUST ALREADY BE IN SCOPE C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR C EQUIVALENT. THE FUNCTION WILL FIRST SEARCH FOR THE (NTAGPV)th C OCCURRENCE OF MNEMONIC TAGPV WITHIN THE OVERALL SUBSET DEFINITION, C COUNTING FROM THE BEGINNING OF THE SUBSET. IF FOUND, IT WILL THEN C SEARCH FORWARD (IF NTAGNB IS POSITIVE) OR BACKWARD (IF NTAGNB IS C NEGATIVE) FROM THAT POINT WITHIN THE SUBSET FOR THE (NTAGNB)th C OCCURRENCE OF MNEMONIC TAGNB AND RETURN THE VALUE CORRESPONDING C TO THAT MNEMONIC. C C PROGRAM HISTORY LOG: C 2012-09-12 J. ATOR -- ORIGINAL AUTHOR C 2014-10-02 J. ATOR -- MODIFIED TO USE FSTAG C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL GETVALNB (LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C TAGPV - CHARACTER*(*): PIVOT MNEMONIC; THE FUNCTION WILL C FIRST SEARCH FOR the (NTAGPV)th OCCURRENCE OF THIS C MNEMONIC, COUNTING FROM THE BEGINNING OF THE OVERALL C SUBSET DEFINITION C NTAGPV - INTEGER: ORDINAL OCCURRENCE OF TAGPV TO SEARCH FOR C TAGNB - CHARACTER*(*): NEARBY MNEMONIC; ASSUMING TAGPV IS C SUCCESSFULLY FOUND, THE FUNCTION WILL THEN SEARCH C NEARBY FOR THE (NTAGNB)th OCCURRENCE OF TAGNB AND C RETURN THE CORRESPONDING VALUE C NTAGNB - INTEGER: ORDINAL OCCURRENCE OF TAGNB TO SEARCH FOR, C COUNTING FROM THE LOCATION OF TAGPV WITHIN THE OVERALL C SUBSET DEFINITION. IF NTAGNB IS POSITIVE, THE FUNCTION C WILL SEARCH IN A FORWARD DIRECTION FROM THE LOCATION OF C TAGPV, OR IF NTAGNB IS NEGATIVE IT WILL INSTEAD SEARCH C IN A BACKWARDS DIRECTION. C C OUTPUT ARGUMENT LIST: C GETVALNB - REAL*8: VALUE CORRESPONDING TO (NTAGNB)th OCCURRENCE C OF TAGNB. IF FOR ANY REASON THIS VALUE CANNOT BE C LOCATED, THEN THE BUFR ARCHIVE LIBRARY MISSING VALUE C BMISS WILL BE RETURNED. C C REMARKS: C THIS ROUTINE CALLS: FSTAG STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) TAGPV, TAGNB C---------------------------------------------------------------------- C---------------------------------------------------------------------- GETVALNB = BMISS C Get LUN from LUNIT. CALL STATUS (LUNIT, LUN, IL, IM ) IF ( IL .GE. 0 ) RETURN IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN C Starting from the beginning of the subset, locate the (NTAGPV)th C occurrence of TAGPV. CALL FSTAG( LUN, TAGPV, NTAGPV, 1, NPV, IRET ) IF ( IRET .NE. 0 ) RETURN C Now, starting from the (NTAGPV)th occurrence of TAGPV, search C forward or backward for the (NTAGNB)th occurrence of TAGNB. CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IRET ) IF ( IRET .NE. 0 ) RETURN GETVALNB = VAL(NNB,LUN) RETURN END ./getwin.f0000644001370400056700000001260313440555365011431 0ustar jator2emc SUBROUTINE GETWIN(NODE,LUN,IWIN,JWIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GETWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: GIVEN A NODE INDEX WITHIN THE INTERNAL JUMP/LINK TABLE, THIS C SUBROUTINE LOOKS WITHIN THE CURRENT SUBSET BUFFER FOR A "WINDOW" C (SEE BELOW REMARKS) WHICH CONTAINS THIS NODE. IF FOUND, IT RETURNS C THE STARTING AND ENDING INDICES OF THIS WINDOW WITHIN THE CURRENT C SUBSET BUFFER. FOR EXAMPLE, IF THE NODE IS FOUND WITHIN THE SUBSET C BUT IS NOT PART OF A DELAYED REPLICATION SEQUENCE, THEN THE RETURNED C INDICES DEFINE THE START AND END OF THE ENTIRE SUBSET BUFFER. C OTHERWISE, THE RETURNED INDICES DEFINE THE START AND END OF THE NEXT C AVAILABLE DELAYED REPLICATION SEQUENCE ITERATION WHICH CONTAINS THE C NODE. IF NO FURTHER ITERATIONS OF THE SEQUENCE CAN BE FOUND, THEN C THE STARTING INDEX IS RETURNED WITH A VALUE OF ZERO. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL GETWIN (NODE, LUN, IWIN, JWIN) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C JWIN - INTEGER: ENDING INDEX OF THE PREVIOUS WINDOW ITERATION C WHICH CONTAINED NODE C C OUTPUT ARGUMENT LIST: C IWIN - INTEGER: STARTING INDEX OF THE CURRENT WINDOW ITERATION C WHICH CONTAINS NODE C 0 = NOT FOUND OR NO MORE ITERATIONS AVAILABLE C JWIN - INTEGER: ENDING INDEX OF THE CURRENT WINDOW ITERATION C WHICH CONTAINS NODE C C REMARKS: C C THIS IS ONE OF A NUMBER OF SUBROUTINES WHICH OPERATE ON "WINDOWS" C (I.E. CONTIGUOUS PORTIONS) OF THE INTERNAL SUBSET BUFFER. THE C SUBSET BUFFER IS AN ARRAY OF VALUES ARRANGED ACCORDING TO THE C OVERALL TEMPLATE DEFINITION FOR A SUBSET. A WINDOW CAN BE ANY C CONTIGUOUS PORTION OF THE SUBSET BUFFER UP TO AND INCLUDING THE C ENTIRE SUBSET BUFFER ITSELF. FOR THE PURPOSES OF THESE "WINDOW C OPERATOR" SUBROUTINES, A WINDOW ESSENTIALLY CONSISTS OF ALL OF THE C ELEMENTS WITHIN A PARTICULAR DELAYED REPLICATION GROUP, SINCE SUCH C GROUPS EFFECTIVELY DEFINE THE DIMENSIONS WITHIN A BUFR SUBSET FOR C THE BUFR ARCHIVE LIBRARY SUBROUTINES SUCH AS UFBINT, UFBIN3, ETC. C WHICH READ/WRITE INDIVIDUAL DATA VALUES. A BUFR SUBSET WITH NO C DELAYED REPLICATION GROUPS IS CONSIDERED TO HAVE ONLY ONE C DIMENSION, AND THEREFORE ONLY ONE "WINDOW" WHICH SPANS THE ENTIRE C SUBSET. ON THE OTHER HAND, EACH DELAYED REPLICATION SEQUENCE C WITHIN A BUFR SUBSET CONSISTS OF SOME NUMBER OF "WINDOWS", WHICH C ARE A DE-FACTO SECOND DIMENSION OF THE SUBSET AND WHERE THE NUMBER C OF WINDOWS IS THE DELAYED DESCRIPTOR REPLICATION FACTOR (I.E. THE C NUMBER OF ITERATIONS) OF THE SEQUENCE. IF NESTED DELAYED C REPLICATION IS USED, THEN THERE MAY BE THREE OR MORE DIMENSIONS C WITHIN THE SUBSET. C C THIS ROUTINE CALLS: BORT INVWIN LSTJPB C THIS ROUTINE IS CALLED BY: CONWIN UFBEVN UFBIN3 UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRPC = LSTJPB(NODE,LUN,'RPC') IF(IRPC.EQ.0) THEN IWIN = INVWIN(NODE,LUN,JWIN,NVAL(LUN)) IF(IWIN.EQ.0 .and. JWIN.GT.1) GOTO 100 IWIN = 1 JWIN = NVAL(LUN) GOTO 100 ELSE IWIN = INVWIN(IRPC,LUN,JWIN,NVAL(LUN)) IF(IWIN.EQ.0) THEN GOTO 100 ELSEIF(VAL(IWIN,LUN).EQ.0.) THEN IWIN = 0 GOTO 100 ENDIF ENDIF JWIN = INVWIN(IRPC,LUN,IWIN+1,NVAL(LUN)) IF(JWIN.EQ.0) GOTO 900 C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: GETWIN - SEARCHED BETWEEN",I5," AND"'// . ',I5,", MISSING BRACKET")') IWIN+1,NVAL(LUN) CALL BORT(BORT_STR) END ./hold4wlc.f0000644001370400056700000000736513440555365011665 0ustar jator2emc SUBROUTINE HOLD4WLC(LUNIT,CHR,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: HOLD4WLC C PRGMMR: ATOR ORG: NP12 DATE: 2014-02-05 C C ABSTRACT: NORMALLY, A LONG CHARACTER STRING (I.E. LONGER THAN 8 C BYTES) IS STORED IN AN UNCOMPRESSED BUFR SUBSET FOR OUTPUT VIA A C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRITLC, AT A POINT AFTER THE C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRITSB (OR WRITSA) HAS C ALREADY BEEN MADE FOR THE SUBSET IN QUESTION. THIS WORKS FINE FOR C ALL CASES EXCEPT WHEN WRITSB (OR WRITSA) FLUSHES THE MESSAGE C CONTAINING THE SUBSET IN QUESTION TO THE BUFR OUTPUT STREAM DURING C THE SAME CALL TO WRITSB (OR WRITSA), SUCH AS WHEN A SUBSET HAS A C BYTE COUNT > 65530 BYTES. WHEN THIS HAPPENS, THERE IS NO LONGER ANY C WAY FOR A SUBSEQUENT WRITLC CALL TO STORE A LONG CHARACTER STRING IN C THE SUBSET, BECAUSE THE SUBSET HAS ALREADY BEEN FLUSHED FROM C INTERNAL MEMORY TO THE OUTPUT STREAM. THIS SUBROUTINE GETS AROUND C THAT PROBLEM, BY ALLOWING A LONG CHARACTER STRING TO BE SPECIFIED C AHEAD OF TIME (I.E. BEFORE CALLING WRITSB OR WRITSB), AND THE C CORRESPONDING VALUE WILL BE HELD AND STORED AUTOMATICALLY (VIA AN C INTERNAL CALL TO WRITLC) AT THE PROPER TIME DURING THE SUBSEQUENT C CALL TO WRITSB (OR WRITSA). IF MULTIPLE LONG CHARACTER STRINGS NEED C TO BE STORED IN A SUBSET, THEN A SEPARATE CALL TO THIS SUBROUTINE C SHOULD BE MADE FOR EACH SUCH STRING. C C PROGRAM HISTORY LOG: C 2014-02-05 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL HOLD4WLC(LUNIT,CHR,STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) C STR - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR C C REMARKS: C THIS ROUTINE CALLS: ERRWRT STRSUC C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_H4WLC INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT CHARACTER*(*) CHR,STR CHARACTER*128 ERRSTR CHARACTER*14 MYSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STRSUC( STR, MYSTR, LENS ) IF ( LENS .EQ. -1 ) RETURN LENC = MIN( LEN( CHR ), 120 ) C IF THIS SUBROUTINE HAS ALREADY BEEN CALLED WITH THIS MNEMONIC FOR C THIS PARTICULAR SUBSET, THEN OVERWRITE THE CORRESPONDING ENTRY IN C THE INTERNAL HOLDING AREA. IF ( NH4WLC .GT. 0 ) THEN DO I = 1, NH4WLC IF ( ( LUNIT .EQ. LUH4WLC(I) ) .AND. . ( MYSTR(1:LENS) .EQ. STH4WLC(I)(1:LENS) ) ) THEN CHH4WLC(I) = '' CHH4WLC(I)(1:LENC) = CHR(1:LENC) RETURN ENDIF ENDDO ENDIF C OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN THE HOLDING AREA. IF ( NH4WLC .GE. MXH4WLC ) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I3)' ) . 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', . 'STRINGS THAT CAN BE HELD INTERNALLY IS ', MXH4WLC CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ENDIF ELSE NH4WLC = NH4WLC + 1 LUH4WLC(NH4WLC) = LUNIT STH4WLC(NH4WLC) = '' STH4WLC(NH4WLC)(1:LENS) = MYSTR(1:LENS) CHH4WLC(NH4WLC) = '' CHH4WLC(NH4WLC)(1:LENC) = CHR(1:LENC) ENDIF RETURN END ./i4dy.f0000644001370400056700000000542113440555365011005 0ustar jator2emc FUNCTION I4DY(IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: I4DY C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 C C ABSTRACT: THIS FUNCTION CONVERTS AN EIGHT DIGIT INTEGER DATE C (YYMMDDHH) TO TEN DIGITS (YYYYMMDDHH) USING THE Y2K "WINDOWING" C TECHNIQUE. ALL TWO-DIGIT YEARS GREATER THAN "40" ARE ASSUMED TO C HAVE A FOUR-DIGIT YEAR BEGINNING WITH "19" (1941-1999) AND ALL TWO- C DIGIT YEARS LESS THAN OR EQUAL TO "40" ARE ASSUMED TO HAVE A FOUR- C DIGIT YEAR BEGINNING WITH "20" (2000-2040). IF THE INPUT DATE IS C ALREADY TEN DIGITS, THIS ROUTINE JUST RETURNS ITS VALUE. C C PROGRAM HISTORY LOG: C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-11-24 J. WOOLLEN -- MODIFIED TO CONFORM TO THE NCEP 2-DIGIT C YEAR TIME WINDOW OF 1921-2020 (BUT C INADVERTENTLY SET TO 1911-2010) C 1998-12-14 J. WOOLLEN -- MODIFIED TO USE 20 AS THE 2-DIGIT YEAR FOR C WINDOWING TO A 4-DIGIT YEAR (00-20 ==> ADD C 2000; 21-99 ==> ADD 1900), THIS WINDOWING C TECHNIQUE WAS INADVERTENTLY CHANGED TO 10 C IN THE PREVIOUS IMPLEMENTATION OF I4DY C (1998-11-24) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED DATE CALCULATIONS TO NO LONGER USE C FLOATING POINT ARITHMETIC SINCE THIS CAN C LEAD TO ROUND OFF ERROR AND AN IMPROPER C RESULTING DATE ON SOME MACHINES (E.G., C NCEP IBM FROST/SNOW), INCREASES C PORTABILITY; UNIFIED/PORTABLE FOR WRF; C ADDED DOCUMENTATION (INCLUDING HISTORY) C 2018-06-29 J. ATOR -- CHANGED 2-DIGIT->4-DIGIT YEAR WINDOW RANGE C TO (00-40 ==> ADD 2000; 41-99 ==> ADD 1900) C C USAGE: I4DY (IDATE) C INPUT ARGUMENT LIST: C IDATE - INTEGER: DATE (EITHER YYMMDDHH OR YYYYMMDDHH), C DEPENDING ON DATELEN() VALUE C C OUTPUT ARGUMENT LIST: C I4DY - INTEGER: DATE (YYYYMMDDHH) C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CKTABA CMSGINI DATEBF DUMPBF C IUPBS01 OPENMB OPENMG REWNBF C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ IF(IDATE.LT.10**8) THEN IY = IDATE/10**6 IF(IY.GT.40) THEN I4DY = IDATE + 19*100000000 ELSE I4DY = IDATE + 20*100000000 ENDIF ELSE I4DY = IDATE ENDIF RETURN END ./ibfms.f0000644001370400056700000000331113440555365011230 0ustar jator2emc INTEGER FUNCTION IBFMS ( R8VAL ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IBFMS C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT VALUE IS EQUIVALENT C TO THE BUFR ARCHIVE LIBRARY "MISSING" VALUE. THE USE OF INTEGER C RETURN CODES ALLOWS THIS FUNCTION TO BE CALLED IN A LOGICAL C CONTEXT FROM A CALLING PROGRAM WRITTEN IN C. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C 2009-03-23 J. ATOR -- INCREASED VALUE OF BDIFD FOR BETTER C TEST ACCURACY C 2012-10-05 J. ATOR -- MODIFIED TO REFLECT THE FACT THAT THE C "MISSING" VALUE IS NOW CONFIGURABLE BY C USERS (MAY BE SOMETHING OTHER THAN 10E10) C C USAGE: IBFMS ( R8VAL ) C INPUT ARGUMENT LIST: C R8VAL - REAL*8: VALUE TO BE TESTED FOR EQUIVALENCE TO C BUFR ARCHIVE LIBRARY "MISSING" VALUE C C OUTPUT ARGUMENT LIST: C IBFMS - INTEGER: RETURN CODE: C 0 - R8VAL IS NOT EQUIVALENT TO "MISSING" C 1 - R8VAL IS EQUIVALENT TO "MISSING" C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: INVMRG STRBTM UFBDMP UFBRW C UFDUMP WRTREE C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' REAL*8 R8VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF ( R8VAL .EQ. BMISS ) THEN IBFMS = 1 ELSE IBFMS = 0 ENDIF RETURN END ./icbfms.f0000644001370400056700000000560313440555365011401 0ustar jator2emc INTEGER FUNCTION ICBFMS ( STR, LSTR ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ICBFMS C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-06-07 C C ABSTRACT: THIS FUNCTION TESTS WHETHER THE INPUT CHARACTER STRING C IS "MISSING" BY CHECKING IF ALL OF THE EQUIVALENT BITS ARE SET TO 1. C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION IBFMS, EXCEPT THAT C IBFMS TESTS REAL*8 VALUES FOR EQUIVALENCE TO THE PARAMETER BMISS, C WHEREAS ICBFMS CHECKS THAT ALL EQUIVALENT BITS ARE SET TO 1 AND IS C THEREFORE A MORE PORTABLE AND RELIABLE TEST FOR USE WITH CHARACTER C STRINGS. C C PROGRAM HISTORY LOG: C 2012-06-07 J. ATOR -- ORIGINAL AUTHOR C 2015-03-10 J. WOOLLEN -- IMPROVED LOGIC FOR TESTING LEGACY CASES C PRIOR TO BUFRLIB V10.2.0 C 2016-02-12 J. ATOR -- MODIFIED FOR CRAYFTN COMPATIBILITY C C USAGE: ICBFMS ( STR, LSTR ) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING TO BE TESTED C LSTR - INTEGER: NUMBER OF CHARACTERS TO BE TESTED WITHIN STR C C OUTPUT ARGUMENT LIST: C ICBFMS - INTEGER: RETURN CODE: C 0 - STR IS NOT "MISSING" C 1 - STR IS "MISSING" C C REMARKS: C THIS ROUTINE CALLS: IUPM C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFDUMP C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' CHARACTER*(*) STR CHARACTER*8 STRZ REAL*8 RL8Z CHARACTER*16 ZZ CHARACTER*16 ZM_BE PARAMETER ( ZM_BE = '202020E076483742' ) C* 10E10 stored as hexadecimal on a big-endian system. CHARACTER*16 ZM_LE PARAMETER ( ZM_LE = '42374876E8000000' ) C* 10E10 stored as hexadecimal on a little-endian system. EQUIVALENCE(STRZ,RL8Z) C----------------------------------------------------------------------- ICBFMS = 0 NUMCHR = MIN(LSTR,LEN(STR)) C* Beginning with version 10.2.0 of the BUFRLIB, "missing" strings C* have always been explicitly encoded with all bits set to 1, C* which is the correct encoding per WMO regulations. However, C* prior to version 10.2.0, the BUFRLIB stored "missing" strings by C* encoding the REAL*8 value of 10E10 into the string, so the C* following logic attempts to identify some of these earlier C cases, at least for strings between 4 and 8 bytes in length. IF ( NUMCHR.GE.4 .AND. NUMCHR.LE.8 ) THEN DO II = 1, NUMCHR STRZ(II:II) = STR(II:II) END DO WRITE (ZZ,'(Z16.16)') RL8Z I = 2*(8-NUMCHR)+1 N = 16 IF ( ZZ(I:N).EQ.ZM_BE(I:N) .OR. ZZ(I:N).EQ.ZM_LE(I:N) ) THEN ICBFMS = 1 RETURN END IF END IF C* Otherwise, the logic below will check for "missing" strings of C* any length which are correctly encoded with all bits set to 1, C* including those encoded by BUFRLIB version 10.2.0 or later. DO I=1,NUMCHR IF ( IUPM(STR(I:I),8).NE.255 ) RETURN ENDDO ICBFMS = 1 RETURN END ./ichkstr.f0000644001370400056700000000365713440555365011614 0ustar jator2emc FUNCTION ICHKSTR(STR,CHR,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ICHKSTR C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION COMPARES A SPECIFIED NUMBER OF CHARACTERS C FROM AN INPUT CHARACTER ARRAY AGAINST THE SAME NUMBER OF CHARACTERS C FROM AN INPUT CHARACTER STRING AND DETERMINES WHETHER THE TWO ARE C EQUIVALENT. THE CHARACTER ARRAY IS ASSUMED TO BE IN ASCII, WHEREAS C THE CHARACTER STRING IS ASSUMED TO BE IN THE NATIVE CHARACTER SET C (I.E. ASCII OR EBCDIC) OF THE LOCAL MACHINE. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: ICHKSTR (STR, CHR, N) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): N-CHARACTER STRING IN ASCII OR EBCDIC, C DEPENDING ON THE NATIVE MACHINE C CHR - CHARACTER*1: ARRAY OF N CHARACTERS IN ASCII C N - INTEGER: NUMBER OF CHARACTERS TO BE COMPARED C C OUTPUT ARGUMENT LIST: C ICHKSTR - INTEGER: RETURN VALUE: C 0 = STR(1:N) AND (CHR(I),I=1,N) ARE EQUIVALENT C 1 = STR(1:N) AND (CHR(I),I=1,N) ARE NOT EQUIVALENT C C REMARKS: C THIS ROUTINE CALLS: CHRTRNA C THIS ROUTINE IS CALLED BY: CRBMG READERME C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*80 CSTR CHARACTER*1 CHR(N) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Copy CHR into CSTR and, if necessary, convert the latter C to EBCDIC (i.e. if the local machine uses EBCDIC) so that C the subsequent comparison will always be valid. CALL CHRTRNA(CSTR,CHR,N) C Compare CSTR to STR. IF(CSTR(1:N).EQ.STR(1:N)) THEN ICHKSTR = 0 ELSE ICHKSTR = 1 ENDIF RETURN END ./icmpdx.f0000644001370400056700000000520013440555365011413 0ustar jator2emc INTEGER FUNCTION ICMPDX(LUD,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ICMPDX C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-18 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) C HAS THE SAME INTERNAL TABLE INFORMATION AS LOGICAL UNIT IOLUN(LUD). C NOTE THAT THIS DOES NOT NECESSARILY MEAN THAT IOLUN(LUN) AND C IOLUN(LUD) ARE SHARING TABLE INFORMATION, SINCE TWO LOGICAL UNITS C CAN HAVE THE SAME INTERNAL TABLE INFORMATION WITHOUT SHARING IT. C C PROGRAM HISTORY LOG: C 2009-06-18 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: ICMPDX (LUD, LUN) C INPUT ARGUMENT LIST: C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR FIRST LOGICAL UNIT C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR SECOND LOGICAL UNIT C C OUTPUT ARGUMENT LIST: C ICMPDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) C HAS THE SAME INTERNAL TABLE INFORMATION AS IOLUN(LUD): C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: ISHRDX C THIS ROUTINE IS CALLED BY: IOK2CPY MAKESTAB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C First, check whether the two units are actually sharing tables. C If so, then they obviously have the same table information. ICMPDX = ISHRDX(LUD,LUN) IF ( ICMPDX .EQ. 1 ) RETURN C Otherwise, check whether the internal Table A, B and D entries are C all identical between the two units. IF ( ( NTBA(LUD) .EQ. 0 ) .OR. . ( NTBA(LUN) .NE. NTBA(LUD) ) ) RETURN DO I = 1, NTBA(LUD) IF ( IDNA(I,LUN,1) .NE. IDNA(I,LUD,1) ) RETURN IF ( IDNA(I,LUN,2) .NE. IDNA(I,LUD,2) ) RETURN IF ( TABA(I,LUN) .NE. TABA(I,LUD) ) RETURN ENDDO IF ( ( NTBB(LUD) .EQ. 0 ) .OR. . ( NTBB(LUN) .NE. NTBB(LUD) ) ) RETURN DO I = 1, NTBB(LUD) IF ( IDNB(I,LUN) .NE. IDNB(I,LUD) ) RETURN IF ( TABB(I,LUN) .NE. TABB(I,LUD) ) RETURN ENDDO IF ( ( NTBD(LUD) .EQ. 0 ) .OR. . ( NTBD(LUN) .NE. NTBD(LUD) ) ) RETURN DO I = 1, NTBD(LUD) IF ( IDND(I,LUN) .NE. IDND(I,LUD) ) RETURN IF ( TABD(I,LUN) .NE. TABD(I,LUD) ) RETURN ENDDO ICMPDX = 1 RETURN END ./icopysb.f0000644001370400056700000000305413440555365011604 0ustar jator2emc FUNCTION ICOPYSB(LUNIN,LUNOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ICOPYSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE COPYSB C AND PASSES BACK ITS RETURN CODE. SEE COPYSB FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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) C C USAGE: ICOPYSB (LUNIN, LUNOT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C OUTPUT ARGUMENT LIST: C ICOPYSB - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the input C BUFR message C C REMARKS: C THIS ROUTINE CALLS: COPYSB C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CALL COPYSB(LUNIN,LUNOT,IRET) ICOPYSB = IRET RETURN END ./icvidx.c0000644001370400056700000000213613440555365011417 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ICVIDX C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS ROUTINE COMPUTES A UNIQUE 1-DIMENSIONAL ARRAY C INDEX FROM 2-DIMENSIONAL INDICES. THIS ALLOWS A 2-DIMENSIONAL C (ROW-BY-COLUMN) ARRAY TO BE STORED AND ACCESSED AS A C 1-DIMENSIONAL ARRAY. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL ICVIDX( II, JJ, NUMJJ ) C INPUT ARGUMENT LIST: C II - INTEGER: FIRST (ROW) INDEX C JJ - INTEGER: SECOND (COLUMN) INDEX C NUMJJ - INTEGER: MAXIMUM NUMBER OF COLUMN INDICES C C OUTPUT ARGUMENT LIST: C ICVIDX - INTEGER: 1-DIMENSIONAL INDEX C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CPMSTABS IREADMT STSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" f77int icvidx( f77int *ii, f77int *jj, f77int *numjj ) { return ( *numjj * (*ii) ) + *jj; } ./idn30.f0000644001370400056700000000515113440555365011051 0ustar jator2emc FUNCTION IDN30(ADN30,L30) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IDN30 C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CONVERTS A DESCRIPTOR FROM ITS FIVE OR SIX C CHARACTER ASCII REPRESENTATION TO ITS BIT-WISE (INTEGER) C REPRESENTATION. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C USAGE: IDN30 (ADN30, L30) C INPUT ARGUMENT LIST: C ADN30 - CHARACTER*(*): CHARACTER FORM OF DESCRIPTOR (FXY C VALUE) C L30 - INTEGER: LENGTH OF ADN30 (NUMBER OF CHARACTERS, 5 OR C 6) C C OUTPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) C VALUE C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT IFXY C THIS ROUTINE IS CALLED BY: STBFDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*(*) ADN30 CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(LEN(ADN30).LT.L30) GOTO 900 IF(L30.EQ.5) THEN READ(ADN30,'(I5)') IDN30 IF(IDN30.LT.0 .OR. IDN30.GT.65535) GOTO 901 ELSEIF(L30.EQ.6) THEN IDN30 = IFXY(ADN30) ELSE GOTO 902 ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// . '" CHARACTER LENGTH (",I4,") IS TOO SHORT (< L30,",I5)') . ADN30,LEN(ADN30),L30 CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: IDN30 - DESCRIPTOR INTEGER '// . 'REPRESENTATION, IDN30 (",I8,"), IS OUTSIDE 16-BIT RANGE '// . '(0-65535)")') IDN30 CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A,'// . '" CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') . ADN30,L30 CALL BORT(BORT_STR) END ./idxmsg.f0000644001370400056700000000323713440555365011432 0ustar jator2emc FUNCTION IDXMSG( MESG ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IDXMSG C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER THE GIVEN BUFR MESSAGE C IS A DX DICTIONARY MESSAGE THAT WAS CREATED BY THE BUFR ARCHIVE C LIBRARY SOFTWARE. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IDXMSG( MESG ) C INPUT ARGUMENT LIST: C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C C OUTPUT ARGUMENT LIST: C IDXMSG - INTEGER: RETURN VALUE: C 0 - MESG IS NOT A DX DICTIONARY MESSAGE C 1 - MESG IS A DX DICTIONARY MESSAGE C C REMARKS: C THIS ROUTINE CALLS: IUPBS01 C THIS ROUTINE IS CALLED BY: CPDXMM DATEBF DUMPBF MESGBC C MESGBF MSGWRT RDBFDX READMG C POSAPX READERME UFBMEM C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MESG(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Note that the following test relies upon logic within subroutine C DXMINI which zeroes out the Section 1 date of all DX dictionary C messages. IF ( (IUPBS01(MESG,'MTYP').EQ.11) .AND. . (IUPBS01(MESG,'MNTH').EQ.0) .AND. . (IUPBS01(MESG,'DAYS').EQ.0) .AND. . (IUPBS01(MESG,'HOUR').EQ.0) ) THEN IDXMSG = 1 ELSE IDXMSG = 0 END IF RETURN END ./ifbget.f0000644001370400056700000000550213440555365011374 0ustar jator2emc FUNCTION IFBGET(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IFBGET C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CHECKS TO SEE IF ANY UNREAD SUBSETS ARE IN C AN INPUT BUFR MESSAGE PREVIOUSLY OPENED BY BUFR ARCHIVE LIBRARY C SUBROUTINE OPENMG OR OPENMB. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 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 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: IFBGET (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C IFBGET - INTEGER: RETURN CODE: C 0 = there is at least one more subset in the C message C -1 = there are no more subsets in the message C C REMARKS: C THIS ROUTINE CALLS: BORT STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT C ------------------------------------------ CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- IF(NSUB(LUN).LT.MSUB(LUN)) THEN IFBGET = 0 ELSE IFBGET = -1 ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') END ./ifxy.f0000644001370400056700000000375513440555365011123 0ustar jator2emc FUNCTION IFXY(ADSC) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IFXY C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION RETURNS THE INTEGER CORRESPONDING TO THE C BIT-WISE REPRESENTATION OF AN INPUT CHARACTER FXY VALUE OF LENGTH C SIX. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C C USAGE: IFXY (ADSC) C INPUT ARGUMENT LIST: C ADSC - CHARACTER*6: CHARACTER FORM OF DESCRIPTOR (FXY VALUE) C C OUTPUT ARGUMENT LIST: C IFXY - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) C VALUE C C REMARKS: C C EXAMPLE: C C If ADSC = '063022', then IFXY = 16150 since: C C 0 63 22 C C F | X | Y C | | C 0 0 1 1 1 1 1 1 0 0 0 1 0 1 1 0 = C C ( 2**13 + 2**12 + 2**11 + 2**10 + C 2**9 + 2**8 + 2**4 + 2**2 + 2**1 ) = 16150 C C C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: BFRINI DXINIT GETNTBE GETCFMNG C IDN30 IREADMT NEMTAB NEMTBB C NEMTBD NUMTBD READS3 RESTD C SNTBDE SNTBFE STBFDX STNTBI C STSEQ UFBQCP C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*6 ADSC C---------------------------------------------------------------------- C---------------------------------------------------------------------- READ(ADSC,'(I1,I2,I3)') IF,IX,IY IFXY = IF*2**14 + IX*2**8 + IY RETURN END ./igetdate.f0000644001370400056700000000347313440555365011727 0ustar jator2emc FUNCTION IGETDATE(MBAY,IYR,IMO,IDY,IHR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETDATE C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS THE SECTION 1 DATE-TIME C FROM THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL WORK ON ANY C MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START OF THE C BUFR MESSAGE, (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE FIRST C FOUR BYTES OF MBAY. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETDATE (MBAY, IYR, IMO, IDY, IHR) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C C OUTPUT ARGUMENT LIST: C IYR - INTEGER: SECTION 1 YEAR (YYYY OR YY, DEPENDING ON C DATELEN() VALUE) C IMO - INTEGER: SECTION 1 MONTH (MM) C IDY - INTEGER: SECTION 1 DAY (DD) C IHR - INTEGER: SECTION 1 HOUR (HH) C IGETDATE - INTEGER: SECTION 1 DATE-TIME (YYYYMMDDHH OR YYMMDDHH, C DEPENDING ON DATELEN() VALUE) C C REMARKS: C THIS ROUTINE CALLS: IUPBS01 C THIS ROUTINE IS CALLED BY: CKTABA DATEBF DUMPBF C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /DATELN/ LENDAT DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IYR = IUPBS01(MBAY,'YEAR') IMO = IUPBS01(MBAY,'MNTH') IDY = IUPBS01(MBAY,'DAYS') IHR = IUPBS01(MBAY,'HOUR') IF(LENDAT.NE.10) THEN IYR = MOD(IYR,100) ENDIF IGETDATE = (IYR*1000000) + (IMO*10000) + (IDY*100) + IHR RETURN END ./igetfxy.f0000644001370400056700000000371013440555365011612 0ustar jator2emc FUNCTION IGETFXY ( STR, CFXY ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETFXY C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS A VALID FXY NUMBER C FROM WITHIN THE GIVEN INPUT STRING. THE FXY NUMBER MAY BE IN C FORMAT OF EITHER FXXYYY OR F-XX-YYY WITHIN THE INPUT STRING, BUT C IT IS ALWAYS RETURNED IN FORMAT FXXYYY UPON OUTPUT. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETFXY ( STR, CFXY ) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): INPUT STRING C C OUTPUT ARGUMENT LIST: C CFXY - CHARACTER*6: FXY NUMBER IN FORMAT FXXYYY C IGETFXY - INTEGER: RETURN CODE: C 0 = normal return C -1 = could not find a valid FXY number in STR C C REMARKS: C THIS ROUTINE CALLS: JSTCHR NUMBCK C THIS ROUTINE IS CALLED BY: GETNTBE SNTBDE SNTBFE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*6 CFXY PARAMETER ( LSTR2 = 120 ) CHARACTER*(LSTR2) STR2 C----------------------------------------------------------------------- C----------------------------------------------------------------------- IGETFXY = -1 LSTR = LEN ( STR ) IF ( LSTR .LT. 6 ) RETURN C Left-justify a copy of the input string. IF ( LSTR .GT. LSTR2 ) THEN STR2(1:LSTR2) = STR(1:LSTR2) ELSE STR2 = STR ENDIF CALL JSTCHR ( STR2, IRET ) IF ( IRET .NE. 0 ) RETURN C Look for an FXY number. IF ( INDEX ( STR2, '-' ) .NE. 0 ) THEN C Format of field is F-XX-YYY. CFXY(1:1) = STR2(1:1) CFXY(2:3) = STR2(3:4) CFXY(4:6) = STR2(6:8) ELSE C Format of field is FXXYYY. CFXY = STR2(1:6) ENDIF C Check that the FXY number is valid. IF ( NUMBCK ( CFXY ) .EQ. 0 ) IGETFXY = 0 RETURN END ./igetmxby.f0000644001370400056700000000254013440555365011763 0ustar jator2emc INTEGER FUNCTION IGETMXBY() C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETMXBY C PRGMMR: WOOLLEN ORG: NCEP DATE: 2016-06-27 C C ABSTRACT: IGETMXBY RETURNS THE CURRENT VALUE OF MAXBYT, WHICH IS THE C MAXIMUM LENGTH OF A BUFRLIB MESSAGE THAT CAN BE WRITTEN C TO AN OUTPUT STREAM. THIS VALUE IS SET TO A DEFAULT VALUE C OF MIN(10000,MXMSGL) IN SUBROUTINE BFRINI, BUT APPLICATION C PROGRAMS MAY SET IT TO A DIFFERENT VALUE VIA A CALL TO C SUBROUTINE MAXOUT. C C PROGRAM HISTORY LOG: C 2016-06-27 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETMXBY() C C INPUT ARGUMENTS: C C OUTPUT ARGUMENTS: C IGETMXBY - INTEGER: CURRENT VALUE OF MAXBYT = MAXIMUM LENGTH OF C A BUFRLIB MESSAGE THAT CAN BE WRITTEN TO OUTPUT C C REMARKS: C THIS ROUTINE CALLS: OPENBF C C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BITBUF INCLUDE 'bufrlib.prm' c----------------------------------------------------------------------- c----------------------------------------------------------------------- CALL OPENBF(0,'FIRST',0) IGETMXBY = MAXBYT RETURN END ./igetntbi.f0000644001370400056700000000333313440555365011741 0ustar jator2emc FUNCTION IGETNTBI ( LUN, CTB ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETNTBI C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS FUNCTION RETURNS THE NEXT AVAILABLE INDEX FOR C STORING AN ENTRY WITHIN INTERNAL BUFR TABLE CTB. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL IGETNTBI ( LUN, CTB ) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C CTB - CHARACTER*1: INTERNAL BUFR TABLE FROM WHICH TO RETURN C THE NEXT AVAILABLE INDEX ('A','B', OR 'D') C C OUTPUT ARGUMENT LIST: C IGETNTBI - INTEGER: NEXT AVAILABLE INDEX IN TABLE CTB C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX STSEQ C Not normally called by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*1 CTB C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( CTB .EQ. 'A' ) THEN IGETNTBI = NTBA(LUN) + 1 IMAX = NTBA(0) ELSE IF ( CTB .EQ. 'B' ) THEN IGETNTBI = NTBB(LUN) + 1 IMAX = NTBB(0) ELSE IF ( CTB .EQ. 'D' ) THEN IGETNTBI = NTBD(LUN) + 1 IMAX = NTBD(0) ENDIF IF ( IGETNTBI .GT. IMAX ) GOTO 900 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: IGETNTBI - NUMBER OF INTERNAL TABLE' . //'",A1," ENTRIES EXCEEDS THE LIMIT (",I4,")")') CTB, IMAX CALL BORT(BORT_STR) END ./igetntbl.f0000644001370400056700000000325613440555365011750 0ustar jator2emc FUNCTION IGETNTBL ( LUNT, LINE ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETNTBL C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS FUNCTION GETS THE NEXT LINE FROM THE ASCII MASTER C TABLE FILE SPECIFIED BY LUNT, IGNORING ANY BLANK LINES OR COMMENT C LINES IN THE PROCESS. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETNTBL ( LUNT, LINE ) C INPUT ARGUMENT LIST: C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING MASTER TABLE INFORMATION C C OUTPUT ARGUMENT LIST: C LINE - CHARACTER*(*): NEXT NON-BLANK, NON-COMMENT LINE READ C FROM LUNT C IGETNTBL - INTEGER: RETURN CODE: C 0 = normal return C -1 = end-of-file encountered while reading C from LUNT C -2 = I/O error encountered while reading C from LUNT C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: GETNTBE GETTBH SNTBDE SNTBFE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) LINE C----------------------------------------------------------------------- C----------------------------------------------------------------------- 10 READ ( LUNT, '(A)', END=100, ERR=200 ) LINE IF ( ( LINE .EQ. ' ' ) .OR. ( LINE(1:1) .EQ. '#' ) ) GOTO 10 IF ( LINE(1:3) .EQ. 'END' ) GOTO 100 IGETNTBL = 0 RETURN 100 IGETNTBL = -1 RETURN 200 IGETNTBL = -2 RETURN END ./igetprm.f0000644001370400056700000001443213440555365011605 0ustar jator2emc INTEGER FUNCTION IGETPRM ( CPRMNM ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETPRM C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: THIS FUNCTION RETURNS THE VALUE ASSOCIATED WITH A C SPECIFIED PARAMETER. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETPRM ( CPRMNM ) C INPUT ARGUMENT LIST: C CPRMNM - CHARACTER*(*): PARAMETER C 'MXMSGL' = MAXIMUM LENGTH (IN BYTES) OF A BUFR C MESSAGE C 'MAXSS' = MAXIMUM NUMBER OF DATA VALUES IN AN C UNCOMPRESSED BUFR SUBSET C 'MXCDV' = MAXIMUM NUMBER OF DATA VALUES THAT CAN BE C WRITTEN INTO A COMPRESSED BUFR SUBSET C 'MXLCC' = MAXIMUM LENGTH (IN BYTES) OF A CHARACTER C STRING THAT CAN BE WRITTEN INTO A C COMPRESSED BUFR SUBSET C 'MXCSB' = MAXIMUM NUMBER OF SUBSETS THAT CAN BE C WRITTEN INTO A COMPRESSED BUFR MESSAGE C 'NFILES' = MAXIMUM NUMBER OF BUFR FILES THAT CAN BE C ACCESSED FOR READING OR WRITING AT ANY C ONE TIME C 'MAXTBA' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE A PER BUFR FILE C 'MAXTBB' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE B PER BUFR FILE C 'MAXTBD' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE D PER BUFR FILE C 'MAXMEM' = MAXIMUM NUMBER OF BYTES THAT CAN BE USED C TO STORE BUFR MESSAGES IN INTERNAL MEMORY C 'MAXMSG' = MAXIMUM NUMBER OF BUFR MESSAGES THAT CAN C BE STORED IN INTERNAL MEMORY C 'MXDXTS' = MAXIMUM NUMBER OF DICTIONARY TABLES THAT C CAN BE STORED FOR USE WITH BUFR MESSAGES C IN INTERNAL MEMORY C 'MXMTBB' = MAXIMUM NUMBER OF MASTER TABLE B ENTRIES C 'MXMTBD' = MAXIMUM NUMBER OF MASTER TABLE D ENTRIES C 'MXMTBF' = MAXIMUM NUMBER OF MASTER CODE/FLAG ENTRIES C 'MAXCD' = MAXIMUM NUMBER OF CHILD DESCRIPTORS IN A C TABLE D DESCRIPTOR SEQUENCE DEFINITION C 'MAXJL' = MAXIMUM NUMBER OF ENTRIES IN THE INTERNAL C JUMP/LINK TABLE C 'MXS01V' = MAXIMUM NUMBER OF DEFAULT SECTION 0 OR C SECTION 1 VALUES THAT CAN BE OVERWRITTEN C WITHIN AN OUTPUT BUFR MESSAGE C 'MXBTM' = MAXIMUM NUMBER OF BITMAPS THAT CAN BE C STORED INTERNALLY FOR A BUFR SUBSET C 'MXBTMSE' = MAXIMUM NUMBER OF ENTRIES THAT CAN BE C SET WITHIN A BITMAP C 'MXTAMC' = MAXIMUM NUMBER OF TABLE A MNEMONICS IN THE C INTERNAL JUMP/LINK TABLE WHICH CONTAIN AT C LEAST ONE TABLE C OPERATOR WITH X>=21 IN C THEIR SUBSET DEFINITION C 'MXTCO' = MAXIMUM NUMBER OF TABLE C OPERATORS (WITH C X>=21) IN THE SUBSET DEFINITION OF A C TABLE A MNEMONIC C 'MXNRV' = MAXIMUM NUMBER OF 2-03 REFERENCE VALUES C IN THE INTERNAL JUMP/LINK TABLE C 'MXRST' = MAXIMUM NUMBER OF LONG CHARACTER STRINGS C THAT CAN BE READ FROM A COMPRESSED SUBSET C C OUTPUT ARGUMENT LIST: C IGETPRM - INTEGER: VALUE ASSOCIATED WITH CPRMNM C -1 = UNKNOWN CPRNMN C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: ARALLOCC INITTBF STSEQ C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MAXSS USE MODV_NFILES USE MODV_MXMSGL USE MODV_MXDXTS USE MODV_MAXMSG USE MODV_MAXMEM USE MODV_MAXTBA USE MODV_MAXTBB USE MODV_MAXTBD USE MODV_MAXJL USE MODV_MXCDV USE MODV_MXLCC USE MODV_MXCSB USE MODV_MXMTBB USE MODV_MXMTBD USE MODV_MXMTBF USE MODV_MAXCD USE MODV_MXS01V USE MODV_MXBTM USE MODV_MXBTMSE USE MODV_MXTAMC USE MODV_MXTCO USE MODV_MXNRV USE MODV_MXRST INCLUDE 'bufrlib.prm' CHARACTER*(*) CPRMNM CHARACTER*64 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( CPRMNM .EQ. 'MAXSS' ) THEN IGETPRM = MAXSS ELSE IF ( CPRMNM .EQ. 'NFILES' ) THEN IGETPRM = NFILES ELSE IF ( CPRMNM .EQ. 'MXMSGL' ) THEN IGETPRM = MXMSGL ELSE IF ( CPRMNM .EQ. 'MXDXTS' ) THEN IGETPRM = MXDXTS ELSE IF ( CPRMNM .EQ. 'MAXMSG' ) THEN IGETPRM = MAXMSG ELSE IF ( CPRMNM .EQ. 'MAXMEM' ) THEN IGETPRM = MAXMEM ELSE IF ( CPRMNM .EQ. 'MAXTBA' ) THEN IGETPRM = MAXTBA ELSE IF ( CPRMNM .EQ. 'MAXTBB' ) THEN IGETPRM = MAXTBB ELSE IF ( CPRMNM .EQ. 'MAXTBD' ) THEN IGETPRM = MAXTBD ELSE IF ( CPRMNM .EQ. 'MAXJL' ) THEN IGETPRM = MAXJL ELSE IF ( CPRMNM .EQ. 'MXCDV' ) THEN IGETPRM = MXCDV ELSE IF ( CPRMNM .EQ. 'MXLCC' ) THEN IGETPRM = MXLCC ELSE IF ( CPRMNM .EQ. 'MXCSB' ) THEN IGETPRM = MXCSB ELSE IF ( CPRMNM .EQ. 'MXMTBB' ) THEN IGETPRM = MXMTBB ELSE IF ( CPRMNM .EQ. 'MXMTBD' ) THEN IGETPRM = MXMTBD ELSE IF ( CPRMNM .EQ. 'MXMTBF' ) THEN IGETPRM = MXMTBF ELSE IF ( CPRMNM .EQ. 'MAXCD' ) THEN IGETPRM = MAXCD ELSE IF ( CPRMNM .EQ. 'MXS01V' ) THEN IGETPRM = MXS01V ELSE IF ( CPRMNM .EQ. 'MXBTM' ) THEN IGETPRM = MXBTM ELSE IF ( CPRMNM .EQ. 'MXBTMSE' ) THEN IGETPRM = MXBTMSE ELSE IF ( CPRMNM .EQ. 'MXTAMC' ) THEN IGETPRM = MXTAMC ELSE IF ( CPRMNM .EQ. 'MXTCO' ) THEN IGETPRM = MXTCO ELSE IF ( CPRMNM .EQ. 'MXNRV' ) THEN IGETPRM = MXNRV ELSE IF ( CPRMNM .EQ. 'MXRST' ) THEN IGETPRM = MXRST ELSE IGETPRM = -1 CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') ERRSTR = 'BUFRLIB: IGETPRM - UNKNOWN INPUT PARAMETER '// . CPRMNM CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') ENDIF RETURN END ./igetrfel.f0000644001370400056700000001676013440555365011745 0ustar jator2emc INTEGER FUNCTION IGETRFEL ( N, LUN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETRFEL C PRGMMR: J. ATOR ORG: NCEP DATE: 2016-05-27 C C ABSTRACT: THIS FUNCTION CHECKS WHETHER THE INPUT ELEMENT REFERS TO C A PREVIOUS ELEMENT WITHIN THE SAME SUBSET VIA AN INTERNAL BITMAP. C IF SO, THEN THE REFERENCED ELEMENT IS RETURNED. IN ADDITION, IF C THE INPUT ELEMENT IS A 2-XX-255 MARKER OPERATOR, ITS SCALE FACTOR, C BIT WIDTH AND REFERENCE VALUE ARE SET INTERNALLY TO MATCH THOSE C OF THE REFERENCED ELEMENT. C C PROGRAM HISTORY LOG: C 2016-05-27 J. ATOR -- ORIGINAL AUTHOR C 2017-04-03 J. ATOR -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT C EACH SUBSET DEFINITION IN THE JUMP/LINK C TABLE HAS ITS OWN SET OF TABLE C OPERATORS C C USAGE: CALL IGETRFEL ( N, LUN ) C INPUT ARGUMENT LIST: C N - INTEGER: SUBSET ELEMENT C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C IGETRFEL - INTEGER: SUBSET ELEMENT REFERENCED BY ELEMENT N C WITHIN THE SAME SUBSET C 0 = INPUT ELEMENT DOES NOT REFER TO A PREVIOUS C ELEMENT, OR REFERENCED ELEMENT NOT FOUND C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT IBFMS IMRKOPR C LSTJPB NEMTAB C THIS ROUTINE IS CALLED BY: RCSTPL RDCMPS C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_USRINT USE MODA_TABLES USE MODA_BITMAPS USE MODA_NRV203 INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*6 CFLWOPR,ADN30,FXY CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- IGETRFEL = 0 NODE = INV( N, LUN ) IF ( ITP(NODE) .GT. 1 ) THEN IF ( NODE .EQ. LSTNOD ) THEN LSTNODCT = LSTNODCT + 1 ELSE LSTNOD = NODE LSTNODCT = 1 END IF C C Does this subset definition contain any Table C operators C with an X value of 21 or greater? C IDXTA = 0 IF ( NTAMC .GT. 0 ) THEN NODTAM = LSTJPB( NODE, LUN, 'SUB' ) DO II = 1, NTAMC IF ( NODTAM .EQ. INODTAMC(II) ) THEN IDXTA = II NTC = NTCO(II) END IF END DO END IF IF ( ( IDXTA .GT. 0 ) .AND. ( NBTM .GT. 0 ) ) THEN C Check whether this element references a previous element C in the same subset via an internal bitmap. To do this, C we first need to determine the appropriate "follow" C operator (if any) corresponding to this element. CFLWOPR = 'XXXXXX' IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) THEN CFLWOPR = TAG(NODE)(1:3) // '000' ELSE CALL NEMTAB( LUN, TAG(NODE), IDN, TAB, NN ) IF ( TAB .EQ. 'B' ) THEN FXY = ADN30(IDN,6) IF ( FXY(2:3) .EQ. '33' ) CFLWOPR = '222000' END IF END IF IF ( CFLWOPR .EQ. 'XXXXXX' ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 900 RETURN END IF C Now, check whether the appropriate "follow" operator was C actually present in the subset. If there are multiple C occurrences, we want the one that most recently precedes C the element in question. NODFLW = 0 DO JJ = 1, NTC IF ( ( CTCO(IDXTA,JJ) .EQ. CFLWOPR ) .AND. . ( INODTCO(IDXTA,JJ) .GE. INODE(LUN) ) .AND. . ( INODTCO(IDXTA,JJ) .LE. ISC(INODE(LUN)) ) .AND. . ( INODTCO(IDXTA,JJ) .LT. NODE ) ) . NODFLW = INODTCO(IDXTA,JJ) ENDDO IF ( NODFLW .EQ. 0 ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 901 RETURN END IF C We found an appropriate corresponding "follow" operator, C so now we need to look for a bitmap corresponding to C this operator. First, look for a bitmap indicator. NODL236 = 0 NODBMAP = 0 JJ = 1 DO WHILE ( ( JJ .LE. NTC ) .AND. . ( INODTCO(IDXTA,JJ) .GE. INODE(LUN) ) .AND. . ( INODTCO(IDXTA,JJ) .LE. ISC(INODE(LUN)) ) .AND. . ( NODBMAP .EQ. 0 ) ) IF ( CTCO(IDXTA,JJ) .EQ. '236000' ) THEN NODL236 = INODTCO(IDXTA,JJ) IF ( INODTCO(IDXTA,JJ) .EQ. NODFLW ) THEN NODBMAP = NODFLW END IF ELSE IF ( ( CTCO(IDXTA,JJ) .EQ. '235000' ) .OR. . ( CTCO(IDXTA,JJ) .EQ. '237255' ) ) THEN NODL236 = 0 ELSE IF ( ( CTCO(IDXTA,JJ) .EQ. '237000' ) .AND. . ( INODTCO(IDXTA,JJ) .EQ. NODFLW ) .AND. . ( NODL236 .NE. 0 ) ) THEN NODBMAP = NODL236 END IF JJ = JJ + 1 END DO IF ( NODBMAP .EQ. 0 ) THEN C There was no valid bitmap indicator, so we'll just C look for a bitmap after the "follow" indicator. NODBMAP = NODFLW END IF C Find the corresponding bitmap. NN = 1 IDXBTM = 0 DO WHILE ( ( IDXBTM .EQ. 0 ) .AND. . ( NN .LE. NVAL(LUN) ) ) IF ( INV( NN, LUN ) .GT. NODBMAP ) THEN II = 1 DO WHILE ( ( IDXBTM .EQ. 0 ) .AND. . ( II .LE. NBTM ) ) IF ( NN .EQ. ISTBTM(II) ) THEN IDXBTM = II ELSE II = II + 1 END IF END DO END IF NN = NN + 1 END DO IF ( IDXBTM .EQ. 0 ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 902 RETURN END IF C Use the bitmap to find the previous element in the C subset that is referenced by the current element. C Search backwards from the start of the bitmap, but C make sure not to cross a 2-35-000 operator. IF ( LSTNODCT .GT. NBTMSE(IDXBTM) ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 903 RETURN END IF IEMRK = ISZBTM(IDXBTM) - IBTMSE(IDXBTM,LSTNODCT) + 1 IECT = 0 DO WHILE ( ( NN .GE. 1 ) .AND. ( IGETRFEL .EQ. 0 ) ) NODNN = INV( NN, LUN ) IF ( NODNN .LE. NODBMAP ) THEN DO JJ = 1, NTC IF ( ( NODNN .EQ. INODTCO(IDXTA,JJ) ) .AND. . ( CTCO(IDXTA,JJ) .EQ. '235000' ) ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 903 RETURN END IF END DO IF ( ITP(NODNN) .GT. 1 ) THEN IECT = IECT + 1 IF ( IECT .EQ. IEMRK ) IGETRFEL = NN END IF END IF NN = NN - 1 END DO IF ( IGETRFEL .EQ. 0 ) THEN IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) GOTO 903 RETURN END IF IF ( IMRKOPR(TAG(NODE)) .EQ. 1 ) THEN C This element is a marker operator, so set the scale, C reference value and bit width accordingly based on C those of the previous referenced element. NODRFE = INV( IGETRFEL, LUN ) ISC(NODE) = ISC(NODRFE) IF ( TAG(NODE)(1:3) .EQ. '225' ) THEN IBT(NODE) = IBT(NODRFE) + 1 IRF(NODE) = -1 * (2 ** IBT(NODRFE)) ELSE IBT(NODE) = IBT(NODRFE) IRF(NODE) = IRF(NODRFE) IF ( NNRV .GT. 0 ) THEN DO II = 1, NNRV IF ( ( NODRFE .NE. INODNRV(II) ) .AND. . ( TAG(NODRFE)(1:8) .EQ. TAGNRV(II) ) .AND. . ( NODRFE .GE. ISNRV(II) ) .AND. . ( NODRFE .LE. IENRV(II) ) ) THEN IRF(NODE) = NRV(II) RETURN END IF END DO END IF END IF END IF END IF END IF RETURN 900 WRITE(BORT_STR,'("BUFRLB: IGETRFEL - UNABLE TO DETERMINE '// . 'FOLLOW OPERATOR FOR MARKER OPERATOR ",A)') TAG(NODE) CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLB: IGETRFEL - UNABLE TO FIND FOLLOW '// . 'OPERATOR ",A," IN SUBSET")') CFLWOPR CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLB: IGETRFEL - UNABLE TO FIND BITMAP '// . 'FOR MARKER OPERATOR ",A)') TAG(NODE) CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLB: IGETRFEL - UNABLE TO FIND PREVIOUS '// . 'ELEMENT REFERENCED BY MARKER OPERATOR ",A)') TAG(NODE) CALL BORT(BORT_STR) END ./igetsc.f0000644001370400056700000000317613440555365011417 0ustar jator2emc FUNCTION IGETSC(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETSC C PRGMMR: J. ATOR ORG: NP12 DATE: 2010-05-11 C C ABSTRACT: THIS FUNCTION RETURNS ANY STATUS CODE THAT WAS INTERNALLY C SET WITHIN THE BUFR ARCHIVE LIBRARY SOFTWARE FOR A GIVEN LOGICAL C UNIT NUMBER C C PROGRAM HISTORY LOG: C 2010-05-11 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: IGETSC (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C IGETSC - INTEGER: STATUS CODE FOR LUNIT: C 0 = no problems noted with LUNIT C -1 = unable to position LUNIT for appending, C possibly due to an incomplete BUFR message C at the end of the file C C REMARKS: C THIS ROUTINE CALLS: BORT STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_STCODE INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Make sure the specified logical unit is connected to the library. CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IGETSC = ISCODES(LUN) RETURN 900 CALL BORT('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') END ./igettdi.f0000644001370400056700000000355713440555365011575 0ustar jator2emc FUNCTION IGETTDI ( IFLAG ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IGETTDI C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: DEPENDING ON THE VALUE OF THE INPUT FLAG, THIS FUNCTION C EITHER RETURNS THE NEXT USABLE SCRATCH TABLE D INDEX FOR THE C CURRENT MASTER TABLE OR ELSE RESETS THE INDEX BACK TO ITS C MINIMUM VALUE. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IGETTDI ( IFLAG ) C INPUT ARGUMENT LIST: C IFLAG - INTEGER: FLAG: IF SET TO 0, THEN THE FUNCTION WILL C RESET THE SCRATCH TABLE D INDEX BACK TO ITS MINIMUM C VALUE; OTHERWISE, IT WILL RETURN THE NEXT USABLE C SCRATCH TABLE D INDEX FOR THE CURRENT MASTER TABLE C C OUTPUT ARGUMENT LIST: C IGETTDI - INTEGER: NEXT USABLE SCRATCH TABLE D INDEX FOR THE C CURRENT MASTER TABLE C -1 = FUNCTION WAS CALLED WITH IFLAG=0 C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: READS3 STSEQ C Not normally called by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ PARAMETER ( IDXMIN = 62976 ) C* = IFXY('354000') PARAMETER ( IDXMAX = 63231 ) C* = IFXY('354255') CHARACTER*128 BORT_STR SAVE IDX C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( IFLAG .EQ. 0 ) THEN C* Initialize the index to one less than the actual minimum C* value. That way, the next normal call will return the C* minimum value. IDX = IDXMIN - 1 IGETTDI = -1 ELSE IDX = IDX + 1 IF ( IDX .GT. IDXMAX ) GOTO 900 IGETTDI = IDX ENDIF RETURN 900 CALL BORT('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') END ./imrkopr.f0000644001370400056700000000272113440555365011617 0ustar jator2emc INTEGER FUNCTION IMRKOPR(NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IMRKOPR C PRGMMR: J. ATOR ORG: NCEP DATE: 2016-05-04 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER THE GIVEN MNEMONIC C CONTAINS A TABLE C MARKER OPERATOR. C C PROGRAM HISTORY LOG: C 2016-05-04 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IMRKOPR (NEMO) C INPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC C C OUTPUT ARGUMENT LIST: C IMRKOPR - INTEGER: RETURN CODE INDICATING WHETHER NEMO CONTAINS C A TABLE C MARKER OPERATOR C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: IGETRFEL IOKOPER STSEQ 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' CHARACTER*(*) NEMO C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF (LEN(NEMO).LT.6) THEN IMRKOPR = 0 ELSE IF ( ( NEMO(4:6).EQ.'255' ) + .AND. + ( ( NEMO(1:3).EQ.'223' ) .OR. ( NEMO(1:3).EQ.'224' ) .OR. + ( NEMO(1:3).EQ.'225' ) .OR. ( NEMO(1:3).EQ.'232' ) ) ) + THEN IMRKOPR = 1 ELSE IMRKOPR = 0 ENDIF RETURN END ./inctab.f0000644001370400056700000000516413440555365011400 0ustar jator2emc SUBROUTINE INCTAB(ATAG,ATYP,NODE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INCTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RETURNS THE NEXT AVAILABLE POSITIONAL INDEX C FOR WRITING INTO THE INTERNAL JUMP/LINK TABLE IN MODULE TABLES, C AND IT ALSO USES THAT INDEX TO STORE ATAG AND ATYP WITHIN, C RESPECTIVELY, THE INTERNAL JUMP/LINK TABLE ARRAYS TAG(*) AND TYP(*). C IF THERE IS NO MORE ROOM FOR ADDITIONAL ENTRIES WITHIN THE INTERNAL C JUMP/LINK TABLE, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE C LIBRARY SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL INCTAB (ATAG, ATYP, NODE) C INPUT ARGUMENT LIST: C ATAG - CHARACTER*(*): MNEMONIC NAME C ATYP - CHARACTER*(*): MNEMONIC TYPE C C OUTPUT ARGUMENT LIST: C NODE - INTEGER: NEXT AVAILABLE POSITIONAL INDEX FOR WRITING C INTO THE INTERNAL JUMP/LINK TABLE C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: TABENT TABSUB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) ATAG,ATYP CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- NTAB = NTAB+1 IF(NTAB.GT.MAXTAB) GOTO 900 TAG(NTAB) = ATAG TYP(NTAB) = ATYP NODE = NTAB C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: INCTAB - THE NUMBER OF JUMP/LINK '// . 'TABLE ENTRIES EXCEEDS THE LIMIT, MAXTAB (",I7,")")') MAXTAB CALL BORT(BORT_STR) END ./inittbf.c0000644001370400056700000000226013440555365011566 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INITTBF C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-03 C C ABSTRACT: THIS ROUTINE INITIALIZES THE INTERNAL MEMORY STRUCTURE C FOR STORING CODE/FLAG TABLE INFORMATION, INCLUDING DYNAMICALLY C ALLOCATING SPACE FOR THIS STRUCTURE IF NEEDED. C C PROGRAM HISTORY LOG: C 2017-11-03 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL INITTBF C C REMARKS: C THIS ROUTINE CALLS: BORT IGETPRM C THIS ROUTINE IS CALLED BY: RDMTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #define IN_INITTBF #include "cfe.h" void inittbf( void ) { char brtstr[50] = "BUFRLIB: INITTBF FAILED ALLOCATING CFE"; /* ** Has array space for the internal memory structure been ** allocated yet? */ if ( cfe == NULL ) { mxmtbf = igetprm( "MXMTBF", 6 ); if ( ( cfe = malloc( mxmtbf * sizeof(struct code_flag_entry) ) ) == NULL ) { bort( brtstr, ( f77int ) strlen( brtstr ) ); } } nmtf = 0; } ./invcon.f0000644001370400056700000000771513440555365011440 0ustar jator2emc FUNCTION INVCON(NC,LUN,INV1,INV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INVCON C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION SEARCHES A "WINDOW" (SEE BELOW REMARKS) FOR AN C ELEMENT IDENTIFIED IN THE USER STRING AS A CONDITIONAL NODE (I.E. AN C ELEMENT WHICH MUST MEET A CONDITION IN ORDER TO BE READ FROM OR WRITTEN TO C A DATA SUBSET). IF A CONDITIONAL ELEMENT IS FOUND AND IT CONFORMS TO THE C CONDITION, THEN THE INDEX OF THE ELEMENT WITHIN THE WINDOW IS RETURNED. C OTHERWISE A VALUE OF ZERO IS RETURNED. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL C THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C 2010-04-27 J. WOOLLEN -- ADD DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: INVCON (NC, LUN, INV1, INV2) C INPUT ARGUMENT LIST: C NC - INTEGER: CONDITION CODE: C 1 = '=' (EQUAL) C 2 = '!' (NOT EQUAL) C 3 = '<' (LESS THAN) C 4 = '>' (GREATER THAN) C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: FIRST INDEX OF WINDOW TO SEARCH C INV2 - INTEGER: LAST INDEX OF WINDOW TO SEARCH C C OUTPUT ARGUMENT LIST: C INVCON - INTEGER: INDEX WITHIN WINDOW OF CONDITIONAL NODE CONFORMING C TO SPECIFIED CONDITION C 0 = NONE FOUND C C REMARKS: C C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. C C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: CONWIN C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /QUIET / IPRT C---------------------------------------------------------------------- C---------------------------------------------------------------------- C CHECK THE INVENTORY INTERVAL C ---------------------------- IF(INV1.LE.0 .OR. INV1.GT.NVAL(LUN)) GOTO 99 IF(INV2.LE.0 .OR. INV2.GT.NVAL(LUN)) GOTO 99 C FIND AN OCCURANCE OF NODE IN THE WINDOW MEETING THIS CONDITION C -------------------------------------------------------------- DO INVCON=INV1,INV2 IF(INV(INVCON,LUN).EQ.NODC(NC)) THEN IF(KONS(NC).EQ.1 .AND. VAL(INVCON,LUN).EQ.IVLS(NC)) GOTO 100 IF(KONS(NC).EQ.2 .AND. VAL(INVCON,LUN).NE.IVLS(NC)) GOTO 100 IF(KONS(NC).EQ.3 .AND. VAL(INVCON,LUN).LT.IVLS(NC)) GOTO 100 IF(KONS(NC).EQ.4 .AND. VAL(INVCON,LUN).GT.IVLS(NC)) GOTO 100 ENDIF ENDDO 99 INVCON = 0 IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: INVCON - RETURNING WITH A VALUE OF 0') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXIT C ---- 100 RETURN END ./invmrg.f0000644001370400056700000001163513440555365011442 0ustar jator2emc SUBROUTINE INVMRG(LUBFI,LUBFJ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INVMRG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 C C ABSTRACT: THIS SUBROUTINE MERGES "PARTS" OF SUBSETS WHICH HAVE C DUPLICATE SPACE AND TIME COORDINATES BUT DIFFERENT OR UNIQUE C OBSERVATIONAL DATA. IT CANNOT MERGE REPLICATED DATA. C C PROGRAM HISTORY LOG: C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-11-25 J. WOOLLEN -- MODIFIED FOR RADIOSONDE CALL SIGNS C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES; C REMOVED ENTRY POINT MRGINV (IT BECAME A C SEPARATE ROUTINE IN THE BUFRLIB TO C INCREASE PORTABILITY TO OTHER PLATFORMS) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS AND SIMPLIFY LOGIC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL INVMRG (LUBFI, LUBFJ) C INPUT ARGUMENT LIST: C LUBFI - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUBFJ - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IBFMS NWORDS STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT CHARACTER*128 BORT_STR LOGICAL HEREI,HEREJ,MISSI,MISSJ,SAMEI C----------------------------------------------------------------------- C----------------------------------------------------------------------- IS = 1 JS = 1 C GET THE UNIT POINTERS C --------------------- CALL STATUS(LUBFI,LUNI,IL,IM) CALL STATUS(LUBFJ,LUNJ,JL,JM) C STEP THROUGH THE BUFFERS COMPARING THE INVENTORY AND MERGING DATA C ----------------------------------------------------------------- DO WHILE(IS.LE.NVAL(LUNI)) C CHECK TO SEE WE ARE AT THE SAME NODE IN EACH BUFFER C --------------------------------------------------- NODE = INV(IS,LUNI) NODJ = INV(JS,LUNJ) IF(NODE.NE.NODJ) GOTO 900 ITYP = ITP(NODE) C FOR TYPE 1 NODES DO AN ENTIRE SEQUENCE REPLACEMENT C -------------------------------------------------- IF(ITYP.EQ.1) THEN IF(TYP(NODE).EQ.'DRB') IOFF = 0 IF(TYP(NODE).NE.'DRB') IOFF = 1 IWRDS = NWORDS(IS,LUNI)+IOFF JWRDS = NWORDS(JS,LUNJ)+IOFF IF(IWRDS.GT.IOFF .AND. JWRDS.EQ.IOFF) THEN DO N=NVAL(LUNJ),JS+1,-1 INV(N+IWRDS-JWRDS,LUNJ) = INV(N,LUNJ) VAL(N+IWRDS-JWRDS,LUNJ) = VAL(N,LUNJ) ENDDO DO N=0,IWRDS INV(JS+N,LUNJ) = INV(IS+N,LUNI) VAL(JS+N,LUNJ) = VAL(IS+N,LUNI) ENDDO NVAL(LUNJ) = NVAL(LUNJ)+IWRDS-JWRDS JWRDS = IWRDS NRPL = NRPL+1 ENDIF IS = IS+IWRDS JS = JS+JWRDS ENDIF C FOR TYPES 2 AND 3 FILL MISSINGS C ------------------------------- IF((ITYP.EQ.2).OR.(ITYP.EQ.3)) THEN HEREI = IBFMS(VAL(IS,LUNI)).EQ.0 HEREJ = IBFMS(VAL(JS,LUNJ)).EQ.0 MISSI = .NOT.(HEREI) MISSJ = .NOT.(HEREJ) SAMEI = VAL(IS,LUNI).EQ.VAL(JS,LUNJ) IF(HEREI.AND.MISSJ) THEN VAL(JS,LUNJ) = VAL(IS,LUNI) NMRG = NMRG+1 ELSEIF(HEREI.AND.HEREJ.AND..NOT.SAMEI) THEN NAMB = NAMB+1 ENDIF ENDIF C BUMP THE COUNTERS AND GO CHECK THE NEXT PAIR C -------------------------------------------- IS = IS + 1 JS = JS + 1 ENDDO NTOT = NTOT+1 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '// . '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), '// . 'TABULAR MISMATCH")') NODE,NODJ CALL BORT(BORT_STR) END ./invtag.f0000644001370400056700000000627613440555365011435 0ustar jator2emc FUNCTION INVTAG(NODE,LUN,INV1,INV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INVTAG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED MNEMONIC WITHIN THE C PORTION OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 C AND INV2. IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVWIN, C EXCEPT THAT INVWIN SEARCHES BASED ON THE ACTUAL NODE WITHIN THE C INTERNAL JUMP/LINK TABLE, RATHER THAN ON THE MNEMONIC CORRESPONDING C TO THAT NODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN UNUSUAL THINGS HAPPEN C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: INVTAG (NODE, LUN, INV1, INV2) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX OF MNEMONIC TO LOOK FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C C OUTPUT ARGUMENT LIST: C INVTAG - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED C PORTION OF SUBSET BUFFER C 0 = NOT FOUND C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: UFBRP UFBSEQ UFBSP C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT CHARACTER*10 TAGN C---------------------------------------------------------------------- C---------------------------------------------------------------------- INVTAG = 0 IF(NODE.EQ.0) GOTO 200 TAGN = TAG(NODE) C SEARCH BETWEEN INV1 AND INV2 C ---------------------------- 10 DO INVTAG=INV1,INV2 IF(TAG(INV(INVTAG,LUN)).EQ.TAGN) GOTO 100 ENDDO INVTAG = 0 200 IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: INVTAG - RETURNING WITH A VALUE OF 0') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXIT C ---- 100 RETURN END ./invwin.f0000644001370400056700000000613213440555365011446 0ustar jator2emc FUNCTION INVWIN(NODE,LUN,INV1,INV2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: INVWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION LOOKS FOR A SPECIFIED NODE WITHIN THE PORTION C OF THE CURRENT SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. C IT IS SIMILAR TO BUFR ARCHIVE LIBRARY FUNCTION INVTAG, EXCEPT THAT C INVTAG SEARCHES BASED ON THE MNEMONIC CORRESPONDING TO THE NODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN UNUSUAL THINGS HAPPEN C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: INVWIN (NODE, LUN, INV1, INV2) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C C OUTPUT ARGUMENT LIST: C INVWIN - INTEGER: LOCATION INDEX OF NODE WITHIN SPECIFIED C PORTION OF SUBSET BUFFER C 0 = NOT FOUND C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: DRSTPL GETWIN NEVN TRYBUMP C UFBGET UFBRW UFBSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT C---------------------------------------------------------------------- C---------------------------------------------------------------------- INVWIN = 0 IF(NODE.EQ.0) GOTO 200 C SEARCH BETWEEN INV1 AND INV2 C ---------------------------- 10 DO INVWIN=INV1,INV2 IF(INV(INVWIN,LUN).EQ.NODE) GOTO 100 ENDDO INVWIN = 0 200 IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: INVWIN - RETURNING WITH A VALUE OF 0') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXIT C ---- 100 RETURN END ./iok2cpy.f0000644001370400056700000000564513440555365011524 0ustar jator2emc INTEGER FUNCTION IOK2CPY(LUI,LUO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IOK2CPY C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-06-26 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER A MESSAGE, OR A SUBSET C FROM A MESSAGE, CAN BE COPIED FROM LOGICAL UNIT IOLUN(LUI) TO C LOGICAL UNIT IOLUN(LUO). THE DECISION IS BASED ON WHETHER THE C EXACT SAME DEFINITION FOR THE GIVEN MESSAGE TYPE APPEARS WITHIN C THE DICTIONARY TABLE INFORMATION FOR BOTH LOGICAL UNITS. NOTE THAT C IT IS POSSIBLE FOR A MESSAGE TYPE TO BE IDENTICALLY DEFINED FOR TWO C DIFFERENT LOGICAL UNITS EVEN IF THE UNITS THEMSELVES DON'T SHARE C THE EXACT SAME FULL SET OF DICTIONARY TABLES. C C PROGRAM HISTORY LOG: C 2009-06-26 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: IOK2CPY (LUI, LUO) C INPUT ARGUMENT LIST: C LUI - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR LOGICAL UNIT TO COPY FROM C LUO - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR LOGICAL UNIT TO COPY TO C C OUTPUT ARGUMENT LIST: C IOK2CPY - INTEGER: RETURN CODE INDICATING WHETHER IT IS OKAY TO C COPY FROM IOLUN(LUI) TO IOLUN(LUO) C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: ICMPDX NEMTBAX C THIS ROUTINE IS CALLED BY: COPYSB COPYMG CPYMEM UFBCPY C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- IOK2CPY = 0 C Do both logical units have the same internal table information? IF ( ICMPDX(LUI,LUO) .EQ. 1 ) THEN IOK2CPY = 1 RETURN ENDIF C No, so get the Table A mnemonic from the message to be copied, C then check whether that mnemonic is defined within the dictionary C tables for the logical unit to be copied to. SUBSET = TAG(INODE(LUI)) CALL NEMTBAX(LUO,SUBSET,MTYP,MSBT,INOD) IF ( INOD .EQ. 0 ) RETURN C The Table A mnemonic is defined within the dictionary tables for C both units, so now make sure the definitions are identical. NTEI = ISC(INODE(LUI))-INODE(LUI) NTEO = ISC(INOD)-INOD IF ( NTEI .NE. NTEO ) RETURN DO I = 1, NTEI IF ( TAG(INODE(LUI)+I) .NE. TAG(INOD+I) ) RETURN IF ( TYP(INODE(LUI)+I) .NE. TYP(INOD+I) ) RETURN IF ( ISC(INODE(LUI)+I) .NE. ISC(INOD+I) ) RETURN IF ( IRF(INODE(LUI)+I) .NE. IRF(INOD+I) ) RETURN IF ( IBT(INODE(LUI)+I) .NE. IBT(INOD+I) ) RETURN ENDDO IOK2CPY = 1 RETURN END ./iokoper.f0000644001370400056700000000414213440555365011603 0ustar jator2emc INTEGER FUNCTION IOKOPER(NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IOKOPER C PRGMMR: J. ATOR ORG: NCEP DATE: 2015-03-06 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER THE GIVEN MNEMONIC C CONTAINS A TABLE C OPERATOR KNOWN TO THE BUFR ARCHIVE LIBRARY. C C PROGRAM HISTORY LOG: C 2015-03-06 J. ATOR -- ORIGINAL AUTHOR C 2016-05-04 J. ATOR -- USE IMRKOPR AND ALLOW ADDITIONAL OPERATORS C C USAGE: IOKOPER (NEMO) C INPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC C C OUTPUT ARGUMENT LIST: C IOKOPER - INTEGER: RETURN CODE INDICATING WHETHER NEMO CONTAINS C A KNOWN TABLE C OPERATOR C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: IMRKOPR C THIS ROUTINE IS CALLED BY: ISTDESC NEMTAB NUMTAB TABSUB 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' CHARACTER*(*) NEMO C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF (LEN(NEMO).LT.6) THEN IOKOPER = 0 ELSE IF ( LGE(NEMO(1:3),'201') .AND. LLE(NEMO(1:3),'208') ) THEN IOKOPER = 1 ELSE IF ( NEMO(1:3).EQ.'221') THEN IOKOPER = 1 ELSE IF ( ( ( NEMO(4:6).EQ.'000' ) .OR. ( NEMO(4:6).EQ.'255' ) ) + .AND. + ( ( NEMO(1:3).EQ.'237' ) .OR. ( NEMO(1:3).EQ.'241' ) .OR. + ( NEMO(1:3).EQ.'242' ) .OR. ( NEMO(1:3).EQ.'243' ) ) ) + THEN IOKOPER = 1 ELSE IF ( ( NEMO(4:6).EQ.'000' ) + .AND. + ( ( NEMO(1:3).EQ.'222' ) .OR. ( NEMO(1:3).EQ.'223' ) .OR. + ( NEMO(1:3).EQ.'224' ) .OR. ( NEMO(1:3).EQ.'225' ) .OR. + ( NEMO(1:3).EQ.'232' ) .OR. ( NEMO(1:3).EQ.'235' ) .OR. + ( NEMO(1:3).EQ.'236' ) ) ) + THEN IOKOPER = 1 ELSE IOKOPER = IMRKOPR(NEMO) ENDIF RETURN END ./ipkm.f0000644001370400056700000000506313440555365011076 0ustar jator2emc SUBROUTINE IPKM(CBAY,NBYT,N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IPKM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER N INTO A CHARACTER STRING C CBAY OF LENGTH NBYT BYTES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) 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 C C USAGE: CALL IPKM (CBAY, NBYT, N) C INPUT ARGUMENT LIST: C NBYT - INTEGER: NUMBER OF BYTES INTO WHICH TO PACK N (LENGTH C OF STRING) C N - INTEGER: INTEGER TO BE PACKED C C OUTPUT ARGUMENT LIST: C CBAY - CHARACTER*8: STRING OF LENGTH NBYT BYTES CONTAINING C PACKED INTEGER N C C REMARKS: C THIS ROUTINE CALLS: BORT IREV C THIS ROUTINE IS CALLED BY: BFRINI CHRTRNA CRBMG PKC C PKTDD UPC WRTREE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*128 BORT_STR CHARACTER*8 CBAY,CINT EQUIVALENCE (CINT,INT) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NBYT.GT.NBYTW) GOTO 900 C Note that the widths of input variable N and local variable INT C will both be equal to the default size of an integer (= NBYTW), C since they aren't specifically declared otherwise. INT = IREV(ISHFT(N,(NBYTW-NBYT)*8)) DO I=1,NBYT CBAY(I:I) = CINT(I:I) ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: IPKM - NUMBER OF BYTES BEING PACKED '// . ', NBYT (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// . 'MACHINE, NBYTW (",I3,")")') NBYT,NBYTW CALL BORT(BORT_STR) END ./ipks.f0000644001370400056700000000460313440555365011103 0ustar jator2emc INTEGER FUNCTION IPKS(VAL,NODE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IPKS C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 C C ABSTRACT: THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR C INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. C C PROGRAM HISTORY LOG: C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL C STATEMENT FUNCTION IN WRTREE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: IPKS (VAL,NODE) C INPUT ARGUMENT LIST: C VAL - REAL*8: USER VALUE C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES C C OUTPUT ARGUMENT LIST: C IPKS - INTEGER: PACKED BUFR VALUE C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: WRTREE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES USE MODA_NRV203 INCLUDE 'bufrlib.prm' REAL*8 TEN,VAL DATA TEN /10./ C----------------------------------------------------------------------- IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - IRF(NODE) IF ( NNRV .GT. 0 ) THEN C There are redefined reference values in the jump/link table, C so we need to check if this node is affected by any of them. DO JJ = 1, NNRV IF ( NODE .EQ. INODNRV(JJ) ) THEN C This node contains a redefined reference value. C Per the rules of BUFR, negative values should be encoded C as positive integers with the left-most bit set to 1. NRV(JJ) = NINT(VAL) IF ( NRV(JJ) .LT. 0 ) THEN IMASK = 2**(IBT(NODE)-1) IPKS = IOR(IABS(NRV(JJ)),IMASK) ELSE IPKS = NRV(JJ) END IF RETURN ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. . ( NODE .GE. ISNRV(JJ) ) .AND. . ( NODE .LE. IENRV(JJ) ) ) THEN C The corresponding redefinded reference value needs to C be used when encoding this value. IPKS = NINT( VAL * TEN**(ISC(NODE)) ) - NRV(JJ) RETURN END IF END DO END IF RETURN END ./ireadmg.f0000644001370400056700000000371213440555365011545 0ustar jator2emc FUNCTION IREADMG(LUNIT,SUBSET,IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREADMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMG C AND PASSES BACK ITS RETURN CODE. SEE READMG FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1999-11-18 J. WOOLLEN -- ADDED NEW FUNCTION ENTRY POINTS IREADMM AND C IREADIBM C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINTS ICOPYSB, IREADFT, C IREADIBM, IREADMM, IREADNS AND IREADSB C (THEY BECAME SEPARATE ROUTINES IN THE C BUFRLIB TO INCREASE PORTABILITY TO OTHER C PLATFORMS) 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) C C USAGE: IREADMG (LUNIT, SUBSET, IDATE) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IREADMG - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more BUFR messages in LUNIT C C REMARKS: C THIS ROUTINE CALLS: READMG C THIS ROUTINE IS CALLED BY: UFBTAB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 SUBSET CALL READMG(LUNIT,SUBSET,IDATE,IRET) IREADMG = IRET RETURN END ./ireadmm.f0000644001370400056700000000364313440555365011556 0ustar jator2emc FUNCTION IREADMM(IMSG,SUBSET,IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREADMM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 C C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READMM C AND PASSES BACK ITS RETURN CODE. SEE READMM FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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) C C USAGE: IREADMM (IMSG, SUBSET, IDATE) C INPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IREADMM - INTEGER: RETURN CODE: C 0 = normal return C -1 = IMSG is either 0 or greater than the C number of messages in memory C C REMARKS: C THIS ROUTINE CALLS: READMM C THIS ROUTINE IS CALLED BY: UFBMNS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL READMM(IMSG,SUBSET,IDATE,IRET) IREADMM = IRET RETURN END ./ireadmt.F0000644001370400056700000002050613440555365011522 0ustar jator2emc INTEGER FUNCTION IREADMT ( LUN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREADMT C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS FUNCTION CHECKS THE MOST RECENT BUFR MESSAGE THAT C WAS READ AS INPUT VIA SUBROUTINE READMG, READERME OR EQUIVALENT C TO DETERMINE IF THE APPROPRIATE CORRESPONDING BUFR MASTER TABLES C HAVE ALREADY BEEN READ INTO INTERNAL MEMORY. IF NOT, THEN IT C OPENS THE APPROPRIATE BUFR MASTER TABLE FILES AND READS THEM INTO C INTERNAL MEMORY, CLEARING ANY PREVIOUS MASTER TABLE INFORMATION C ALREADY STORED THERE. INFORMATION ABOUT THE BUFR MASTER TABLE C FILES IS OBTAINED FROM THE MOST RECENT CALL TO SUBROUTINE MTINFO, C OR ELSE AS DEFINED WITHIN SUBROUTINE BFRINI IF SUBROUTINE MTINFO C WAS NEVER CALLED. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2014-11-25 J. ATOR -- ADD CALL TO CPMSTABS FOR ACCESS TO MASTER C TABLE INFORMATION WITHIN C WHEN USING C DYNAMICALLY ALLOCATED ARRAYS C 2017-10-13 J. ATOR -- ADD FUNCTIONALITY TO CHECK WHETHER NEW C MASTER TABLES NEED TO BE READ (THIS C FUNCTIONALITY WAS PREVIOUSLY PART OF C SUBROUTINE READS3) C 2018-04-09 J. ATOR -- ONLY READ MASTER B AND D TABLES WHEN C SECTION 3 IS BEING USED FOR DECODING C C USAGE: IREADMT ( LUN ) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C IREADMT - INTEGER: RETURN CODE INDICATING WHETHER NEW BUFR C MASTER TABLE FILES NEEDED TO BE OPENED AND READ C DURING THIS CALL TO THE FUNCTION C 0 = NO C 1 = YES C C INPUT FILES: C UNITS 98,99 - IF SUBROUTINE MTINFO WAS NEVER CALLED, THEN THESE C LOGICAL UNIT NUMBERS ARE USED BY THIS ROUTINE FOR C OPENING AND READING THE BUFR MASTER TABLES. C ALTERNATIVELY, IF SUBROUTINE MTINFO WAS CALLED, C THEN THE LOGICAL UNIT NUMBERS SPECIFIED IN THE C MOST RECENT CALL TO MTINFO (ARGUMENTS LUNMT1 AND C LUNMT2) ARE USED INSTEAD. C REMARKS: C THIS ROUTINE CALLS: BORT2 CPMSTABS ERRWRT ICVIDX C IFXY ISTDESC IUPBS01 MTFNAM C RDMTBB RDMTBD RDMTBF UPDS3 C THIS ROUTINE IS CALLED BY: GETCFMNG READS3 UFDUMP C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSTABS USE MODA_BITBUF USE MODA_RDMTB USE MODA_SC3BFR INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR COMMON /TABLEF/ CDMF CHARACTER*1 CDMF CHARACTER*6 CDS3(MAXNC) CHARACTER*100 MTDIR CHARACTER*128 BORT_STR CHARACTER*132 STDFIL,LOCFIL LOGICAL ALLSTD C* Initializing the following value ensures that new master tables C* are read during the first call to this subroutine. DATA LMT /-99/ SAVE LMT, LMTV, LOGCE, LMTVL C----------------------------------------------------------------------- C----------------------------------------------------------------------- IREADMT = 0 C* Unpack some Section 1 information from the message that was C* most recently read. IMT = IUPBS01 ( MBAY(1,LUN), 'BMT' ) IMTV = IUPBS01 ( MBAY(1,LUN), 'MTV' ) IOGCE = IUPBS01 ( MBAY(1,LUN), 'OGCE' ) IMTVL = IUPBS01 ( MBAY(1,LUN), 'MTVL' ) C* Compare the master table and master table version numbers from C* this message to those from the message that was processed during C* the previous call to this subroutine. IF ( ( IMT .NE. LMT ) . .OR. . ( ( IMT .NE. 0 ) .AND. ( IMTV .NE. LMTV ) ) . .OR. . ( ( IMT .EQ. 0 ) .AND. ( IMTV .NE. LMTV ) .AND. . ( ( IMTV .GT. 13 ) .OR. ( LMTV .GT. 13 ) ) ) ) . THEN C* Either the master table number has changed C* .OR. C* The master table number hasn't changed, but it isn't 0, and C* the table version number has changed C* .OR. C* The master table number hasn't changed and is 0, but the table C* version number has changed, and at least one of the table C* version numbers (i.e. the current or the previous) is greater C* than 13 (which is the last version that was a superset of all C* earlier versions of master table 0!) C* In any of these cases, we need to read in new tables! IREADMT = 1 ELSE C* Unpack the list of Section 3 descriptors from the message and C* determine if any of them are local descriptors. CALL UPDS3 ( MBAY(1,LUN), MAXNC, CDS3, NCDS3 ) II = 1 ALLSTD = .TRUE. DO WHILE ( (ALLSTD) .AND. (II.LE.NCDS3) ) IF ( ISTDESC(IFXY(CDS3(II))) .EQ. 0 ) THEN ALLSTD = .FALSE. ELSE II = II + 1 ENDIF ENDDO C* If there was at least one local (i.e. non-standard) descriptor, C* and if either the originating center or local table version C* number are different than those from the message that was C* processed during the previous call to this subroutine, then C* we need to read in new tables. IF ( ( .NOT. ALLSTD ) .AND. + ( ( IOGCE .NE. LOGCE ) .OR. ( IMTVL .NE. LMTVL ) ) ) + IREADMT = 1 ENDIF IF ( IREADMT .EQ. 0 ) RETURN LMT = IMT LMTV = IMTV LOGCE = IOGCE LMTVL = IMTVL IF ( IPRT .GE. 2 ) THEN CALL ERRWRT(' ') CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT('BUFRLIB: IREADMT - OPENING/READING MASTER TABLES') ENDIF IF ( ISC3(LUN) .NE. 0 ) THEN C* Locate and open the master Table B files. There should be one C* file of standard descriptors and one file of local descriptors. CALL MTFNAM ( IMT, IMTV, IOGCE, IMTVL, 'TableB', . STDFIL, LOCFIL ) OPEN ( UNIT = LUN1, FILE = STDFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 900 OPEN ( UNIT = LUN2, FILE = LOCFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 901 C* Read the master Table B files. CALL RDMTBB ( LUN1, LUN2, MXMTBB, . IBMT, IBMTV, IBOGCE, IBLTV, . NMTB, IBFXYN, CBSCL, CBSREF, CBBW, . CBUNIT, CBMNEM, CMDSCB, CBELEM ) C* Close the master Table B files. CLOSE ( UNIT = LUN1 ) CLOSE ( UNIT = LUN2 ) C* Locate and open the master Table D files. There should be one C* file of standard descriptors and one file of local descriptors. CALL MTFNAM ( IMT, IMTV, IOGCE, IMTVL, 'TableD', . STDFIL, LOCFIL ) OPEN ( UNIT = LUN1, FILE = STDFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 900 OPEN ( UNIT = LUN2, FILE = LOCFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 901 C* Read the master Table D files. CALL RDMTBD ( LUN1, LUN2, MXMTBD, MAXCD, . IDMT, IDMTV, IDOGCE, IDLTV, . NMTD, IDFXYN, CDMNEM, CMDSCD, CDSEQ, . NDELEM, IEFXYN, CEELEM ) DO I = 1, NMTD DO J = 1, NDELEM(I) IDX = ICVIDX ( I-1, J-1, MAXCD ) + 1 IDEFXY(IDX) = IEFXYN(I,J) ENDDO ENDDO C* Close the master Table D files. CLOSE ( UNIT = LUN1 ) CLOSE ( UNIT = LUN2 ) #ifdef DYNAMIC_ALLOCATION C* Copy master table B and D information into internal C arrays. CALL CPMSTABS ( NMTB, IBFXYN, CBSCL, CBSREF, CBBW, CBUNIT, . CBMNEM, CBELEM, NMTD, IDFXYN, CDSEQ, CDMNEM, . NDELEM, IDEFXY, MAXCD ) #endif ENDIF IF ( CDMF .EQ. 'Y' ) THEN C* Locate and open the master code and flag table files. There C* should be one file corresponding to the standard Table B C* descriptors, and one file corresponding to the local Table B C* descriptors. CALL MTFNAM ( IMT, IMTV, IOGCE, IMTVL, 'CodeFlag', . STDFIL, LOCFIL ) OPEN ( UNIT = LUN1, FILE = STDFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 900 OPEN ( UNIT = LUN2, FILE = LOCFIL, IOSTAT = IER ) IF ( IER .NE. 0 ) GOTO 901 C* Read the master code and flag table files. CALL RDMTBF ( LUN1, LUN2 ) C* Close the master code and flag table files. CLOSE ( UNIT = LUN1 ) CLOSE ( UNIT = LUN2 ) ENDIF IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF RETURN 900 BORT_STR = 'BUFRLIB: IREADMT - COULD NOT OPEN STANDARD FILE:' CALL BORT2(BORT_STR,STDFIL) 901 BORT_STR = 'BUFRLIB: IREADMT - COULD NOT OPEN LOCAL FILE:' CALL BORT2(BORT_STR,LOCFIL) END ./ireadns.f0000644001370400056700000000342713440555365011565 0ustar jator2emc FUNCTION IREADNS(LUNIT,SUBSET,IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREADNS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READNS C AND PASSES BACK ITS RETURN CODE. SEE READNS FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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) C C USAGE: IREADNS (LUNIT, SUBSET, IDATE) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE C CONTAINING SUBSET BEING READ C IDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() C VALUE C IREADNS - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the BUFR file C C REMARKS: C THIS ROUTINE CALLS: READNS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 SUBSET CALL READNS(LUNIT,SUBSET,IDATE,IRET) IREADNS = IRET RETURN END ./ireadsb.f0000644001370400056700000000257113440555365011550 0ustar jator2emc FUNCTION IREADSB(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREADSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CALLS BUFR ARCHIVE LIBRARY SUBROUTINE READSB C AND PASSES BACK ITS RETURN CODE. SEE READSB FOR MORE DETAILS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN IREADMG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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) C C USAGE: IREADSB (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C IREADSB - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the BUFR C message C C REMARKS: C THIS ROUTINE CALLS: READSB C THIS ROUTINE IS CALLED BY: UFBTAB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CALL READSB(LUNIT,IRET) IREADSB = IRET RETURN END ./irev.F0000644001370400056700000000562113440555365011043 0ustar jator2emc FUNCTION IREV(N) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IREV C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION WILL, WHEN THE LOCAL MACHINE IS "LITTLE- C ENDIAN" (I.E., USES A RIGHT TO LEFT SCHEME FOR NUMBERING THE BYTES C WITHIN A MACHINE WORD), RETURN A COPY OF AN INPUT INTEGER WORD WITH C THE BYTES REVERSED. ALTHOUGH, BY DEFINITION (WITHIN WMO MANUAL C 306), A BUFR MESSAGE IS A STREAM OF INDIVIDUAL OCTETS (I.E., BYTES) C THAT IS INDEPENDENT OF ANY PARTICULAR MACHINE REPRESENTATION, THE C BUFR ARCHIVE LIBRARY SOFTWARE OFTEN NEEDS TO INTERPRET ALL OR PARTS C OF TWO OR MORE ADJACENT BYTES IN ORDER TO CONSTRUCT AN INTEGER C WORD. BY DEFAULT, THE SOFTWARE USES THE "BIG-ENDIAN" (LEFT TO C RIGHT) SCHEME FOR NUMBERING BYTES. BY REVERSING THE BYTES, IREV C ALLOWS THE INTEGER WORD TO BE PROPERLY READ OR WRITTEN (DEPENDING C ON WHETHER INPUT OR OUTPUT OPERATIONS, RESPECTIVELY, ARE BEING C PERFORMED) ON LITTLE-ENDIAN MACHINES. IF THE LOCAL MACHINE IS C BIG-ENDIAN, IREV SIMPLY RETURNS A COPY OF THE SAME INTEGER THAT WAS C INPUT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW C DETERMINED AT COMPILE TIME AND CONFIGURED C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION C DIRECTIVES C C USAGE: IREV (N) C INPUT ARGUMENT LIST: C N - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO C THE "BIG-ENDIAN" NUMBERING SCHEME C C OUTPUT ARGUMENT LIST: C IREV - INTEGER: INTEGER WORD WITH BYTES ORDERED ACCORDING TO C THE NUMBERING SCHEME OF THE LOCAL MACHINE (EITHER C "BIG-ENDIAN" OR "LITTLE-ENDIAN", IF "BIG-ENDIAN THEN C THIS IS JUST A DIRECT COPY OF N) C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: IPKM IUPM PKB PKC C UPBB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*8 CINT,DINT EQUIVALENCE(CINT,INT) EQUIVALENCE(DINT,JNT) C---------------------------------------------------------------------- C---------------------------------------------------------------------- #ifdef BIG_ENDIAN IREV = N #else INT = N DO I=1,NBYTW DINT(I:I) = CINT(IORD(I):IORD(I)) ENDDO IREV = JNT #endif RETURN END ./isetprm.F0000644001370400056700000001714613440555365011566 0ustar jator2emc INTEGER FUNCTION ISETPRM ( CPRMNM, IPVAL ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ISETPRM C PRGMMR: ATOR ORG: NP12 DATE: 2014-12-04 C C ABSTRACT: THIS FUNCTION SHOULD ONLY BE CALLED IF DYNAMIC MEMORY C ALLOCATION IS BEING USED. IT SETS A SPECIFIED PARAMETER TO A C SPECIFIED VALUE FOR LATER USE IN DYNAMICALLY SIZING ONE OR MORE C INTERNAL ARRAYS. THE LIST OF PARAMETERS THAT CAN BE DYNAMICALLY C SIZED IS GIVEN BELOW, AND A SEPARATE CALL TO THIS FUNCTION MUST C BE MADE FOR EACH SUCH PARAMETER THAT IS DESIRED TO BE CHANGED C FROM ITS DEFAULT VALUE. IF THIS FUNCTION IS NOT CALLED FOR A C PARTICULAR PARAMETER, THE DEFAULT VALUE IS OBTAINED FROM THE C CORRESPONDING MODULE FILE FOR THAT PARAMETER. C C NOTE THAT ALL CALLS TO THIS FUNCTION MUST BE MADE PRIOR TO THE C FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. C C PROGRAM HISTORY LOG: C 2014-12-04 J. ATOR -- ORIGINAL AUTHOR C 2016-05-24 J. ATOR -- ADD MXNRV, MXBTM, MXBTMSE, MXTCO C 2017-04-03 J. ATOR -- ADD MXTAMC C 2017-05-22 J. ATOR -- ADD MXRST C 2017-10-17 J. ATOR -- ADD MXMTBF C C USAGE: ISETPRM ( CPRMNM, IPVAL ) C INPUT ARGUMENT LIST: C CPRMNM - CHARACTER*(*): PARAMETER TO BE CHANGED FROM ITS C DEFAULT VALUE: C 'MXMSGL' = MAXIMUM LENGTH (IN BYTES) OF A BUFR C MESSAGE C 'MAXSS' = MAXIMUM NUMBER OF DATA VALUES IN AN C UNCOMPRESSED BUFR SUBSET C 'MXCDV' = MAXIMUM NUMBER OF DATA VALUES THAT CAN BE C WRITTEN INTO A COMPRESSED BUFR SUBSET C 'MXLCC' = MAXIMUM LENGTH (IN BYTES) OF A CHARACTER C STRING THAT CAN BE WRITTEN INTO A C COMPRESSED BUFR SUBSET C 'MXCSB' = MAXIMUM NUMBER OF SUBSETS THAT CAN BE C WRITTEN INTO A COMPRESSED BUFR MESSAGE C 'NFILES' = MAXIMUM NUMBER OF BUFR FILES THAT CAN BE C ACCESSED FOR READING OR WRITING AT ANY C ONE TIME C 'MAXTBA' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE A PER BUFR FILE C 'MAXTBB' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE B PER BUFR FILE C 'MAXTBD' = MAXIMUM NUMBER OF ENTRIES IN INTERNAL BUFR C TABLE D PER BUFR FILE C 'MAXMEM' = MAXIMUM NUMBER OF BYTES THAT CAN BE USED C TO STORE BUFR MESSAGES IN INTERNAL MEMORY C 'MAXMSG' = MAXIMUM NUMBER OF BUFR MESSAGES THAT CAN C BE STORED IN INTERNAL MEMORY C 'MXDXTS' = MAXIMUM NUMBER OF DICTIONARY TABLES THAT C CAN BE STORED FOR USE WITH BUFR MESSAGES C IN INTERNAL MEMORY C 'MXMTBB' = MAXIMUM NUMBER OF MASTER TABLE B ENTRIES C 'MXMTBD' = MAXIMUM NUMBER OF MASTER TABLE D ENTRIES C 'MXMTBF' = MAXIMUM NUMBER OF MASTER CODE/FLAG ENTRIES C 'MAXCD' = MAXIMUM NUMBER OF CHILD DESCRIPTORS IN A C TABLE D DESCRIPTOR SEQUENCE DEFINITION C 'MAXJL' = MAXIMUM NUMBER OF ENTRIES IN THE INTERNAL C JUMP/LINK TABLE C 'MXS01V' = MAXIMUM NUMBER OF DEFAULT SECTION 0 OR C SECTION 1 VALUES THAT CAN BE OVERWRITTEN C WITHIN AN OUTPUT BUFR MESSAGE C 'MXBTM' = MAXIMUM NUMBER OF BITMAPS THAT CAN BE C STORED INTERNALLY FOR A BUFR SUBSET C 'MXBTMSE' = MAXIMUM NUMBER OF ENTRIES THAT CAN BE C SET WITHIN A BITMAP C 'MXTAMC' = MAXIMUM NUMBER OF TABLE A MNEMONICS IN THE C INTERNAL JUMP/LINK TABLE WHICH CONTAIN AT C LEAST ONE TABLE C OPERATOR WITH X>=21 IN C THEIR SUBSET DEFINITION C 'MXTCO' = MAXIMUM NUMBER OF TABLE C OPERATORS (WITH C X>=21) IN THE SUBSET DEFINITION OF A C TABLE A MNEMONIC C 'MXNRV' = MAXIMUM NUMBER OF 2-03 REFERENCE VALUES C IN THE INTERNAL JUMP/LINK TABLE C 'MXRST' = MAXIMUM NUMBER OF LONG CHARACTER STRINGS C THAT CAN BE READ FROM A COMPRESSED SUBSET C IPVAL - INTEGER: VALUE ASSOCIATED WITH CPRMNM C C OUTPUT ARGUMENT LIST: C ISETPRM - INTEGER: RETURN CODE: C 0 = NORMAL RETURN C -1 = UNKNOWN CPRNMN, OR DYNAMIC ALLOCATION NOT IN C EFFECT FOR THIS BUILD C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MAXSS USE MODV_NFILES USE MODV_MXMSGL USE MODV_MXDXTS USE MODV_MAXMSG USE MODV_MAXMEM USE MODV_MAXTBA USE MODV_MAXTBB USE MODV_MAXTBD USE MODV_MAXJL USE MODV_MXCDV USE MODV_MXLCC USE MODV_MXCSB USE MODV_MXMTBB USE MODV_MXMTBD USE MODV_MXMTBF USE MODV_MAXCD USE MODV_MXS01V USE MODV_MXBTM USE MODV_MXBTMSE USE MODV_MXTAMC USE MODV_MXTCO USE MODV_MXNRV USE MODV_MXRST INCLUDE 'bufrlib.prm' CHARACTER*(*) CPRMNM CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- #ifdef DYNAMIC_ALLOCATION ISETPRM = 0 IF ( CPRMNM .EQ. 'MAXSS' ) THEN MAXSS = IPVAL ELSE IF ( CPRMNM .EQ. 'NFILES' ) THEN NFILES = IPVAL ELSE IF ( CPRMNM .EQ. 'MXMSGL' ) THEN MXMSGL = IPVAL ELSE IF ( CPRMNM .EQ. 'MXDXTS' ) THEN MXDXTS = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXMSG' ) THEN MAXMSG = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXMEM' ) THEN MAXMEM = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXTBA' ) THEN MAXTBA = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXTBB' ) THEN MAXTBB = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXTBD' ) THEN MAXTBD = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXJL' ) THEN MAXJL = IPVAL ELSE IF ( CPRMNM .EQ. 'MXCDV' ) THEN MXCDV = IPVAL ELSE IF ( CPRMNM .EQ. 'MXLCC' ) THEN MXLCC = IPVAL ELSE IF ( CPRMNM .EQ. 'MXCSB' ) THEN MXCSB = IPVAL ELSE IF ( CPRMNM .EQ. 'MXMTBB' ) THEN MXMTBB = IPVAL ELSE IF ( CPRMNM .EQ. 'MXMTBD' ) THEN MXMTBD = IPVAL ELSE IF ( CPRMNM .EQ. 'MXMTBF' ) THEN MXMTBF = IPVAL ELSE IF ( CPRMNM .EQ. 'MAXCD' ) THEN MAXCD = IPVAL ELSE IF ( CPRMNM .EQ. 'MXS01V' ) THEN MXS01V = IPVAL ELSE IF ( CPRMNM .EQ. 'MXBTM' ) THEN MXBTM = IPVAL ELSE IF ( CPRMNM .EQ. 'MXBTMSE' ) THEN MXBTMSE = IPVAL ELSE IF ( CPRMNM .EQ. 'MXTAMC' ) THEN MXTAMC = IPVAL ELSE IF ( CPRMNM .EQ. 'MXTCO' ) THEN MXTCO = IPVAL ELSE IF ( CPRMNM .EQ. 'MXNRV' ) THEN MXNRV = IPVAL ELSE IF ( CPRMNM .EQ. 'MXRST' ) THEN MXRST = IPVAL ELSE ISETPRM = -1 CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') ERRSTR = 'BUFRLIB: ISETPRM - UNKNOWN INPUT PARAMETER '// . CPRMNM // ' -- NO ACTION WAS TAKEN' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') ENDIF #else ISETPRM = -1 CALL ERRWRT('++++++++++++++++++++WARNING+++++++++++++++++++++') ERRSTR = 'BUFRLIB: ISETPRM - DYNAMIC MEMORY ALLOCATION IS '// . 'NOT SUPPORTED FOR THIS BUILD OF BUFRLIB' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++++++++WARNING+++++++++++++++++++++') #endif RETURN END ./ishrdx.f0000644001370400056700000000437213440555365011441 0ustar jator2emc INTEGER FUNCTION ISHRDX(LUD,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ISHRDX C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-11-30 C C ABSTRACT: THIS FUNCTION DETERMINES WHETHER LOGICAL UNIT IOLUN(LUN) IS C SHARING INTERNAL TABLE INFORMATION WITH LOGICAL UNIT IOLUN(LUD). C NOTE THAT TWO LOGICAL UNITS CAN HAVE THE SAME INTERNAL TABLE C INFORMATION WITHOUT ACTUALLY SHARING IT. C C PROGRAM HISTORY LOG: C 2009-11-30 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: ISHRDX (LUD, LUN) C INPUT ARGUMENT LIST: C LUD - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR FIRST LOGICAL UNIT C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C FOR SECOND LOGICAL UNIT C C OUTPUT ARGUMENT LIST: C ISHRDX - INTEGER: RETURN CODE INDICATING WHETHER IOLUN(LUN) C IS SHARING TABLE INFORMATION WITH IOLUN(LUD): C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: ICMPDX MAKESTAB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Note that, for any I/O stream index value LUx, the MTAB(*,LUx) C array contains pointer indices into the internal jump/link table C for each of the Table A mnemonics that is currently defined for C that LUx value. Thus, if all of these indices are identical for C two different LUx values, then the associated logical units are C sharing table information. IF ( ( NTBA(LUD) .GE. 1 ) .AND. + ( NTBA(LUD) .EQ. NTBA(LUN) ) ) THEN II = 1 ISHRDX = 1 DO WHILE ( ( II .LE. NTBA(LUD) ) .AND. ( ISHRDX .EQ. 1 ) ) IF ( ( MTAB(II,LUD) .NE. 0 ) .AND. + ( MTAB(II,LUD) .EQ. MTAB(II,LUN) ) ) THEN II = II + 1 ELSE ISHRDX = 0 ENDIF ENDDO ELSE ISHRDX = 0 ENDIF RETURN END ./isize.f0000644001370400056700000000276113440555365011263 0ustar jator2emc INTEGER FUNCTION ISIZE (NUM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ISIZE C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE NUMBER OF CHARACTERS C NEEDED TO ENCODE THE INPUT INTEGER NUM AS A STRING. IT DOES NOT C ACTUALLY ENCODE THE STRING BUT RATHER ONLY FIGURES OUT THE REQUIRED C SIZE. NUM MUST BE AN INTEGER IN THE RANGE OF 0 TO 99999. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2016-02-12 J. ATOR -- MODIFIED FOR CRAYFTN COMPATIBILITY C C USAGE: CALL ISIZE ( NUM ) C INPUT ARGUMENT LIST: C NUM - INTEGER: NUMBER TO BE ENCODED C C OUTPUT ARGUMENT LIST: C ISIZE - INTEGER: NUMBER OF CHARACTERS NECESSARY TO ENCODE NUM C AS A STRING C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: MTFNAM UFBDMP UFDUMP C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( NUM .GE. 0 ) THEN DO ISIZE = 1, 5 IF ( NUM .LT. 10**ISIZE ) RETURN ENDDO ENDIF WRITE(BORT_STR,'("BUFRLIB: ISIZE - INPUT NUMBER (",I7,'// . '") IS OUT OF RANGE")') NUM CALL BORT(BORT_STR) RETURN END ./istdesc.f0000644001370400056700000000267113440555365011576 0ustar jator2emc FUNCTION ISTDESC( IDN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: ISTDESC C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF THE FXY VALUE C FOR A DESCRIPTOR, THIS FUNCTION DETERMINES WHETHER THE DESCRIPTOR C IS A WMO-STANDARD DESCRIPTOR OR A LOCAL DESCRIPTOR. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C C USAGE: ISTDESC( IDN ) C INPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE C FOR DESCRIPTOR TO BE CHECKED C C OUTPUT ARGUMENT LIST: C ISTDESC - INTEGER: RETURN VALUE: C 0 - IDN IS A LOCAL DESCRIPTOR C 1 - IDN IS A WMO-STANDARD DESCRIPTOR C C REMARKS: C THIS ROUTINE CALLS: ADN30 IOKOPER C THIS ROUTINE IS CALLED BY: IREADMT RESTD STNDRD C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*6 ADSC, ADN30 ADSC = ADN30( IDN, 6 ) READ(ADSC,'(I1,I2,I3)') IF,IX,IY IF ( IF .EQ. 1 ) THEN C ADSC IS A REPLICATION DESCRIPTOR AND THEREFORE STANDARD C BY DEFAULT. ISTDESC = 1 ELSE IF ( IF .EQ. 2 ) THEN C ADSC IS AN OPERATOR DESCRIPTOR ISTDESC = IOKOPER( ADSC ) ELSE IF ( ( IX .LT. 48 ) .AND. ( IY .LT. 192 ) ) THEN ISTDESC = 1 ELSE ISTDESC = 0 END IF RETURN END ./iupb.f0000644001370400056700000000351513440555365011075 0ustar jator2emc FUNCTION IUPB(MBAY,NBYT,NBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IUPB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD C CONTAINED WITHIN NBIT BITS OF A BUFR MESSAGE PACKED INTO THE C INTEGER ARRAY MBAY, STARTING WITH THE FIRST BIT OF BYTE NBYT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C C USAGE: IUPB (MBAY, NBYT, NBIT) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE C NBYT - INTEGER: BYTE WITHIN MBAY AT WHOSE FIRST BIT TO BEGIN C UNPACKING C NBIT - INTEGER: NUMBER OF BITS WITHIN MBAY TO BE UNPACKED C C OUTPUT ARGUMENT LIST: C IUPB - INTEGER: UNPACKED INTEGER WORD C C REMARKS: C THIS ROUTINE CALLS: UPB C THIS ROUTINE IS CALLED BY: CKTABA CPYUPD GETLENS IUPBS01 C IUPBS3 MSGUPD MSGWRT RDMEMS C RTRCPTB STBFDX STNDRD STRCPT C UPDS3 WRDXTB WRITLC C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- MBIT = (NBYT-1)*8 CALL UPB(IRET,NBIT,MBAY,MBIT) IUPB = IRET RETURN END ./iupbs01.f0000644001370400056700000001505513440555365011423 0ustar jator2emc FUNCTION IUPBS01(MBAY,S01MNEM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IUPBS01 C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE C FROM SECTION 0 OR SECTION 1 OF THE BUFR MESSAGE STORED IN ARRAY C MBAY. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 C OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST C BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE C UNPACKED IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS EXPLAINED IN C FURTHER DETAIL BELOW. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2006-04-14 J. ATOR -- ADDED OPTIONS FOR 'YCEN' AND 'CENT'; C RESTRUCTURED LOGIC C C USAGE: IUPBS01 (MBAY, S01MNEM) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE: C 'LENM' = LENGTH (IN BYTES) OF BUFR MESSAGE C 'LEN0' = LENGTH (IN BYTES) OF SECTION 0 C 'BEN' = BUFR EDITION NUMBER C 'LEN1' = LENGTH (IN BYTES) OF SECTION 1 C 'BMT' = BUFR MASTER TABLE C 'OGCE' = ORIGINATING CENTER C 'GSES' = ORIGINATING SUBCENTER C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 3 OR 4 MESSAGES!) C 'USN' = UPDATE SEQUENCE NUMBER C 'ISC2' = FLAG INDICATING ABSENCE/PRESENCE OF C (OPTIONAL) SECTION 2 IN BUFR MESSAGE: C 0 = SECTION 2 ABSENT C 1 = SECTION 2 PRESENT C 'MTYP' = DATA CATEGORY C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MSBT' = DATA SUBCATEGORY (LOCAL) C 'MTV' = VERSION NUMBER OF MASTER TABLE C 'MTVL' = VERSION NUMBER OF LOCAL TABLES C 'YCEN' = YEAR OF CENTURY (1-100) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, C 21 FOR YEARS 2001-2100) C (NOTE: THIS VALUE *MAY* BE PRESENT IN C BUFR EDITION 2 AND 3 MESSAGES, C BUT IT IS NEVER PRESENT IN ANY C BUFR EDITION 4 MESSAGES!) C 'YEAR' = YEAR (4-DIGIT) C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES. FOR C BUFR EDITION 2 AND 3 MESSAGES C IT WILL BE CALCULATED USING THE C VALUES FOR 'YCEN' AND 'CENT', C EXCEPT WHEN THE LATTER IS NOT C PRESENT AND IN WHICH CASE A C "WINDOWING" TECHNIQUE WILL BE C USED INSTEAD!) C 'MNTH' = MONTH C 'DAYS' = DAY C 'HOUR' = HOUR C 'MINU' = MINUTE C 'SECO' = SECOND C (NOTE: THIS VALUE IS PRESENT ONLY IN C BUFR EDITION 4 MESSAGES!) C C OUTPUT ARGUMENT LIST: C IUPBS01 - INTEGER: UNPACKED INTEGER VALUE C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID FOR C THE EDITION OF BUFR MESSAGE IN MBAY C C REMARKS: C THIS ROUTINE CALLS: GETS1LOC I4DY IUPB WRDLEN C THIS ROUTINE IS CALLED BY: ATRCPT CKTABA CNVED4 COPYBF C COPYMG CPYMEM CRBMG CRDBUFR C DUMPBF GETLENS IDXMSG IGETDATE C IREADMT IUPVS01 MESGBC MESGBF C MSGWRT NMWRD PADMSG PKBS1 C RTRCPTB STBFDX STNDRD UFBMEX C WRCMPS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) CHARACTER*(*) S01MNEM LOGICAL OK4CENT C----------------------------------------------------------------------- C This statement function checks whether its input value contains C a valid century value. OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21)) C----------------------------------------------------------------------- C Call subroutine WRDLEN to initialize some important information C about the local machine, just in case subroutine OPENBF hasn't C been called yet. CALL WRDLEN C Handle some simple requests that do not depend on the BUFR C edition number. IF(S01MNEM.EQ.'LENM') THEN IUPBS01 = IUPB(MBAY,5,24) RETURN ENDIF LEN0 = 8 IF(S01MNEM.EQ.'LEN0') THEN IUPBS01 = LEN0 RETURN ENDIF C Get the BUFR edition number. IBEN = IUPB(MBAY,8,8) IF(S01MNEM.EQ.'BEN') THEN IUPBS01 = IBEN RETURN ENDIF C Use the BUFR edition number to handle any other requests. CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRET) IF(IRET.EQ.0) THEN IUPBS01 = IUPB(MBAY,LEN0+ISBYT,IWID) IF(S01MNEM.EQ.'CENT') THEN C Test whether the returned value was a valid C century value. IF(.NOT.OK4CENT(IUPBS01)) IUPBS01 = -1 ENDIF ELSE IF( (S01MNEM.EQ.'YEAR') .AND. (IBEN.LT.4) ) THEN C Calculate the 4-digit year. IYOC = IUPB(MBAY,21,8) ICEN = IUPB(MBAY,26,8) C Does ICEN contain a valid century value? IF(OK4CENT(ICEN)) THEN C YES, so use it to calculate the 4-digit year. Note that, C by international convention, the year 2000 was the 100th C year of the 20th century, and the year 2001 was the 1st C year of the 21st century IUPBS01 = (ICEN-1)*100 + IYOC ELSE C NO, so use a windowing technique to determine the C 4-digit year from the year of the century. IUPBS01 = I4DY(MOD(IYOC,100)*1000000)/10**6 ENDIF ELSE IUPBS01 = -1 ENDIF RETURN END ./iupbs3.f0000644001370400056700000000517013440555365011342 0ustar jator2emc FUNCTION IUPBS3(MBAY,S3MNEM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IUPBS3 C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE C FROM SECTION 3 OF THE BUFR MESSAGE STORED IN ARRAY MBAY. IT WILL C WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4. THE START C OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE C FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE UNPACKED IS SPECIFIED C VIA THE MNEMONIC S3MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: IUPBS3 (MBAY, S3MNEM) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C S3MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE C UNPACKED FROM SECTION 3 OF BUFR MESSAGE: C 'NSUB' = NUMBER OF DATA SUBSETS C 'IOBS' = FLAG INDICATING WHETHER THE MESSAGE C CONTAINS OBSERVED DATA: C 0 = NO C 1 = YES C 'ICMP' = FLAG INDICATING WHETHER THE MESSAGE C CONTAINS COMPRESSED DATA: C 0 = NO C 1 = YES C C OUTPUT ARGUMENT LIST: C IUPBS3 - INTEGER: UNPACKED INTEGER VALUE C -1 = THE INPUT S3MNEM MNEMONIC WAS INVALID C C REMARKS: C THIS ROUTINE CALLS: GETLENS IUPB C THIS ROUTINE IS CALLED BY: CKTABA CPDXMM DUMPBF MESGBC C RDBFDX READERME STNDRD WRITLC C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) CHARACTER*(*) S3MNEM C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Call subroutine WRDLEN to initialize some important information C about the local machine, just in case subroutine OPENBF hasn't C been called yet. CALL WRDLEN C Skip to the beginning of Section 3. CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) IPT = LEN0 + LEN1 + LEN2 C Unpack the requested value. IF(S3MNEM.EQ.'NSUB') THEN IUPBS3 = IUPB(MBAY,IPT+5,16) ELSE IF( (S3MNEM.EQ.'IOBS') .OR. (S3MNEM.EQ.'ICMP') ) THEN IVAL = IUPB(MBAY,IPT+7,8) IF(S3MNEM.EQ.'IOBS') THEN IMASK = 128 ELSE IMASK = 64 ENDIF IUPBS3 = MIN(1,IAND(IVAL,IMASK)) ELSE IUPBS3 = -1 ENDIF RETURN END ./iupm.f0000644001370400056700000000475113440555365011113 0ustar jator2emc FUNCTION IUPM(CBAY,NBITS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IUPM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD C CONTAINED WITHIN NBITS BITS OF A CHARACTER STRING CBAY, STARTING C WITH THE FIRST BIT OF THE FIRST BYTE OF CBAY. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) 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 C C USAGE: IUPM (CBAY, NBITS) C INPUT ARGUMENT LIST: C CBAY - CHARACTER*8: CHARACTER STRING CONTAINING PACKED C INTEGER C NBITS - INTEGER: NUMBER OF BITS WITHIN CBAY TO BE UNPACKED C C OUTPUT ARGUMENT LIST: C IUPM - INTEGER: UNPACKED INTEGER WORD C C REMARKS: C THIS ROUTINE CALLS: BORT IREV C THIS ROUTINE IS CALLED BY: CHRTRNA CRBMG DXMINI ICBFMS C PKC PKTDD UPC UPTDD C WRDLEN WRDXTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*128 BORT_STR CHARACTER*8 CBAY CHARACTER*8 CINT DIMENSION INT(2) EQUIVALENCE (CINT,INT) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NBITS.GT.NBITW) GOTO 900 CINT = CBAY INT(1) = IREV(INT(1)) IUPM = ISHFT(INT(1),NBITS-NBITW) C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: IUPM - NUMBER OF BITS BEING UNPACKED'// . ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// . 'MACHINE, NBITW (",I3,")")') NBITS,NBITW CALL BORT(BORT_STR) END ./iupvs01.f0000644001370400056700000000543213440555365011445 0ustar jator2emc FUNCTION IUPVS01(LUNIT,S01MNEM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IUPVS01 C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE C FROM SECTION 0 OR SECTION 1 OF THE LAST BUFR MESSAGE THAT WAS READ C FROM LOGICAL UNIT NUMBER LUNIT VIA BUFR ARCHIVE LIBRARY SUBROUTINE C READMG, READERME OR EQUIVALENT. IT WILL WORK ON ANY MESSAGE ENCODED C USING BUFR EDITION 2, 3 OR 4, AND THE VALUE TO BE UNPACKED IS C SPECIFIED VIA THE MNEMONIC S01MNEM (SEE THE DOCBLOCK OF BUFR ARCHIVE C LIBRARY FUNCTION IUPBS01 FOR A LISTING OF POSSIBLE VALUES FOR C S01MNEM). NOTE THAT THIS FUNCTION IS SIMILAR TO BUFR ARCHIVE C LIBRARY FUNCTION IUPBS01 EXCEPT THAT IT OPERATES ON A BUFR MESSAGE C THAT HAS ALREADY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY C ARRAYS (VIA A PREVIOUS CALL TO READMG, READERME, ETC.) RATHER THAN C ON A BUFR MESSAGE PASSED DIRECTLY INTO THE FUNCTION VIA A MEMORY C ARRAY. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: IUPVS01 (LUNIT, S01MNEM) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE C UNPACKED FROM SECTION 0 OR SECTION 1 OF BUFR MESSAGE C (SEE DOCBLOCK OF FUNCTION IUPBS01 FOR LISTING OF C POSSIBLE VALUES) C C OUTPUT ARGUMENT LIST: C IUPVS01 - INTEGER: UNPACKED INTEGER VALUE C -1 = THE INPUT S01MNEM MNEMONIC WAS INVALID C C REMARKS: C THIS ROUTINE CALLS: BORT IUPBS01 STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BITBUF INCLUDE 'bufrlib.prm' CHARACTER*(*) S01MNEM C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,ILST,IMST) IF(ILST.EQ.0) GOTO 900 IF(ILST.GT.0) GOTO 901 IF(IMST.EQ.0) GOTO 902 C UNPACK THE REQUESTED VALUE C -------------------------- IUPVS01 = IUPBS01(MBAY(1,LUN),S01MNEM) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') END ./jstchr.f0000644001370400056700000000456113440555365011435 0ustar jator2emc SUBROUTINE JSTCHR(STR,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: JSTCHR C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE LEFT-JUSTIFIES (I.E. REMOVES ALL LEADING C BLANKS FROM) A CHARACTER STRING. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS C THEN REMOVED BECAUSE IT WAS JUST A DUMMY C ROUTINE WITH ENTRIES) 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 C 2007-01-19 J. ATOR -- RESTRUCTURED AND ADDED IRET ARGUMENT C C USAGE: CALL JSTCHR (STR, IRET) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS C REMOVED C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = input string was empty (i.e. all blanks) C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: ELEMDX IGETFXY SNTBBE SNTBDE C SNTBFE C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(STR.EQ.' ') THEN IRET = -1 ELSE IRET = 0 LSTR = LEN(STR) DO WHILE(STR(1:1).EQ.' ') STR = STR(2:LSTR) ENDDO ENDIF RETURN END ./jstnum.f0000644001370400056700000000722713440555365011462 0ustar jator2emc SUBROUTINE JSTNUM(STR,SIGN,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: JSTNUM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE REMOVES ALL LEADING BLANKS FROM A CHARACTER C STRING CONTAINING AN ENCODED INTEGER VALUE. IF THE VALUE HAS A C LEADING SIGN CHARACTER ('+' OR '-'), THEN THIS CHARACTER IS ALSO C REMOVED AND IS RETURNED SEPARATELY WITHIN SIGN. IF THE RESULTANT C STRING CONTAINS ANY NON-NUMERIC CHARACTERS, THAN AN APPROPRIATE C CALL IS MADE TO TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN JSTIFY) C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" (IN PARENT ROUTINE JSTIFY) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS (JSTIFY WAS C THEN REMOVED BECAUSE IT WAS JUST A DUMMY C ROUTINE WITH ENTRIES) 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 OR UNUSUAL THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL JSTNUM (STR, SIGN, IRET) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): COPY OF INPUT STR WITH LEADING BLANKS C AND SIGN CHARACTER REMOVED C SIGN - CHARACTER*1: SIGN OF ENCODED INTEGER VALUE: C '+' = positive value C '-' = negative value C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = encoded value within STR was not an integer C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT STRNUM C THIS ROUTINE IS CALLED BY: ELEMDX C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*128 ERRSTR CHARACTER*1 SIGN COMMON /QUIET / IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 IF(STR.EQ.' ') GOTO 900 LSTR = LEN(STR) 2 IF(STR(1:1).EQ.' ') THEN STR = STR(2:LSTR) GOTO 2 ENDIF IF(STR(1:1).EQ.'+') THEN STR = STR(2:LSTR) SIGN = '+' ELSEIF(STR(1:1).EQ.'-') THEN STR = STR(2:LSTR) SIGN = '-' ELSE SIGN = '+' ENDIF CALL STRNUM(STR,NUM) IF(NUM.LT.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT '// . 'CHARACTER STRING (' // STR // ') IS NOT AN INTEGER - '// . 'RETURN WITH IRET = -1' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IRET = -1 ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT '// . 'ALLOWED') END ./lcmgdf.f0000644001370400056700000000404513440555365011371 0ustar jator2emc INTEGER FUNCTION LCMGDF(LUNIT,SUBSET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LCMGDF C PRGMMR: J. ATOR ORG: NP20 DATE: 2009-07-09 C C ABSTRACT: THIS FUNCTION CHECKS WHETHER AT LEAST ONE "LONG" (I.E. C GREATER THAN 8 BYTES) CHARACTER STRING EXISTS WITHIN THE INTERNAL C DICTIONARY DEFINITION FOR THE TABLE A MESSAGE TYPE GIVEN BY SUBSET. C C PROGRAM HISTORY LOG: C 2009-07-09 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: LCMGDF (LUNIT, SUBSET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED WITH C SUBSET DEFINITION C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR MESSAGE TYPE C C OUTPUT ARGUMENT LIST: C LCMGDF - INTEGER: RETURN CODE INDICATING WHETHER SUBSET CONTAINS C AT LEAST ONE "LONG" CHARACTER STRING IN ITS DEFINITION C 0 - NO C 1 - YES C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTBA STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Get LUN from LUNIT. CALL STATUS(LUNIT,LUN,IL,IM) IF (IL.EQ.0) GOTO 900 C Confirm that SUBSET is defined for this logical unit. CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD) C Check if there's a long character string in the definition. NTE = ISC(INOD)-INOD DO I = 1, NTE IF ( (TYP(INOD+I).EQ.'CHR') .AND. (IBT(INOD+I).GT.64) ) THEN LCMGDF = 1 RETURN ENDIF ENDDO LCMGDF = 0 RETURN 900 CALL BORT('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN') END ./lmsg.f0000644001370400056700000000313213440555365011073 0ustar jator2emc FUNCTION LMSG(SEC0) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LMSG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: GIVEN A CHARACTER STRING CONTAINING SECTION ZERO FROM A C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER C OF WORDS REQUIRED TO HOLD THE MESSAGE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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) C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION C 2005-11-29 J. ATOR -- USE NMWRD C C USAGE: LMSG (SEC0) C INPUT ARGUMENT LIST: C SEC0 - CHARACTER*8: PACKED BUFR MESSAGE SECTION ZERO C C OUTPUT ARGUMENT LIST: C LMSG - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) C C REMARKS: C THIS ROUTINE CALLS: NMWRD C THIS ROUTINE IS CALLED BY: READERME C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 SEC0,CSEC0 DIMENSION MSEC0(2) EQUIVALENCE(MSEC0,CSEC0) C----------------------------------------------------------------------- C----------------------------------------------------------------------- CSEC0 = SEC0 LMSG = NMWRD(MSEC0) C EXIT C ---- RETURN END ./lstjpb.f0000644001370400056700000000737713471257203011440 0ustar jator2emc FUNCTION LSTJPB(NODE,LUN,JBTYP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LSTJPB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION SEARCHES BACKWARDS, BEGINNING FROM A GIVEN C NODE WITHIN THE JUMP/LINK TABLE, UNTIL IT FINDS THE MOST RECENT C NODE OF TYPE JBTYP. THE INTERNAL JMPB ARRAY IS USED TO JUMP C BACKWARDS WITHIN THE JUMP/LINK TABLE, AND THE FUNCTION RETURNS C THE TABLE INDEX OF THE FOUND NODE. IF THE INPUT NODE ITSELF IS C OF TYPE JBTYP, THEN THE FUNCTION SIMPLY RETURNS THE INDEX OF THAT C SAME NODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: LSTJPB (NODE, LUN, JBTYP) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX OF ENTRY TO BEGIN C SEARCHING BACKWARDS FROM C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C JBTYP - CHARACTER*(*): TYPE OF NODE FOR WHICH TO SEARCH C C OUTPUT ARGUMENT LIST: C LSTJPB - INTEGER: INDEX OF FIRST NODE OF TYPE JBTYP FOUND BY C JUMPING BACKWARDS FROM INPUT NODE C 0 = NO SUCH NODE FOUND C C REMARKS: C C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE TABSUB FOR AN C EXPLANATION OF THE VARIOUS NODE TYPES PRESENT WITHIN AN INTERNAL C JUMP/LINK TABLE C C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: GETWIN IGETRFEL NEVN NEWWIN C NXTWIN PARUSR STRBTM TRYBUMP C UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) JBTYP CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NODE.LT.INODE(LUN)) GOTO 900 IF(NODE.GT.ISC(INODE(LUN))) GOTO 901 NOD = NODE C FIND THIS OR THE PREVIOUS "JBTYP" NODE C -------------------------------------- 10 IF(TYP(NOD).NE.JBTYP) THEN NOD = JMPB(NOD) IF(NOD.NE.0) GOTO 10 ENDIF LSTJPB = NOD C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// . 'OF BOUNDS, < LOWER BOUNDS (",I7,"); TAG IS ",A10)') . NODE,INODE(LUN),TAG(NODE) CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT '// . 'OF BOUNDS, > UPPER BOUNDS (",I7,"); TAG IS ",A10)') . NODE,ISC(INODE(LUN)),TAG(NODE) CALL BORT(BORT_STR) END ./getdefflags_C.sh0000755001370400056700000000130313475253136013033 0ustar jator2emc#!/bin/sh #------------------------------------------------------------------------------- # Set define flags for the C compiler. cflags_defs="-DDYNAMIC_ALLOCATION" #------------------------------------------------------------------------------- # Use the bufrlib.prm header file to generate a few additional corresponding # define flags for the C compiler. for bprm in MAXNC MXNAF do bprmval=`grep " ${bprm} = " bufrlib.prm | cut -f2 -d= | cut -f2 -d" "` cflags_defs="${cflags_defs} -D${bprm}=${bprmval}" done #------------------------------------------------------------------------------- # Print (to standard output) the define flags for the C compiler. echo ${cflags_defs} ./makestab.f0000644001370400056700000003437713440555365011737 0ustar jator2emc SUBROUTINE MAKESTAB C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MAKESTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE C WITHIN MODULE TABLES, USING THE INFORMATION WITHIN THE C INTERNAL BUFR TABLE ARRAYS (WITHIN MODULE TABABD) FOR ALL OF C THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO C THE BUFR ARCHIVE LIBRARY SOFTWARE. NOTE THAT THE ENTIRE JUMP/LINK C TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF C SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS C ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS C SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN C PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET C BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G. C THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE C VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY; NOW ALLOWS FOR THE C POSSIBILITY THAT A CONNECTED FILE MAY NOT C CONTAIN ANY DICTIONARY TABLE INFO (E.G., C AN EMPTY FILE), SUBSEQUENT CONNECTED FILES C WHICH ARE NOT EMPTY WILL NO LONGER GET C TRIPPED UP BY THIS (THIS AVOIDS THE NEED C FOR AN APPLICATION PROGRAM TO DISCONNECT C ANY EMPTY FILES VIA A CALL TO CLOSBF) C 2009-03-18 J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE C AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM. C THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE C OTHER FILES ARE CONNECTED TO THE TABLES OF C THE FILE WHOSE TABLES HAVE CHANGED. C 2009-06-25 J. ATOR -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE C WHERE TABLE WAS RE-READ FOR A PARTICULAR C LOGICAL UNIT BUT IS STILL THE SAME ACTUAL C TABLE AS BEFORE AND IS STILL SHARING THAT C TABLE WITH A DIFFERENT LOGICAL UNIT C 2009-11-17 J. ATOR -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE C INFORMATION WHEN A TABLE HAS BEEN RE-READ C WITHIN A SHARED LOGICAL UNIT BUT HASN'T C REALLY CHANGED C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2017-04-03 J. ATOR -- INCLUDE MODULE BITMAPS AND INITIALIZATION C OF NTAMC C C USAGE: CALL MAKESTAB C C REMARKS: C THIS ROUTINE CALLS: BORT CHEKSTAB CLOSMG CPBFDX C ERRWRT ICMPDX ISHRDX STRCLN C TABSUB WRDXTB C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM RDUSDX READDX C READERME READS3 C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_STBFR USE MODA_LUSHR USE MODA_XTAB USE MODA_TABABD USE MODA_TABLES USE MODA_NRV203 USE MODA_BITMAPS INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 NEMO LOGICAL EXPAND C----------------------------------------------------------------------- C----------------------------------------------------------------------- C RESET POINTER TABLE AND STRING CACHE C ------------------------------------ NTAB = 0 NNRV = 0 NTAMC = 0 CALL STRCLN C FIGURE OUT WHICH UNITS SHARE TABLES C ----------------------------------- C The LUS array is static between calls to this subroutine, and it C keeps track of which logical units share dictionary table C information: C if LUS(I) = 0, then IOLUN(I) does not share dictionary table C information with any other logical unit C if LUS(I) > 0, then IOLUN(I) shares dictionary table C information with logical unit IOLUN(LUS(I)) C if LUS(I) < 0, then IOLUN(I) does not now, but at one point in C the past, shared dictionary table information C with logical unit IOLUN(ABS(LUS(I))) C The XTAB array is non-static and is recomputed within the below C loop during each call to this subroutine: C if XTAB(I) = .TRUE., then the dictionary table information C has changed for IOLUN(I) since the last C call to this subroutine C if XTAB(I) = .FALSE., then the dictionary table information C has not changed for IOLUN(I) since the C last call to this subroutine DO LUN=1,NFILES XTAB(LUN) = .FALSE. IF(IOLUN(LUN).EQ.0) THEN C Logical unit IOLUN(LUN) is not defined to the BUFRLIB. LUS(LUN) = 0 ELSE IF(MTAB(1,LUN).EQ.0) THEN C New dictionary table information has been read for logical C unit IOLUN(LUN) since the last call to this subroutine. XTAB(LUN) = .TRUE. IF(LUS(LUN).NE.0) THEN IF(IOLUN(ABS(LUS(LUN))).EQ.0) THEN LUS(LUN) = 0 ELSE IF(LUS(LUN).GT.0) THEN C IOLUN(LUN) was sharing table information with logical C unit IOLUN(LUS(LUN)), so check whether the table C information has really changed. If not, then IOLUN(LUN) C just re-read a copy of the exact same table information C as before, and therefore it can continue to share with C logical unit IOLUN(LUS(LUN)). IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN XTAB(LUN) = .FALSE. CALL CPBFDX(LUS(LUN),LUN) ELSE LUS(LUN) = (-1)*LUS(LUN) ENDIF ELSE IF(ICMPDX(ABS(LUS(LUN)),LUN).EQ.1) THEN C IOLUN(LUN) was not sharing table information with logical C unit IOLUN(LUS(LUN)), but it did at one point in the past C and now once again has the same table information as that C logical unit. Since the two units shared table C information at one point in the past, allow them to do C so again. XTAB(LUN) = .FALSE. LUS(LUN) = ABS(LUS(LUN)) CALL CPBFDX(LUS(LUN),LUN) ENDIF ENDIF ELSE IF(LUS(LUN).GT.0) THEN C Logical unit IOLUN(LUN) is sharing table information with C logical unit IOLUN(LUS(LUN)), so make sure that the latter C unit is still defined to the BUFRLIB. IF(IOLUN(LUS(LUN)).EQ.0) THEN LUS(LUN) = 0 ELSE IF( XTAB(LUS(LUN)) .AND. + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN C The table information for logical unit IOLUN(LUS(LUN)) C just changed (in midstream). If IOLUN(LUN) is an output C file, then we will have to update it with the new table C information later on in this subroutine. Otherwise, C IOLUN(LUN) is an input file and is no longer sharing C tables with IOLUN(LUS(LUN)). IF(IOLUN(LUN).LT.0) LUS(LUN) = (-1)*LUS(LUN) ENDIF ELSE C Determine whether logical unit IOLUN(LUN) is sharing table C information with any other logical units. LUM = 1 DO WHILE ((LUM.LT.LUN).AND.(LUS(LUN).EQ.0)) IF(ISHRDX(LUM,LUN).EQ.1) THEN LUS(LUN) = LUM ELSE LUM = LUM+1 ENDIF ENDDO ENDIF ENDDO C INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS C ----------------------------------------------------------- DO LUN=1,NFILES IF(IOLUN(LUN).NE.0 .AND. NTBA(LUN).GT.0) THEN C Reset any existing inventory pointers. IF(IOMSG(LUN).NE.0) THEN IF(LUS(LUN).EQ.0) THEN INC = (NTAB+1)-MTAB(1,LUN) ELSE INC = MTAB(1,LUS(LUN))-MTAB(1,LUN) ENDIF DO N=1,NVAL(LUN) INV(N,LUN) = INV(N,LUN)+INC ENDDO ENDIF IF(LUS(LUN).LE.0) THEN C The dictionary table information corresponding to logical C unit IOLUN(LUN) has not yet been written into the internal C jump/link table, so add it in now. CALL CHEKSTAB(LUN) DO ITBA=1,NTBA(LUN) INOD = NTAB+1 NEMO = TABA(ITBA,LUN)(4:11) CALL TABSUB(LUN,NEMO) MTAB(ITBA,LUN) = INOD ISC(INOD) = NTAB ENDDO ELSE IF( XTAB(LUS(LUN)) .AND. + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN C Logical unit IOLUN(LUN) is an output file that is sharing C table information with logical unit IOLUN(LUS(LUN)) whose C table just changed (in midstream). Flush any existing data C messages from IOLUN(LUN), then update the table information C for this logical unit with the corresponding new table C information from IOLUN(LUS(LUN)), then update IOLUN(LUN) C itself with a copy of the new table information. LUNIT = ABS(IOLUN(LUN)) IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT) CALL CPBFDX(LUS(LUN),LUN) LUNDX = ABS(IOLUN(LUS(LUN))) CALL WRDXTB(LUNDX,LUNIT) ENDIF ENDIF ENDDO C STORE TYPES AND INITIAL VALUES AND COUNTS C ----------------------------------------- DO NODE=1,NTAB IF(TYP(NODE).EQ.'SUB') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'SEQ') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'RPC') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'RPS') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'REP') THEN VALI(NODE) = BMISS KNTI(NODE) = IRF(NODE) ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'DRS') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'DRP') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'DRB') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'NUM') THEN VALI(NODE) = BMISS KNTI(NODE) = 1 ITP (NODE) = 2 ELSEIF(TYP(NODE).EQ.'CHR') THEN VALI(NODE) = BMISS KNTI(NODE) = 1 ITP (NODE) = 3 ELSE GOTO 901 ENDIF ENDDO C SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES C ---------------------------------------------------------------- NEWN = 0 DO N=1,NTAB ISEQ(N,1) = 0 ISEQ(N,2) = 0 EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS' . .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB' IF(EXPAND) THEN ISEQ(N,1) = NEWN+1 NODA = N NODE = N+1 DO K=1,MAXJL KNT(K) = 0 ENDDO IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA) IF(TYP(NODA).NE.'REP') KNT(NODE) = 1 1 NEWN = NEWN+1 IF(NEWN.GT.MAXJL) GOTO 902 JSEQ(NEWN) = NODE KNT(NODE) = MAX(KNTI(NODE),KNT(NODE)) 2 IF(JUMP(NODE)*KNT(NODE).GT.0) THEN NODE = JUMP(NODE) GOTO 1 ELSE IF(LINK(NODE).GT.0) THEN NODE = LINK(NODE) GOTO 1 ELSE NODE = JMPB(NODE) IF(NODE.EQ.NODA) GOTO 3 IF(NODE.EQ.0 ) GOTO 903 KNT(NODE) = MAX(KNT(NODE)-1,0) GOTO 2 ENDIF 3 ISEQ(N,2) = NEWN ENDIF ENDDO C PRINT THE SEQUENCE TABLES C ------------------------ IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') DO I=1,NTAB WRITE ( UNIT=ERRSTR, FMT='(A,I5,2X,A10,A5,6I8)' ) . 'BUFRLIB: MAKESTAB ', I, TAG(I), TYP(I), JMPB(I), JUMP(I), . LINK(I), IBT(I), IRF(I), ISC(I) CALL ERRWRT(ERRSTR) ENDDO CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '// . 'DUPLICATED IN SUBSET: ",A)') NEMO,TAG(N1) CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')TYP(NODE) CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'// . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '// . 'CIRCULATE (TAG IS ",A,")")') TAG(N) CALL BORT(BORT_STR) END ./maxout.f0000644001370400056700000000622413440555365011453 0ustar jator2emc SUBROUTINE MAXOUT(MAXO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MAXOUT C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE ALLOWS AN APPLICATION PROGRAM TO SET THE C RECORD LENGTH OF NEWLY CREATED BUFR MESSAGES, OVERRIDING THE VALUE C SET IN BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI. THIS MUST BE CALLED C AFTER THE INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF C SINCE OPENBF CALLS BFRINI. THE RECORD LENGTH WILL REMAIN MAXO C UNLESS THIS SUBROUTINE IS CALLED AGAIN WITH A NEW MAXO. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR 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 FOR C INFORMATIONAL PURPOSES C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2006-04-14 J. ATOR -- ADDED MAXO=0 OPTION AND OVERFLOW CHECK C 2009-03-23 D. KEYSER -- NO LONGER PRINTS THE RECORD LENGTH CHANGE C DIAGNOSTIC IF THE REQUESTED RECORD LENGTH C PASSED IN AS MAXO IS ACTUALLY THE SAME AS C THE PREVIOUS RECORD LENGTH C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- CORRECT TYPOS IN DOCBLOCK C C USAGE: CALL MAXOUT (MAXO) C INPUT ARGUMENT LIST: C MAXO - INTEGER: DESIRED MESSAGE LENGTH (BYTES): C 0 = SET RECORD LENGTH TO THE MAXIMUM ALLOWABLE C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) COMMON /QUIET / IPRT CHARACTER*128 ERRSTR CHARACTER*56 DXSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF((MAXO.EQ.0).OR.(MAXO.GT.MXMSGL)) THEN NEWSIZ = MXMSGL ELSE NEWSIZ = MAXO ENDIF IF(IPRT.GE.0) THEN IF(MAXBYT.NE.NEWSIZ) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A,I7)' ) . 'BUFRLIB: MAXOUT - THE RECORD LENGTH OF ALL BUFR MESSAGES ', . 'CREATED FROM THIS POINT ON IS BEING CHANGED FROM ', MAXBYT, . ' TO ', NEWSIZ CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF ENDIF MAXBYT = NEWSIZ MAXCMB = NEWSIZ MAXDX = NEWSIZ RETURN END ./mesgbc.f0000644001370400056700000001647213440555365011404 0ustar jator2emc SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MESGBC C PRGMMR: KEYSER ORG: NP22 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH C THE MESSAGE TYPE FROM SECTION 1 AND A MESSAGE COMPRESSION INDICATOR C UNPACKED FROM SECTION 3. IT OBTAINS THE BUFR MESSAGE VIA TWO C DIFFERENT METHODS, BASED UPON THE SIGN OF LUNIN. C IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE READS AND EXAMINES C SECTION 1 OF MESSAGES IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE C FIRST MESSAGE THAT ACTUALLY CONTAINS REPORT DATA {I.E., BEYOND THE C BUFR TABLE (DICTIONARY) MESSAGES AT THE TOP AND, FOR DUMP FILES, C BEYOND THE TWO DUMMY MESSAGES CONTAINING THE CENTER TIME AND THE C DUMP TIME}. IT THEN RETURNS THE MESSAGE TYPE AND COMPRESSION C INDICATOR FOR THIS FIRST DATA MESSAGE. IN THIS CASE, THE BUFR FILE C SHOULD NOT BE OPENED VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF C PRIOR TO CALLING THIS SUBROUTINE. HOWEVER, THE BUFR FILE MUST BE C CONNECTED TO UNIT ABS(LUNIN). WHEN USED THIS WAY, THIS SUBROUTINE C IS IDENTICAL TO BUFR ARCHIVE LIBRARY SUBROUTINE MESGBF EXCEPT MESGBF C DOES NOT RETURN ANY INFORMATION ABOUT COMPRESSION AND MESGBF READS C UNTIL IT FINDS THE FIRST NON-DICTIONARY MESSAGE REGARDLESS OF C WHETHER OR NOT IT CONTAINS ANY REPORTS (I.E., IT WOULD STOP AT THE C DUMMY MESSAGE CONTAINING THE CENTER TIME FOR DUMP FILES). C THE SECOND METHOD IN WHICH THIS SUBROUTINE CAN BE USED OCCURS C WHEN LUNIN IS PASSED IN WITH A VALUE LESS THAN ZERO. IN THIS CASE, C IT SIMPLY RETURNS THE MESSAGE TYPE AND COMPRESSION INDICATOR FOR THE C BUFR MESSAGE CURRENTLY STORED IN THE INTERNAL MESSAGE BUFFER (ARRAY C MBAY IN MODULE BITBUF). IN THIS CASE, THE BUFR FILE C CONNECTED TO ABS(LUNIN) MUST HAVE BEEN PREVIOUSLY OPENED FOR INPUT C OPERATIONS BY BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF, AND THE BUFR C MESSAGE MUST HAVE BEEN READ INTO MEMORY BY BUFR ARCHIVE LIBRARY C ROUTINE READMG OR EQUIVALENT. C C PROGRAM HISTORY LOG: C 2003-11-04 D. KEYSER -- ORIGINAL AUTHOR C 2004-06-29 D. KEYSER -- ADDED NEW OPTION TO RETURN MESSAGE TYPE AND C COMPRESSION INDICATOR FOR BUFR MESSAGE C CURRENTLY STORED IN MEMORY (TRIGGERED BY C INPUT ARGUMENT LUNIN LESS THAN ZERO) 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 IUPBS01, GETLENS AND RDMSGW C 2009-03-23 J. ATOR -- USE IUPBS3 AND IDXMSG C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE C ADD OPENBF AND CLOSBF FOR THE CASE C WHEN LUNIN GT 0 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL MESGBC (LUNIN, MESGTYP, ICOMP) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C - IF LUNIN IS GREATER THAN ZERO, THIS SUBROUTINE C READS THROUGH ALL BUFR MESSAGES FROM BEGINNING OF C FILE UNTIL IT FINDS THE FIRST MESSAGE CONTAINING C REPORT DATA C - IF LUNIN IS LESS THAN ZERO, THIS SUBROUTINE C OPERATES ON THE BUFR MESSAGE CURRENTLY STORED IN C MEMORY C C OUTPUT ARGUMENT LIST: C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR EITHER THE FIRST C MESSAGE IN FILE CONTAINING REPORT DATA (IF LUNIN > 0), C OR FOR THE MESSAGE CURRENTLY IN MEMORY (IF LUNIN < 0) C -256 = for LUNIN > 0 case only: no messages read C or error reading file C < 0 = for LUNIN > 0 case only: none of the C messages read contain reports; this is the C negative of the message type the last C message read (i.e., -11 indicates the BUFR C file contains only BUFR table messages) C ICOMP - INTEGER: BUFR MESSAGE COMPRESSION SWITCH: C -3 = for LUNIN > 0 case only: BUFR file does not C exist C -2 = for LUNIN > 0 case only: BUFR file does not C contain any report messages C -1 = for LUNIN > 0 case only: cannot determine C if first BUFR message containing report C data is compressed due to error reading C file C 0 = BUFR message (either first containing C report data if LUNIN > 0, or that currently C in memory if LUNIN < 0) is NOT compressed C 1 = BUFR message (either first containing C report data if LUNIN > 0, or that currently C in memory if LUNIN < 0) IS compressed C C INPUT FILES: C UNIT ABS(LUNIN) - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 IUPBS3 C OPENBF RDMSGW STATUS C THIS ROUTINE IS CALLED BY: COPYSB UFBTAB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BITBUF USE MODA_MGWA INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- LUNIT = ABS(LUNIN) C DETERMINE METHOD OF OPERATION BASED ON SIGN OF LUNIN C LUNIN > 0 - REWIND AND LOOK FOR FIRST DATA MESSAGE (ITYPE = 0) C LUNIN < 0 - LOOK AT MESSAGE CURRENLY IN MEMORY (ITYPE = 1) C --------------------------------------------------------------- ITYPE = 0 IF(LUNIT.NE.LUNIN) ITYPE = 1 ICOMP = -1 MESGTYP = -256 IF(ITYPE.EQ.0) THEN IREC = 0 C CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET C --------------------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND C ----------------------------------------------------------------- 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.EQ.-1) GOTO 900 IF(IER.EQ.-2) GOTO 901 IREC = IREC + 1 MESGTYP = IUPBS01(MGWA,'MTYP') IF((IDXMSG(MGWA).EQ.1).OR.(IUPBS3(MGWA,'NSUB').EQ.0)) GOTO 1 ELSE C RETURN MESSAGE TYPE FOR MESSAGE CURRENTLY STORED IN MEMORY C ---------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) DO I=1,12 MGWA(I) = MBAY(I,LUN) ENDDO MESGTYP = IUPBS01(MGWA,'MTYP') END IF C SET THE COMPRESSION SWITCH C -------------------------- ICOMP = IUPBS3(MGWA,'ICMP') GOTO 100 C CAN ONLY GET TO STATEMENTS 900 OR 901 WHEN ITYPE = 0 C ---------------------------------------------------- 900 IF(IREC.EQ.0) THEN MESGTYP = -256 ICOMP = -3 ELSE IF(MESGTYP.GE.0) MESGTYP = -MESGTYP ICOMP = -2 ENDIF GOTO 100 901 MESGTYP = -256 ICOMP = -1 C EXIT C ---- 100 IF(ITYPE.EQ.0) CALL CLOSBF(LUNIT) RETURN END ./mesgbf.f0000644001370400056700000000704013440555365011376 0ustar jator2emc SUBROUTINE MESGBF(LUNIT,MESGTYP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MESGBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS AND EXAMINES SECTION 1 OF MESSAGES C IN A BUFR FILE IN SEQUENCE UNTIL IT FINDS THE FIRST MESSAGE THAT C IS NOT A BUFR TABLE (DICTIONARY) MESSAGE. IT THEN RETURNS THE C MESSAGE TYPE FOR THIS FIRST NON-DICTIONARY MESSAGE. THE BUFR FILE C SHOULD NOT BE OPEN VIA BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF PRIOR C TO CALLING THIS SUBROUTINE; HOWEVER, THE BUFR FILE MUST BE CONNECTED C TO UNIT LUNIT. THIS SUBROUTINE IS IDENTICAL TO BUFR ARCHIVE LIBRARY C SUBROUTINE MESGBC EXCEPT THAT MESGBC RETURNS THE MESSAGE TYPE FOR C THE FIRST NON-DICTIONARY MESSAGE THAT ACTUALLY CONTAINS REPORT DATA C (WHEREAS MESGBF WOULD RETURN THE REPORT TYPE OF A DUMMY MESSAGE C CONTAINING THE CENTER TIME FOR DUMP FILES), AND MESGBC ALSO C INDICATES WHETHER OR NOT THE FIRST REPORT DATA MESSAGE IS BUFR C COMPRESSED. MESGBC ALSO HAS AN OPTION TO OPERATE ON THE CURRENT C MESSAGE STORED IN MEMORY, WHICH IS SOMETHING THAT MESGBF CANNOT DO. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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) 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 IUPBS01 AND RDMSGW C 2009-03-23 J. ATOR -- USE IDXMSG C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE C THE C FILE WITHOUT CLOSING THE FORTRAN FILE C 2013-01-25 J. WOOLLEN -- ALWAYS CALL CLOSBF BEFORE EXITING C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL MESGBF (LUNIT, MESGTYP) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C MESGTYP - INTEGER: BUFR MESSAGE TYPE FOR FIRST NON-DICTIONARY C MESSAGE C -1 = no messages read or error C 11 = if only BUFR table messages in BUFR file C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: CLOSBF IDXMSG IUPBS01 OPENBF C RDMSGW C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- MESGTYP = -1 C SINCE OPENBF HAS NOT YET BEEN CALLED, CALL IT C --------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) C READ PAST ANY BUFR TABLES AND RETURN THE FIRST MESSAGE TYPE FOUND C ----------------------------------------------------------------- 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.EQ.0) THEN MESGTYP = IUPBS01(MGWA,'MTYP') IF(IDXMSG(MGWA).EQ.1) GOTO 1 ENDIF C CLOSE THE FILE C -------------- CALL CLOSBF(LUNIT) C EXIT C ---- 100 RETURN END ./minimg.f0000644001370400056700000000604113440555365011413 0ustar jator2emc SUBROUTINE MINIMG(LUNIT,MINI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MINIMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PACKS THE VALUE OF MINI INTO SECTION 1 OF C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT, C SO THAT THIS VALUE THEN BECOMES THE MINUTES COMPONENT OF THE C SECTION 1 DATE-TIME FOR THE MESSAGE. THIS SUBROUTINE SHOULD ONLY C BE CALLED WHEN LOGICAL UNIT LUNIT HAS BEEN OPENED FOR OUTPUT C OPERATIONS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN MSGINI) C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" (IN PARENT ROUTINE MSGINI) 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) (IN PARENT C ROUTINE MSGINI) C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES (IN PARENT ROUTINE C MSGINI) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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 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 PKBS1 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL MINIMG (LUNIT, MINI) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C MINI - INTEGER: MINUTES VALUE TO BE PACKED C C REMARKS: C THIS ROUTINE CALLS: BORT PKBS1 STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C$$$ USE MODA_BITBUF INCLUDE 'bufrlib.prm' CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 CALL PKBS1(MINI,MBAY(1,LUN),'MINU') C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') END ./moda_bitbuf.F0000644001370400056700000000066213440555365012351 0ustar jator2emc MODULE MODA_BITBUF #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif INTEGER :: MAXBYT INTEGER :: IBIT #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IBAY(:) INTEGER, ALLOCATABLE :: MBYT(:) INTEGER, ALLOCATABLE :: MBAY(:,:) #else INTEGER :: IBAY(MXMSGLD4) INTEGER :: MBYT(NFILES) INTEGER :: MBAY(MXMSGLD4,NFILES) #endif END MODULE ./moda_bitmaps.F0000644001370400056700000000172613440555365012537 0ustar jator2emc MODULE MODA_BITMAPS #ifndef MXBTM_H #define MXBTM_H USE MODV_MXBTM #endif #ifndef MXBTMSE_H #define MXBTMSE_H USE MODV_MXBTMSE #endif #ifndef MXTCO_H #define MXTCO_H USE MODV_MXTCO #endif #ifndef MXTAMC_H #define MXTAMC_H USE MODV_MXTAMC #endif INTEGER :: NBTM INTEGER :: NTAMC INTEGER :: LSTNOD INTEGER :: LSTNODCT LOGICAL :: LINBTM #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: INODTAMC(:) INTEGER, ALLOCATABLE :: NTCO(:) CHARACTER*6, ALLOCATABLE :: CTCO(:,:) INTEGER, ALLOCATABLE :: INODTCO(:,:) INTEGER, ALLOCATABLE :: NBTMSE(:) INTEGER, ALLOCATABLE :: ISTBTM(:) INTEGER, ALLOCATABLE :: ISZBTM(:) INTEGER, ALLOCATABLE :: IBTMSE(:,:) #else INTEGER :: INODTAMC(MXTAMC) INTEGER :: NTCO(MXTAMC) CHARACTER*6 :: CTCO(MXTAMC,MXTCO) INTEGER :: INODTCO(MXTAMC,MXTCO) INTEGER :: NBTMSE(MXBTM) INTEGER :: ISTBTM(MXBTM) INTEGER :: ISZBTM(MXBTM) INTEGER :: IBTMSE(MXBTM,MXBTMSE) #endif END MODULE ./moda_bufrmg.F0000644001370400056700000000052213465106723012350 0ustar jator2emc MODULE MODA_BUFRMG #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MSGLEN(:) INTEGER, ALLOCATABLE :: MSGTXT(:,:) #else INTEGER :: MSGLEN(NFILES) INTEGER :: MSGTXT(MXMSGLD4,NFILES) #endif END MODULE ./moda_bufrsr.F0000644001370400056700000000077513440555365012406 0ustar jator2emc MODULE MODA_BUFRSR #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif INTEGER :: JUNN INTEGER :: JILL INTEGER :: JIMM INTEGER :: JBIT INTEGER :: JBYT INTEGER :: JMSG INTEGER :: JSUB INTEGER :: KSUB INTEGER :: JNOD INTEGER :: JDAT #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: JSR(:) INTEGER, ALLOCATABLE :: JBAY(:) #else INTEGER :: JSR(NFILES) INTEGER :: JBAY(MXMSGLD4) #endif END MODULE ./moda_comprs.F0000644001370400056700000000064613440555365012403 0ustar jator2emc MODULE MODA_COMPRS #ifndef MXCSB_H #define MXCSB_H USE MODV_MXCSB #endif #ifndef MXCDV_H #define MXCDV_H USE MODV_MXCDV #endif #ifndef MXLCC_H #define MXLCC_H USE MODV_MXLCC #endif INTEGER :: NCOL #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MATX(:,:) CHARACTER*(:), ALLOCATABLE :: CATX(:,:) #else INTEGER :: MATX(MXCDV,MXCSB) CHARACTER*(MXLCC) :: CATX(MXCDV,MXCSB) #endif END MODULE ./moda_comprx.F0000644001370400056700000000133313440555365012402 0ustar jator2emc MODULE MODA_COMPRX #ifndef MXCDV_H #define MXCDV_H USE MODV_MXCDV #endif #ifndef MXLCC_H #define MXLCC_H USE MODV_MXLCC #endif INTEGER :: NROW INTEGER :: LUNC INTEGER :: KBYT LOGICAL :: FLUSH LOGICAL :: WRIT1 #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: KMIN(:) INTEGER, ALLOCATABLE :: KMAX(:) LOGICAL, ALLOCATABLE :: KMIS(:) INTEGER, ALLOCATABLE :: KBIT(:) INTEGER, ALLOCATABLE :: ITYP(:) INTEGER, ALLOCATABLE :: IWID(:) CHARACTER*(:), ALLOCATABLE :: CSTR(:) #else INTEGER :: KMIN(MXCDV) INTEGER :: KMAX(MXCDV) LOGICAL :: KMIS(MXCDV) INTEGER :: KBIT(MXCDV) INTEGER :: ITYP(MXCDV) INTEGER :: IWID(MXCDV) CHARACTER*(MXLCC) :: CSTR(MXCDV) #endif END MODULE ./moda_h4wlc.F0000644001370400056700000000033713440555365012116 0ustar jator2emc MODULE MODA_H4WLC #ifndef MXH4WLC_H #define MXH4WLC_H USE MODV_MXH4WLC #endif INTEGER :: NH4WLC INTEGER :: LUH4WLC(MXH4WLC) CHARACTER*14 :: STH4WLC(MXH4WLC) CHARACTER*120 :: CHH4WLC(MXH4WLC) END MODULE ./moda_idrdm.F0000644001370400056700000000030513440555365012167 0ustar jator2emc MODULE MODA_IDRDM #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IDRDM(:) #else INTEGER :: IDRDM(NFILES) #endif END MODULE ./moda_ifopbf.F0000644001370400056700000000030113440555365012331 0ustar jator2emc MODULE MODA_IFOPBF C IFOPBF is a flag variable which keeps track of whether C subroutine OPENBF has already been called: C 0 = no C 1 = yes INTEGER :: IFOPBF = 0 END MODULE ./moda_ival.F0000644001370400056700000000027313440555365012027 0ustar jator2emc MODULE MODA_IVAL #ifndef MAXSS_H #define MAXSS_H USE MODV_MAXSS #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IVAL(:) #else INTEGER IVAL(MAXSS) #endif END MODULE ./moda_ivttmp.F0000644001370400056700000000050413440555365012414 0ustar jator2emc MODULE MODA_IVTTMP #ifndef MAXJL_H #define MAXJL_H USE MODV_MAXJL #endif #ifdef DYNAMIC_ALLOCATION CHARACTER*10, ALLOCATABLE :: TTMP(:) INTEGER, ALLOCATABLE :: ITMP(:) REAL*8, ALLOCATABLE :: VTMP(:) #else CHARACTER*10 :: TTMP(MAXJL) INTEGER :: ITMP(MAXJL) REAL*8 :: VTMP(MAXJL) #endif END MODULE ./moda_lushr.F0000644001370400056700000000030113440555365012221 0ustar jator2emc MODULE MODA_LUSHR #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: LUS(:) #else INTEGER :: LUS(NFILES) #endif END MODULE ./moda_mgwa.F0000644001370400056700000000030113440555365012017 0ustar jator2emc MODULE MODA_MGWA #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MGWA(:) #else INTEGER MGWA(MXMSGLD4) #endif END MODULE ./moda_mgwb.F0000644001370400056700000000030113440555365012020 0ustar jator2emc MODULE MODA_MGWB #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MGWB(:) #else INTEGER MGWB(MXMSGLD4) #endif END MODULE ./moda_msgcwd.F0000644001370400056700000000070013440555365012353 0ustar jator2emc MODULE MODA_MSGCWD #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: NMSG(:) INTEGER, ALLOCATABLE :: NSUB(:) INTEGER, ALLOCATABLE :: MSUB(:) INTEGER, ALLOCATABLE :: INODE(:) INTEGER, ALLOCATABLE :: IDATE(:) #else INTEGER :: NMSG(NFILES) INTEGER :: NSUB(NFILES) INTEGER :: MSUB(NFILES) INTEGER :: INODE(NFILES) INTEGER :: IDATE(NFILES) #endif END MODULE ./moda_msglim.F0000644001370400056700000000031013440555365012354 0ustar jator2emc MODULE MODA_MSGLIM #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MSGLIM(:) #else INTEGER :: MSGLIM(NFILES) #endif END MODULE ./moda_msgmem.F0000644001370400056700000000174313440555365012364 0ustar jator2emc MODULE MODA_MSGMEM #ifndef MAXMSG_H #define MAXMSG_H USE MODV_MAXMSG #endif #ifndef MAXMEM_H #define MAXMEM_H USE MODV_MAXMEM #endif #ifndef MXDXTS_H #define MXDXTS_H USE MODV_MXDXTS #endif #ifndef MXMSGL_H #define MXMSGL_H USE MODV_MXMSGL #endif INTEGER :: MUNIT INTEGER :: MLAST INTEGER :: LDXM INTEGER :: NDXM INTEGER :: LDXTS INTEGER :: NDXTS #ifdef DYNAMIC_ALLOCATION INTEGER :: MXDXM INTEGER :: MXDXW INTEGER, ALLOCATABLE :: MSGP(:) INTEGER, ALLOCATABLE :: MSGS(:) INTEGER, ALLOCATABLE :: MDX(:) INTEGER, ALLOCATABLE :: IPDXM(:) INTEGER, ALLOCATABLE :: IFDXTS(:) INTEGER, ALLOCATABLE :: ICDXTS(:) INTEGER, ALLOCATABLE :: IPMSGS(:) #else PARAMETER ( MXDXM = MXDXTS*3 ) PARAMETER ( MXDXW = MXDXM*MXMSGLD4 ) INTEGER :: MSGP(0:MAXMSG) INTEGER :: MSGS(MAXMEM) INTEGER :: MDX(MXDXW) INTEGER :: IPDXM(MXDXM) INTEGER :: IFDXTS(MXDXTS) INTEGER :: ICDXTS(MXDXTS) INTEGER :: IPMSGS(MXDXTS) #endif END MODULE ./moda_mstabs.F0000644001370400056700000000245113440555365012365 0ustar jator2emc MODULE MODA_MSTABS #ifndef MAXCD_H #define MAXCD_H USE MODV_MAXCD #endif #ifndef MXMTBB_H #define MXMTBB_H USE MODV_MXMTBB #endif #ifndef MXMTBD_H #define MXMTBD_H USE MODV_MXMTBD #endif #ifdef DYNAMIC_ALLOCATION INTEGER :: NMTB INTEGER :: NMTD INTEGER, ALLOCATABLE :: IBFXYN(:) CHARACTER*4, ALLOCATABLE :: CBSCL(:) CHARACTER*12, ALLOCATABLE :: CBSREF(:) CHARACTER*4, ALLOCATABLE :: CBBW(:) CHARACTER*14, ALLOCATABLE :: CBUNIT(:) CHARACTER*8, ALLOCATABLE :: CBMNEM(:) CHARACTER*120, ALLOCATABLE :: CBELEM(:) INTEGER, ALLOCATABLE :: IDFXYN(:) CHARACTER*120, ALLOCATABLE :: CDSEQ(:) CHARACTER*8, ALLOCATABLE :: CDMNEM(:) INTEGER, ALLOCATABLE :: NDELEM(:) INTEGER, ALLOCATABLE :: IDEFXY(:) #else INTEGER, BIND(C) :: NMTB INTEGER, BIND(C) :: NMTD INTEGER, BIND(C) :: IBFXYN(MXMTBB) CHARACTER*4, BIND(C) :: CBSCL(MXMTBB) CHARACTER*12, BIND(C) :: CBSREF(MXMTBB) CHARACTER*4, BIND(C) :: CBBW(MXMTBB) CHARACTER*14, BIND(C) :: CBUNIT(MXMTBB) CHARACTER*8, BIND(C) :: CBMNEM(MXMTBB) CHARACTER*120, BIND(C) :: CBELEM(MXMTBB) INTEGER, BIND(C) :: IDFXYN(MXMTBD) CHARACTER*120, BIND(C) :: CDSEQ(MXMTBD) CHARACTER*8, BIND(C) :: CDMNEM(MXMTBD) INTEGER, BIND(C) :: NDELEM(MXMTBD) INTEGER, BIND(C) :: IDEFXY(MXMTBD*MAXCD) #endif END MODULE ./moda_nmikrp.F0000644001370400056700000000051313440555365012371 0ustar jator2emc MODULE MODA_NMIKRP #ifndef MAXCD_H #define MAXCD_H USE MODV_MAXCD #endif #ifdef DYNAMIC_ALLOCATION CHARACTER*8, ALLOCATABLE :: NEM(:,:) INTEGER, ALLOCATABLE :: IRP(:,:) INTEGER, ALLOCATABLE :: KRP(:,:) #else CHARACTER*8 :: NEM(MAXCD,10) INTEGER :: IRP(MAXCD,10) INTEGER :: KRP(MAXCD,10) #endif END MODULE ./moda_nrv203.F0000644001370400056700000000101513440555365012121 0ustar jator2emc MODULE MODA_NRV203 #ifndef MXNRV_H #define MXNRV_H USE MODV_MXNRV #endif INTEGER :: NNRV INTEGER :: IBTNRV INTEGER :: IPFNRV #ifdef DYNAMIC_ALLOCATION CHARACTER*8, ALLOCATABLE :: TAGNRV(:) INTEGER, ALLOCATABLE :: INODNRV(:) INTEGER, ALLOCATABLE :: NRV(:) INTEGER, ALLOCATABLE :: ISNRV(:) INTEGER, ALLOCATABLE :: IENRV(:) #else CHARACTER*8 :: TAGNRV(MXNRV) INTEGER :: INODNRV(MXNRV) INTEGER :: NRV(MXNRV) INTEGER :: ISNRV(MXNRV) INTEGER :: IENRV(MXNRV) #endif END MODULE ./moda_nulbfr.F0000644001370400056700000000030413440555365012357 0ustar jator2emc MODULE MODA_NULBFR #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: NULL(:) #else INTEGER :: NULL(NFILES) #endif END MODULE ./moda_rdmtb.F0000644001370400056700000000106013440555365012177 0ustar jator2emc MODULE MODA_RDMTB #ifndef MAXCD_H #define MAXCD_H USE MODV_MAXCD #endif #ifndef MXMTBB_H #define MXMTBB_H USE MODV_MXMTBB #endif #ifndef MXMTBD_H #define MXMTBD_H USE MODV_MXMTBD #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IEFXYN(:,:) CHARACTER*4, ALLOCATABLE :: CMDSCB(:) CHARACTER*4, ALLOCATABLE :: CMDSCD(:) CHARACTER*120, ALLOCATABLE :: CEELEM(:,:) #else INTEGER :: IEFXYN(MXMTBD,MAXCD) CHARACTER*4 :: CMDSCB(MXMTBB) CHARACTER*4 :: CMDSCD(MXMTBD) CHARACTER*120 :: CEELEM(MXMTBD,MAXCD) #endif END MODULE ./moda_rlccmn.F0000644001370400056700000000054113440555365012350 0ustar jator2emc MODULE MODA_RLCCMN #ifndef MXRST_H #define MXRST_H USE MODV_MXRST #endif INTEGER :: NRST #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IRNCH(:) INTEGER, ALLOCATABLE :: IRBIT(:) CHARACTER*10, ALLOCATABLE :: CRTAG(:) #else INTEGER :: IRNCH(MXRST) INTEGER :: IRBIT(MXRST) CHARACTER*10 :: CRTAG(MXRST) #endif END MODULE ./moda_s01cm.F0000644001370400056700000000044613440555365012021 0ustar jator2emc MODULE MODA_S01CM #ifndef MXS01V_H #define MXS01V_H USE MODV_MXS01V #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IVMNEM(:) CHARACTER*8, ALLOCATABLE :: CMNEM(:) #else INTEGER :: IVMNEM(MXS01V) CHARACTER*8 :: CMNEM(MXS01V) #endif INTEGER :: NS01V = 0 END MODULE ./moda_sc3bfr.F0000644001370400056700000000041613440555365012255 0ustar jator2emc MODULE MODA_SC3BFR #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: ISC3(:) CHARACTER*8, ALLOCATABLE :: TAMNEM(:) #else INTEGER :: ISC3(NFILES) CHARACTER*8 :: TAMNEM(NFILES) #endif END MODULE ./moda_stbfr.F0000644001370400056700000000040513440555365012211 0ustar jator2emc MODULE MODA_STBFR #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IOLUN(:) INTEGER, ALLOCATABLE :: IOMSG(:) #else INTEGER :: IOLUN(NFILES) INTEGER :: IOMSG(NFILES) #endif END MODULE ./moda_stcode.F0000644001370400056700000000031213440555365012347 0ustar jator2emc MODULE MODA_STCODE #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: ISCODES(:) #else INTEGER :: ISCODES(NFILES) #endif END MODULE ./moda_tababd.F0000644001370400056700000000202613440555365012307 0ustar jator2emc MODULE MODA_TABABD #ifndef MAXTBA_H #define MAXTBA_H USE MODV_MAXTBA #endif #ifndef MAXTBB_H #define MAXTBB_H USE MODV_MAXTBB #endif #ifndef MAXTBD_H #define MAXTBD_H USE MODV_MAXTBD #endif #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: NTBA(:) INTEGER, ALLOCATABLE :: NTBB(:) INTEGER, ALLOCATABLE :: NTBD(:) INTEGER, ALLOCATABLE :: MTAB(:,:) INTEGER, ALLOCATABLE :: IDNA(:,:,:) INTEGER, ALLOCATABLE :: IDNB(:,:) INTEGER, ALLOCATABLE :: IDND(:,:) CHARACTER*128, ALLOCATABLE :: TABA(:,:) CHARACTER*128, ALLOCATABLE :: TABB(:,:) CHARACTER*600, ALLOCATABLE :: TABD(:,:) #else INTEGER :: NTBA(0:NFILES) INTEGER :: NTBB(0:NFILES) INTEGER :: NTBD(0:NFILES) INTEGER :: MTAB(MAXTBA,NFILES) INTEGER :: IDNA(MAXTBA,NFILES,2) INTEGER :: IDNB(MAXTBB,NFILES) INTEGER :: IDND(MAXTBD,NFILES) CHARACTER*128 :: TABA(MAXTBA,NFILES) CHARACTER*128 :: TABB(MAXTBB,NFILES) CHARACTER*600 :: TABD(MAXTBD,NFILES) #endif END MODULE ./moda_tables.F0000644001370400056700000000201113440555365012336 0ustar jator2emc MODULE MODA_TABLES #ifndef MAXJL_H #define MAXJL_H USE MODV_MAXJL #endif INTEGER :: MAXTAB INTEGER :: NTAB #ifdef DYNAMIC_ALLOCATION CHARACTER*10, ALLOCATABLE :: TAG(:) CHARACTER*3, ALLOCATABLE :: TYP(:) INTEGER, ALLOCATABLE :: KNT(:) INTEGER, ALLOCATABLE :: JUMP(:) INTEGER, ALLOCATABLE :: LINK(:) INTEGER, ALLOCATABLE :: JMPB(:) INTEGER, ALLOCATABLE :: IBT(:) INTEGER, ALLOCATABLE :: IRF(:) INTEGER, ALLOCATABLE :: ISC(:) INTEGER, ALLOCATABLE :: ITP(:) REAL*8, ALLOCATABLE :: VALI(:) INTEGER, ALLOCATABLE :: KNTI(:) INTEGER, ALLOCATABLE :: ISEQ(:,:) INTEGER, ALLOCATABLE :: JSEQ(:) #else CHARACTER*10 :: TAG(MAXJL) CHARACTER*3 :: TYP(MAXJL) INTEGER :: KNT(MAXJL) INTEGER :: JUMP(MAXJL) INTEGER :: LINK(MAXJL) INTEGER :: JMPB(MAXJL) INTEGER :: IBT(MAXJL) INTEGER :: IRF(MAXJL) INTEGER :: ISC(MAXJL) INTEGER :: ITP(MAXJL) REAL*8 :: VALI(MAXJL) INTEGER :: KNTI(MAXJL) INTEGER :: ISEQ(MAXJL,2) INTEGER :: JSEQ(MAXJL) #endif END MODULE ./moda_ufbcpl.F0000644001370400056700000000031013440555365012337 0ustar jator2emc MODULE MODA_UFBCPL #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: LUNCPY(:) #else INTEGER :: LUNCPY(NFILES) #endif END MODULE ./moda_unptyp.F0000644001370400056700000000031013440555365012423 0ustar jator2emc MODULE MODA_UNPTYP #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: MSGUNP(:) #else INTEGER :: MSGUNP(NFILES) #endif END MODULE ./moda_usrbit.F0000644001370400056700000000037513440555365012407 0ustar jator2emc MODULE MODA_USRBIT #ifndef MAXSS_H #define MAXSS_H USE MODV_MAXSS #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: NBIT(:) INTEGER, ALLOCATABLE :: MBIT(:) #else INTEGER :: NBIT(MAXSS) INTEGER :: MBIT(MAXSS) #endif END MODULE ./moda_usrint.F0000644001370400056700000000071613440555365012422 0ustar jator2emc MODULE MODA_USRINT #ifndef MAXSS_H #define MAXSS_H USE MODV_MAXSS #endif #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: NVAL(:) INTEGER, ALLOCATABLE :: INV(:,:) INTEGER, ALLOCATABLE :: NRFELM(:,:) REAL*8, ALLOCATABLE :: VAL(:,:) #else INTEGER :: NVAL(NFILES) INTEGER :: INV(MAXSS,NFILES) INTEGER :: NRFELM(MAXSS,NFILES) REAL*8 :: VAL(MAXSS,NFILES) #endif END MODULE ./moda_usrtmp.F0000644001370400056700000000045713440555365012432 0ustar jator2emc MODULE MODA_USRTMP #ifndef MAXJL_H #define MAXJL_H USE MODV_MAXJL #endif PARAMETER ( MAXRCR = 100 ) #ifdef DYNAMIC_ALLOCATION INTEGER, ALLOCATABLE :: IUTMP(:,:) REAL*8, ALLOCATABLE :: VUTMP(:,:) #else INTEGER :: IUTMP(MAXJL,MAXRCR) REAL*8 :: VUTMP(MAXJL,MAXRCR) #endif END MODULE ./moda_xtab.F0000644001370400056700000000030213440555365012023 0ustar jator2emc MODULE MODA_XTAB #ifndef NFILES_H #define NFILES_H USE MODV_NFILES #endif #ifdef DYNAMIC_ALLOCATION LOGICAL, ALLOCATABLE :: XTAB(:) #else LOGICAL :: XTAB(NFILES) #endif END MODULE ./modv_MAXCD.F0000644001370400056700000000121413440555365011751 0ustar jator2emc MODULE MODV_MAXCD C MAXCD is the maximum number of child descriptors that can C be included within the sequence definition of a Table D C descriptor. C This value must be identically defined in the C header C file bufrlib.h C Note that this value does *not* need to take into account C the recursive resolution of any child descriptors which may C themselves be Table D descriptors. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXCD. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXCD = 250 #else PARAMETER ( MAXCD = 250 ) #endif END MODULE ./modv_MAXJL.F0000644001370400056700000000054113440555365011772 0ustar jator2emc MODULE MODV_MAXJL C MAXJL is the maximum number of entries in the internal C jump/link table. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXJL. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXJL = 84000 #else PARAMETER ( MAXJL = 96000 ) #endif END MODULE ./modv_MAXMEM.F0000644001370400056700000000061113440555365012101 0ustar jator2emc MODULE MODV_MAXMEM C MAXMEM is the maximum number of bytes that can be used to C store BUFR messages within internal memory. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXMEM. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXMEM = 50000000 #else PARAMETER ( MAXMEM = 50000000 ) #endif END MODULE ./modv_MAXMSG.F0000644001370400056700000000057013440555365012115 0ustar jator2emc MODULE MODV_MAXMSG C MAXMSG is the maximum number of BUFR messages that can be C stored within internal memory. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXMSG. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXMSG = 200000 #else PARAMETER ( MAXMSG = 200000 ) #endif END MODULE ./modv_MAXSS.F0000644001370400056700000000061513440555365012014 0ustar jator2emc MODULE MODV_MAXSS C MAXSS is the maximum number of data values that can be read C from or written into a subset by the BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXSS. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXSS = 80000 #else PARAMETER ( MAXSS = 120000 ) #endif END MODULE ./modv_MAXTBA.F0000644001370400056700000000064013440555365012073 0ustar jator2emc MODULE MODV_MAXTBA C MAXTBA is the maximum number of entries in the internal BUFR C Table A for each BUFR file that is connected to the BUFRLIB C software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXTBA. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXTBA = 150 #else PARAMETER ( MAXTBA = 150 ) #endif END MODULE ./modv_MAXTBB.F0000644001370400056700000000064013440555365012074 0ustar jator2emc MODULE MODV_MAXTBB C MAXTBB is the maximum number of entries in the internal BUFR C Table B for each BUFR file that is connected to the BUFRLIB C software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXTBB. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXTBB = 500 #else PARAMETER ( MAXTBB = 500 ) #endif END MODULE ./modv_MAXTBD.F0000644001370400056700000000064013440555365012076 0ustar jator2emc MODULE MODV_MAXTBD C MAXTBD is the maximum number of entries in the internal BUFR C Table D for each BUFR file that is connected to the BUFRLIB C software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MAXTBD. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MAXTBD = 500 #else PARAMETER ( MAXTBD = 500 ) #endif END MODULE ./modv_MXBTM.F0000644001370400056700000000055113440555365012007 0ustar jator2emc MODULE MODV_MXBTM C MXBTM is the maximum number of bitmaps that can be stored C internally for a BUFR subset. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXBTM. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXBTM = 5 #else PARAMETER ( MXBTM = 5 ) #endif END MODULE ./modv_MXBTMSE.F0000644001370400056700000000063413471266354012242 0ustar jator2emc MODULE MODV_MXBTMSE C MXBTMSE is the maximum number of entries that can be set C within a bitmap. An entry is "set" if the bit has a value C of 0. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXBTMSE. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXBTMSE = 500 #else PARAMETER ( MXBTMSE = 500 ) #endif END MODULE ./modv_MXCDV.F0000644001370400056700000000063613440555365012005 0ustar jator2emc MODULE MODV_MXCDV C MXCDV is the maximum number of data values that can be C written into a subset of a compressed BUFR message by the C BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXCDV. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXCDV = 3000 #else PARAMETER ( MXCDV = 3000 ) #endif END MODULE ./modv_MXCSB.F0000644001370400056700000000061213440555365011772 0ustar jator2emc MODULE MODV_MXCSB C MXCSB is the maximum number of subsets that can be written C into a compressed BUFR message by the BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXCSB. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXCSB = 4000 #else PARAMETER ( MXCSB = 4000 ) #endif END MODULE ./modv_MXDXTS.F0000644001370400056700000000061513440555365012150 0ustar jator2emc MODULE MODV_MXDXTS C MXDXTS is the maximum number of dictionary tables that can C be stored for use with BUFR messages in internal memory. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXDXTS. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXDXTS = 200 #else PARAMETER ( MXDXTS = 200 ) #endif END MODULE ./modv_MXH4WLC.F0000644001370400056700000000036313440555365012207 0ustar jator2emc MODULE MODV_MXH4WLC C MXH4WLC is the maximum number of long character strings that C can be held for writing into an uncompressed BUFR subset by C future internal calls to subroutine WRITLC. PARAMETER ( MXH4WLC = 10 ) END MODULE ./modv_MXLCC.F0000644001370400056700000000064113440555365011766 0ustar jator2emc MODULE MODV_MXLCC C MXLCC is the maximum length of a character string that can be C written into a subset of a compressed BUFR message by the C BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXLCC. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXLCC = 32 #else PARAMETER ( MXLCC = 32 ) #endif END MODULE ./modv_MXMSGL.F0000644001370400056700000000071213440555365012126 0ustar jator2emc MODULE MODV_MXMSGL C MXMSGL is the maximum length (in bytes) of a BUFR message that C can be read or written by the BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXMSGL. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXMSGL = 200000 INTEGER :: MXMSGLD4 #else PARAMETER ( MXMSGL = 600000 ) PARAMETER ( MXMSGLD4 = MXMSGL/4 ) #endif END MODULE ./modv_MXMTBB.F0000644001370400056700000000053713440555365012115 0ustar jator2emc MODULE MODV_MXMTBB C MXMTBB is the maximum number of entries in the master C BUFR Table B. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXMTBB. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXMTBB = 2500 #else PARAMETER ( MXMTBB = 4000 ) #endif END MODULE ./modv_MXMTBD.F0000644001370400056700000000053613440555365012116 0ustar jator2emc MODULE MODV_MXMTBD C MXMTBD is the maximum number of entries in the master C BUFR Table D. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXMTBD. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXMTBD = 800 #else PARAMETER ( MXMTBD = 1000 ) #endif END MODULE ./modv_MXMTBF.F0000644001370400056700000000125113440555365012113 0ustar jator2emc MODULE MODV_MXMTBF C MXMTBF is the maximum number of entries in the master C BUFR Code/Flag tables. C Note that this maximum count includes all entries across C all Code and Flag tables. In other words, each defined C code figure (within each individual Code table) or defined C bit number (within each individual Flag table) is counted C as a separate "entry" for the purposes of this parameter C value. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXMTBF. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXMTBF = 25000 #else PARAMETER ( MXMTBF = 25000 ) #endif END MODULE ./modv_MXNRV.F0000644001370400056700000000057313440555365012036 0ustar jator2emc MODULE MODV_MXNRV C MXNRV is the maximum number of nodes in the jump/link table C that can contain new 2-03 reference values. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXNRV. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXNRV = 15 #else PARAMETER ( MXNRV = 15 ) #endif END MODULE ./modv_MXRST.F0000644001370400056700000000065013440555365012035 0ustar jator2emc MODULE MODV_MXRST C MXRST is the maximum number of "long" character strings (i.e. C greater than 8 bytes) that can be read from a subset of a C compressed BUFR message. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXRST. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXRST = 50 #else PARAMETER ( MXRST = 50 ) #endif END MODULE ./modv_MXS01V.F0000644001370400056700000000066013440555365012057 0ustar jator2emc MODULE MODV_MXS01V C MXS01V is the maximum number of default Section 0 or C Section 1 values that can be overwritten within an output C BUFR message by the BUFRLIB software. #ifdef DYNAMIC_ALLOCATION C Set a default value for MXS01V. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXS01V = 10 #else PARAMETER ( MXS01V = 10 ) #endif END MODULE ./modv_MXTAMC.F0000644001370400056700000000071613440555365012114 0ustar jator2emc MODULE MODV_MXTAMC C MXTAMC is the maximum number of Table A (subset) mnemonics C in the jump/link table which contain at least one Table C C operator with an X value of 21 or greater in their definition #ifdef DYNAMIC_ALLOCATION C Set a default value for MXTAMC. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXTAMC = 15 #else PARAMETER ( MXTAMC = 15 ) #endif END MODULE ./modv_MXTCO.F0000644001370400056700000000065213440555365012014 0ustar jator2emc MODULE MODV_MXTCO C MXTCO is the maximum number of Table C operators with an C X value of 21 or greater that can appear in the definition C of a Table A (subset) mnemonic #ifdef DYNAMIC_ALLOCATION C Set a default value for MXTCO. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: MXTCO = 30 #else PARAMETER ( MXTCO = 30 ) #endif END MODULE ./modv_NFILES.F0000644001370400056700000000075513440555365012106 0ustar jator2emc MODULE MODV_NFILES C NFILES is the maximum number of BUFR files that can be C connected to the BUFRLIB software (for reading or writing) C at any one time. C This value must be identically defined in the C header C file bufrlib.h #ifdef DYNAMIC_ALLOCATION C Set a default value for NFILES. This value will be used C unless it is overridden by a subsequent user call to C function ISETPRM. INTEGER :: NFILES = 32 #else PARAMETER ( NFILES = 32 ) #endif END MODULE ./mrginv.f0000644001370400056700000000440213440555365011434 0ustar jator2emc SUBROUTINE MRGINV C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MRGINV C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 C C ABSTRACT: THIS SUBROUTINE PRINTS A SUMMARY OF MERGE ACTIVITY. C C PROGRAM HISTORY LOG: C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN INVMRG) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS 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) C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL MRGINV C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT COMMON /QUIET / IPRT CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') CALL ERRWRT('---------------------------------------------------') CALL ERRWRT('INVENTORY FROM MERGE PROCESS IN SUBROUTINE INVMRG:') CALL ERRWRT('---------------------------------------------------') WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) . 'NUMBER OF DRB EXPANSIONS = ', NRPL CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) . 'NUMBER OF MERGES = ', NMRG CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8)' ) . 'NUMBER THAT ARE AMBIGUOUS = ', NAMB CALL ERRWRT(ERRSTR) CALL ERRWRT('---------------------------------------------------') WRITE ( UNIT=ERRSTR, FMT='(A,I9)' ) . 'TOTAL NUMBER OF VISITS = ', NTOT CALL ERRWRT(ERRSTR) CALL ERRWRT('---------------------------------------------------') CALL ERRWRT('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF RETURN END ./msgfull.f0000644001370400056700000000446713440555365011616 0ustar jator2emc LOGICAL FUNCTION MSGFULL(MSIZ,ITOADD,MXSIZ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSGFULL C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS LOGICAL FUNCTION DETERMINES WHETHER THE CURRENT SUBSET C (OF LENGTH ITOADD BYTES) WILL FIT WITHIN THE CURRENT BUFR MESSAGE. C A FINITE AMOUNT OF "WIGGLE ROOM" IS ALLOWED FOR AS SHOWN BELOW. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: MSGFULL (MSIZ,ITOADD,MXSIZ) C INPUT ARGUMENT LIST: C MSIZ - INTEGER: SIZE OF CURRENT MESSAGE (IN BYTES) C ITOADD - INTEGER: SIZE OF SUBSET TO BE ADDED (IN BYTES) C MXSIZ - INTEGER: MAXIMUM SIZE OF A BUFR MESSAGE C C OUTPUT ARGUMENT LIST: C MSGFULL - LOGICAL: FALSE IF SUBSET WILL FIT; TRUE OTHERWISE C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD WRCMPS WRDXTB 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 /MSGSTD/ CSMF COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT CHARACTER*1 CSMF CHARACTER*1 CTRT C---------------------------------------------------------------------- C---------------------------------------------------------------------- C Allow for at least 11 additional bytes of "wiggle room" in the C message, because subroutine MSGWRT may do any or all of the C following: C 3 bytes may be added by a call to subroutine CNVED4 C + 1 byte (at most) of padding may be added to Section 4 C + 7 bytes (at most) of padding may be added up to the next C word boundary after Section 5 C ---- C 11 IWGBYT = 11 C But subroutine MSGWRT may also do any of all of the following: C 6 bytes may be added by a call to subroutine ATRCPT IF(CTRT.EQ.'Y') IWGBYT = IWGBYT + 6 C (MAXNC*2) bytes (at most) may be added by a call to C subroutine STNDRD IF(CSMF.EQ.'Y') IWGBYT = IWGBYT + (MAXNC*2) C Determine whether the subset will fit. IF ( ( MSIZ + ITOADD + IWGBYT ) .GT. MXSIZ ) THEN MSGFULL = .TRUE. ELSE MSGFULL = .FALSE. ENDIF RETURN END ./msgini.f0000644001370400056700000001602013440555365011417 0ustar jator2emc SUBROUTINE MSGINI(LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSGINI C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A C NEW BUFR MESSAGE FOR OUTPUT. ARRAYS ARE FILLED IN COMMON BLOCKS C /MSGPTR/ AND MODULES MSGCWD AND BITBUF. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-12-11 J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN C WRITING THE MESSAGE DATE INTO A BUFR C MESSAGE C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION C WRITTEN IN SECTION 0 FROM 2 TO 3 C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT 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 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A C SEPARATE ROUTINE IN THE BUFRLIB TO C INCREASE PORTABILITY TO OTHER PLATFORMS) 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION; 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 -- CHANGED DEFAULT MASTER TABLE VERSION TO 12 C 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13 C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL MSGINI (LUN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTAB NEMTBA PKB C PKC C THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD OPENMB OPENMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_UFBCPL USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 CHARACTER*128 BORT_STR CHARACTER*8 SUBTAG CHARACTER*4 BUFR,SEVN CHARACTER*1 TAB DATA BUFR/'BUFR'/ DATA SEVN/'7777'/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE C --------------------------------------------------- SUBTAG = TAG(INODE(LUN)) c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD CALL NEMTBA(LUN,SUBTAG,MTYP,MSBT,INOD) IF(INODE(LUN).NE.INOD) GOTO 900 CALL NEMTAB(LUN,SUBTAG,ISUB,TAB,IRET) IF(IRET.EQ.0) GOTO 901 C DATE CAN BE YYMMDDHH OR YYYYMMDDHH C ---------------------------------- MCEN = MOD(IDATE(LUN)/10**8,100)+1 MEAR = MOD(IDATE(LUN)/10**6,100) MMON = MOD(IDATE(LUN)/10**4,100) MDAY = MOD(IDATE(LUN)/10**2,100) MOUR = MOD(IDATE(LUN) ,100) MMIN = 0 c .... DK: Can this happen?? (investigate) IF(MCEN.EQ.1) GOTO 902 IF(MEAR.EQ.0) MCEN = MCEN-1 IF(MEAR.EQ.0) MEAR = 100 C INITIALIZE THE MESSAGE C ---------------------- MBIT = 0 NBY0 = 8 NBY1 = 18 NBY2 = 0 NBY3 = 20 NBY4 = 4 NBY5 = 4 NBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5 C SECTION 0 C --------- CALL PKC(BUFR , 4 , MBAY(1,LUN),MBIT) CALL PKB(NBYT , 24 , MBAY(1,LUN),MBIT) CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) C SECTION 1 C --------- CALL PKB(NBY1 , 24 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 3 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 7 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) CALL PKB(MTYP , 8 , MBAY(1,LUN),MBIT) CALL PKB(MSBT , 8 , MBAY(1,LUN),MBIT) CALL PKB( 29 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) CALL PKB(MEAR , 8 , MBAY(1,LUN),MBIT) CALL PKB(MMON , 8 , MBAY(1,LUN),MBIT) CALL PKB(MDAY , 8 , MBAY(1,LUN),MBIT) CALL PKB(MOUR , 8 , MBAY(1,LUN),MBIT) CALL PKB(MMIN , 8 , MBAY(1,LUN),MBIT) CALL PKB(MCEN , 8 , MBAY(1,LUN),MBIT) C SECTION 3 C --------- CALL PKB(NBY3 , 24 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 16 , MBAY(1,LUN),MBIT) CALL PKB(2**7 , 8 , MBAY(1,LUN),MBIT) CALL PKB(IBCT , 16 , MBAY(1,LUN),MBIT) CALL PKB(ISUB , 16 , MBAY(1,LUN),MBIT) CALL PKB(IPD1 , 16 , MBAY(1,LUN),MBIT) CALL PKB(IPD2 , 16 , MBAY(1,LUN),MBIT) CALL PKB(IPD3 , 16 , MBAY(1,LUN),MBIT) CALL PKB(IPD4 , 16 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) C SECTION 4 C --------- CALL PKB(NBY4 , 24 , MBAY(1,LUN),MBIT) CALL PKB( 0 , 8 , MBAY(1,LUN),MBIT) C SECTION 5 C --------- CALL PKC(SEVN , 4 , MBAY(1,LUN),MBIT) C DOUBLE CHECK INITIAL MESSAGE LENGTH C ----------------------------------- IF(MOD(MBIT,8).NE.0) GOTO 903 IF(MBIT/8.NE.NBYT ) GOTO 904 NMSG(LUN) = NMSG(LUN)+1 NSUB(LUN) = 0 MBYT(LUN) = NBYT LUNCPY(LUN)=0 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'// . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '// . 'DICTIONARY")') INODE(LUN),INOD,SUBTAG CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '// . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBTAG CALL BORT(BORT_STR) 902 CALL BORT . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') 903 CALL BORT('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '// . 'ON A BYTE BOUNDARY') 904 WRITE(BORT_STR,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '// . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '// . 'CALCULATED, NBYT (",I6)') MBIT/8,NBYT CALL BORT(BORT_STR) END ./msgupd.f0000644001370400056700000001655113440555365011441 0ustar jator2emc SUBROUTINE MSGUPD(LUNIT,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSGUPD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY C (ARRAY IBAY IN MODULE BITBUF) AND THEN TRIES TO ADD IT TO C THE BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR LUNIT C (ARRAY MBAY IN MODULE BITBUF). IF THE SUBSET WILL NOT FIT C INTO THE CURRENTLY OPEN MESSAGE, OR IF THE SUBSET BYTE COUNT EXCEEDS C 65530 (SUFFICIENTLY CLOSE TO THE 16-BIT BYTE COUNTER UPPER LIMIT OF C 65535), THEN THAT MESSAGE IS FLUSHED TO LUNIT AND A NEW ONE IS C CREATED IN ORDER TO HOLD THE CURRENT SUBSET. ANY SUBSET WITH BYTE C COUNT > 65530 WILL BE WRITTEN INTO ITS OWN ONE-SUBSET MESSAGE. C IF THE CURRENT SUBSET IS LARGER THAN THE MAXIMUM MESSAGE LENGTH, C THEN THE SUBSET IS DISCARDED AND A DIAGNOSTIC IS PRINTED. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-12-14 J. WOOLLEN -- NO LONGER CALLS BORT IF A SUBSET IS LARGER C THAN A MESSAGE, JUST DISCARDS THE SUBSET 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 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 C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- USE MSGFULL AND ERRWRT C 2014-10-20 J. WOOLLEN -- ACCOUNT FOR SUBSETS WITH BYTE COUNT > 65530 C (THESE MUST BE WRITTEN INTO THEIR OWN C ONE-SUBSET MESSAGE) C 2014-10-20 D. KEYSER -- FOR CASE ABOVE, DO NOT WRITE "CURRENT" C MESSAGE IF IT CONTAINS ZERO SUBSETS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2016-03-21 D. STOKES -- CALL USRTPL FOR OVERLARGE SUBSETS C C USAGE: CALL MSGUPD (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 REMARKS: C THIS ROUTINE CALLS: ERRWRT IUPB MSGFULL MSGINI C MSGWRT MVB PAD PKB C USRTPL WRITLC C THIS ROUTINE IS CALLED BY: WRITSA WRITSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_H4WLC INCLUDE 'bufrlib.prm' COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5 COMMON /QUIET / IPRT LOGICAL MSGFULL CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C PAD THE SUBSET BUFFER C --------------------- CALL PAD(IBAY,IBIT,IBYT,8) C CHECK WHETHER THE NEW SUBSET SHOULD BE WRITTEN INTO THE CURRENTLY C OPEN MESSAGE C ----------------------------------------------------------------- IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT) . .OR. . ((IBYT.GT.65530).AND.(NSUB(LUN).GT.0))) THEN c NO it should not, either because: c 1) it doesn't fit, c -- OR -- c 2) it has byte count > 65530 (sufficiently close to the c upper limit for the 16 bit byte counter placed at the c beginning of each subset), AND the current message has c at least one subset in it, c SO write the current message out and create a new one to c hold the current subset CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) CALL MSGINI(LUN) ENDIF IF(MSGFULL(MBYT(LUN),IBYT,MAXBYT)) THEN c This is an overlarge subset that won't fit in any message c given the current value of MAXBYT, so discard the subset c and exit gracefully. IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I7,A)') . 'BUFRLIB: MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE ', . '{MAXIMUM MESSAGE LENGTH = ', MAXBYT, '}' CALL ERRWRT(ERRSTR) CALL ERRWRT('>>>>>>>OVERLARGE SUBSET DISCARDED FROM FILE<<<<<<<<') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF C SET A BYTE COUNT AND TRANSFER THE SUBSET BUFFER INTO THE MESSAGE C ---------------------------------------------------------------- LBIT = 0 CALL PKB(IBYT,16,IBAY,LBIT) C Note that we want to append the data for this subset to the end C of Section 4, but the value in MBYT(LUN) already includes the C length of Section 5 (i.e. 4 bytes). Therefore, we need to begin C writing at the point 3 bytes prior to the byte currently pointed C to by MBYT(LUN). CALL MVB(IBAY,1,MBAY(1,LUN),MBYT(LUN)-3,IBYT) C UPDATE THE SUBSET AND BYTE COUNTERS C -------------------------------------- MBYT(LUN) = MBYT(LUN) + IBYT NSUB(LUN) = NSUB(LUN) + 1 LBIT = (NBY0+NBY1+NBY2+4)*8 CALL PKB(NSUB(LUN),16,MBAY(1,LUN),LBIT) LBYT = NBY0+NBY1+NBY2+NBY3 NBYT = IUPB(MBAY(1,LUN),LBYT+1,24) LBIT = LBYT*8 CALL PKB(NBYT+IBYT,24,MBAY(1,LUN),LBIT) C IF ANY LONG CHARACTER STRINGS ARE BEING HELD INTERNALLY FOR STORAGE C INTO THIS SUBSET, STORE THEM NOW. C ------------------------------------------------------------------- IF(NH4WLC.GT.0) THEN DO II = 1, NH4WLC CALL WRITLC(LUH4WLC(II),CHH4WLC(II),STH4WLC(II)) ENDDO NH4WLC = 0 ENDIF C IF THE SUBSET BYTE COUNT IS > 65530, THEN GIVE IT ITS OWN ONE-SUBSET C MESSAGE (CANNOT HAVE ANY OTHER SUBSETS IN THIS MESSAGE BECAUSE THEIR C BEGINNING WOULD BE BEYOND THE UPPER LIMIT OF 65535 IN THE 16-BIT C BYTE COUNTER, MEANING THEY COULD NOT BE LOCATED!) C -------------------------------------------------------------------- IF(IBYT.GT.65530) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I7,A,A)') . 'BUFRLIB: MSGUPD - SUBSET HAS BYTE COUNT = ',IBYT,' > UPPER ', . 'LIMIT OF 65535' CALL ERRWRT(ERRSTR) CALL ERRWRT('>>>>>>>WILL BE WRITTEN INTO ITS OWN MESSAGE<<<<<<<<') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL MSGWRT(LUNIT,MBAY(1,LUN),MBYT(LUN)) CALL MSGINI(LUN) ENDIF C RESET THE USER ARRAYS AND EXIT NORMALLY C --------------------------------------- 100 CALL USRTPL(LUN,1,1) C EXIT C ---- RETURN END ./msgwrt.f0000644001370400056700000002460313465106306011454 0ustar jator2emc SUBROUTINE MSGWRT(LUNIT,MESG,MGBYT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MSGWRT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PERFORMS SOME FINAL CHECKS ON AN OUTPUT C BUFR MESSAGE (E.G., CONFIRMING THAT EACH SECTION OF THE MESSAGE HAS C AN EVEN NUMBER OF BYTES WHEN NECESSARY, "STANDARDIZING" THE MESSAGE C IF REQUESTED VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C STDMSG, ETC.), AND THEN PREPARES THE MESSAGE FOR FINAL OUTPUT TO C LOGICAL UNIT LUNIT (E.G., ADDING THE STRING "7777" TO THE LAST FOUR C BYTES OF THE MESSAGE, APPENDING ZEROED-OUT BYTES UP TO A SUBSEQUENT C MACHINE WORD BOUNDARY, ETC.). IT THEN WRITES OUT THE FINISHED C MESSAGE TO LOGICAL UNIT LUNIT AND ALSO STORES A COPY OF IT WITHIN C MODULE BUFRMG FOR POSSIBLE LATER RETRIEVAL VIA BUFR ARCHIVE C LIBRARY SUBROUTINE WRITSA. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION C WRITTEN IN SECTION 0 FROM 2 TO 3 C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-11-24 J. WOOLLEN -- MODIFIED TO ZERO OUT THE PADDING BYTES C WRITTEN AT THE END OF SECTION 4 C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2003-11-04 J. ATOR -- DON'T WRITE TO LUNIT IF OPENED AS A NULL C FILE BY OPENBF {NULL(LUN) = 1 IN NEW C COMMON BLOCK /NULBFR/} (WAS IN DECODER C VERSION); 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 C 2004-08-18 J. ATOR -- IMPROVED DOCUMENTATION; ADDED LOGIC TO CALL C STNDRD IF REQUESTED VIA COMMON /MSGSTD/; C ADDED LOGIC TO CALL OVRBS1 IF NECESSARY; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- USE GETLENS, IUPBS01, PADMSG, PKBS1 AND C NMWRD; ADDED LOGIC TO CALL PKBS1 AND/OR C CNVED4 WHEN NECESSARY C 2009-03-23 J. ATOR -- USE IDXMSG AND ERRWRT; ADD CALL TO ATRCPT; C ALLOW STANDARDIZING VIA COMMON /MSGSTD/ C EVEN IF DATA IS COMPRESSED; WORK ON LOCAL C COPY OF INPUT MESSAGE C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C CALL NEW ROUTINE BLOCKS FOR FILE BLOCKING C AND NEW C ROUTINE CWRBUFR TO WRITE BUFR C MESSAGE TO DISK FILE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2019-05-09 J. ATOR -- ADDED DIMENSIONS FOR MSGLEN AND MSGTXT C C USAGE: CALL MSGWRT (LUNIT, MESG, MGBYT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE TO OUTPUT TO LUNIT C MGBYT - INTEGER: LENGTH OF BUFR MESSAGE IN BYTES C C OUTPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: ATRCPT BORT CNVED4 ERRWRT C GETLENS IDXMSG IUPB IUPBS01 C NMWRD PADMSG PKB PKBS1 C PKC STATUS STNDRD BLOCKS C CWRBUFR C THIS ROUTINE IS CALLED BY: CLOSMG COPYBF COPYMG CPYMEM C CPYUPD MSGUPD WRCMPS WRDXTB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_NULBFR USE MODA_BUFRMG USE MODA_MGWA USE MODA_MGWB USE MODA_S01CM INCLUDE 'bufrlib.prm' PARAMETER (MXCOD=15) COMMON /QUIET / IPRT COMMON /MSGSTD/ CSMF COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT CHARACTER*128 ERRSTR CHARACTER*4 BUFR,SEVN CHARACTER*1 CSMF CHARACTER*1 CTRT DIMENSION MESG(*) DIMENSION IEC0(2) DATA BUFR/'BUFR'/ DATA SEVN/'7777'/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS C SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD, C CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE C BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT. MBYT = MGBYT IEC0(1) = MESG(1) IEC0(2) = MESG(2) IBIT = 32 CALL PKB(MBYT,24,IEC0,IBIT) DO II = 1, NMWRD(IEC0) MGWA(II) = MESG(II) ENDDO C OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE C REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE C PKVS01. IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER C TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL. IF(NS01V.GT.0) THEN DO I=1,NS01V IF(CMNEM(I).EQ.'BEN') THEN IF(IVMNEM(I).EQ.4) THEN C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4. IBIT = 32 CALL PKB(MBYT,24,MGWA,IBIT) CALL CNVED4(MGWA,MXMSGLD4,MGWB) C COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE. MBYT = IUPBS01(MGWB,'LENM') C COPY THE MGWB ARRAY BACK INTO MGWA. DO II = 1, NMWRD(MGWB) MGWA(II) = MGWB(II) ENDDO ENDIF ELSE C OVERWRITE THE REQUESTED VALUE. CALL PKBS1(IVMNEM(I),MGWA,CMNEM(I)) ENDIF ENDDO ENDIF C "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/. C HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR C TABLE (DX) INFORMATION, IN WHICH CASE IT IS ALREADY "STANDARD". IF ( ( CSMF.EQ.'Y' ) .AND. ( IDXMSG(MGWA).NE.1 ) ) THEN C INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE C ORIGINAL MESSAGE. THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD C REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT. IBIT = 32 CALL PKB(MBYT,24,MGWA,IBIT) IBIT = (MBYT-4)*8 CALL PKC(SEVN,4,MGWA,IBIT) CALL STNDRD(LUNIT,MGWA,MXMSGLD4,MGWB) C COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE. MBYT = IUPBS01(MGWB,'LENM') C COPY THE MGWB ARRAY BACK INTO MGWA. DO II = 1, NMWRD(MGWB) MGWA(II) = MGWB(II) ENDDO ENDIF C APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA C COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX) C INFORMATION. IF ( ( CTRT.EQ.'Y' ) .AND. ( IDXMSG(MGWA).NE.1 ) ) THEN C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT. IBIT = 32 CALL PKB(MBYT,24,MGWA,IBIT) CALL ATRCPT(MGWA,MXMSGLD4,MGWB) C COMPUTE MBYT FOR THE REVISED MESSAGE. MBYT = IUPBS01(MGWB,'LENM') C COPY THE MGWB ARRAY BACK INTO MGWA. DO II = 1, NMWRD(MGWB) MGWA(II) = MGWB(II) ENDDO ENDIF C GET THE SECTION LENGTHS. CALL GETLENS(MGWA,4,LEN0,LEN1,LEN2,LEN3,LEN4,L5) C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE C THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES. IF(IUPBS01(MGWA,'BEN').LT.4) THEN IF(MOD(LEN1,2).NE.0) GOTO 901 IF(MOD(LEN2,2).NE.0) GOTO 902 IF(MOD(LEN3,2).NE.0) GOTO 903 IF(MOD(LEN4,2).NE.0) THEN C PAD SECTION 4 WITH AN ADDITIONAL BYTE C THAT IS ZEROED OUT. IAD4 = LEN0+LEN1+LEN2+LEN3 IAD5 = IAD4+LEN4 IBIT = IAD4*8 LEN4 = LEN4+1 CALL PKB(LEN4,24,MGWA,IBIT) IBIT = IAD5*8 CALL PKB(0,8,MGWA,IBIT) MBYT = MBYT+1 ENDIF ENDIF C WRITE SECTION 0 BYTE COUNT AND SECTION 5 C ---------------------------------------- IBIT = 0 CALL PKC(BUFR, 4,MGWA,IBIT) CALL PKB(MBYT,24,MGWA,IBIT) KBIT = (MBYT-4)*8 CALL PKC(SEVN, 4,MGWA,KBIT) C ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN C ---------------------------------------------- C I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY C MGWA(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE C SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE C BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT. CALL PADMSG(MGWA,MXMSGLD4,NPBYT) C WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0 C ------------------------------------------------------------------ MWRD = NMWRD(MGWA) CALL STATUS(LUNIT,LUN,IL,IM) IF(NULL(LUN).EQ.0) THEN CALL BLOCKS(MGWA,MWRD) CALL CWRBUFR(LUN,MGWA,MWRD) ENDIF IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,I7)') . 'BUFRLIB: MSGWRT: LUNIT =', LUNIT, ', BYTES =', MBYT+NPBYT CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE C ------------------------------------------------------------ IF(IDXMSG(MGWA).NE.1) THEN C STORE A COPY OF THIS MESSAGE WITHIN MODULE BUFRMG, C FOR POSSIBLE LATER RETRIEVAL DURING A FUTURE CALL TO C SUBROUTINE WRITSA. MSGLEN(LUN) = MWRD DO I=1,MSGLEN(LUN) MSGTXT(I,LUN) = MGWA(I) ENDDO ENDIF C EXITS C ----- RETURN 901 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') 902 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') 903 CALL BORT . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') END ./mstabs.h0000644001370400056700000000437113440555365011432 0ustar jator2emc/* ** If array sizes are statically allocated, then we can directly access the ** arrays in FORTRAN MODULE MSTABS from within C. However, if these arrays ** are dynamically allocated, meaning that their size isn't known at compile ** time, then we can't directly access these arrays from within C. Instead, ** we'll need to allocate separate array space in C and copy the relevant ** information from the FORTRAN MODULE MSTABS arrays to these new C arrays ** at run time in order to access the information from within C. */ #ifdef STATIC_ALLOCATION # define MSTABS_BASE(var) var extern f77int MSTABS_BASE(nmtb); extern f77int MSTABS_BASE(ibfxyn)[]; extern char MSTABS_BASE(cbscl)[][4]; extern char MSTABS_BASE(cbsref)[][12]; extern char MSTABS_BASE(cbbw)[][4]; extern char MSTABS_BASE(cbunit)[][14]; extern char MSTABS_BASE(cbmnem)[][8]; extern char MSTABS_BASE(cbelem)[][120]; extern f77int MSTABS_BASE(nmtd); extern f77int MSTABS_BASE(idfxyn)[]; extern char MSTABS_BASE(cdseq)[][120]; extern char MSTABS_BASE(cdmnem)[][8]; extern f77int MSTABS_BASE(ndelem)[]; extern f77int MSTABS_BASE(idefxy)[]; #else # define MSTABS_BASE(var) mstabs_newCarr_ ## var # ifdef IN_ARALLOCC f77int MSTABS_BASE(nmtb); f77int *MSTABS_BASE(ibfxyn); char (*MSTABS_BASE(cbscl))[4]; char (*MSTABS_BASE(cbsref))[12]; char (*MSTABS_BASE(cbbw))[4]; char (*MSTABS_BASE(cbunit))[14]; char (*MSTABS_BASE(cbmnem))[8]; char (*MSTABS_BASE(cbelem))[120]; f77int MSTABS_BASE(nmtd); f77int *MSTABS_BASE(idfxyn); char (*MSTABS_BASE(cdseq))[120]; char (*MSTABS_BASE(cdmnem))[8]; f77int *MSTABS_BASE(ndelem); f77int *MSTABS_BASE(idefxy); # else extern f77int MSTABS_BASE(nmtb); extern f77int *MSTABS_BASE(ibfxyn); extern char (*MSTABS_BASE(cbscl))[4]; extern char (*MSTABS_BASE(cbsref))[12]; extern char (*MSTABS_BASE(cbbw))[4]; extern char (*MSTABS_BASE(cbunit))[14]; extern char (*MSTABS_BASE(cbmnem))[8]; extern char (*MSTABS_BASE(cbelem))[120]; extern f77int MSTABS_BASE(nmtd); extern f77int *MSTABS_BASE(idfxyn); extern char (*MSTABS_BASE(cdseq))[120]; extern char (*MSTABS_BASE(cdmnem))[8]; extern f77int *MSTABS_BASE(ndelem); extern f77int *MSTABS_BASE(idefxy); # endif #endif ./mtfnam.f0000644001370400056700000000755713440555365011432 0ustar jator2emc SUBROUTINE MTFNAM ( IMT, IMTV, IOGCE, IMTVL, TBLTYP, . STDFIL, LOCFIL ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MTFNAM C PRGMMR: ATOR ORG: NCEP DATE: 2017-10-16 C C ABSTRACT: BASED ON THE INPUT ARGUMENTS, THIS SUBROUTINE DETERMINES C THE NAMES OF THE CORRESPONDING STANDARD AND LOCAL MASTER TABLE C FILES. IT THEN CONFIRMS THE EXISTENCE OF THESE FILES ON THE C FILESYSTEM, USING ADDITIONAL INFORMATION OBTAINED FROM THE MOST C RECENT CALL TO SUBROUTINE MTINFO, OR ELSE AS DEFINED WITHIN C SUBROUTINE BFRINI IF SUBROUTINE MTINFO WAS NEVER CALLED. C C PROGRAM HISTORY LOG: C 2017-10-16 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL MTFNAM ( IMT, IMTV, IOGCE, IMTVL, TBLTYP, C STDFIL, LOCFIL ) C INPUT ARGUMENT LIST: C IMT - INTEGER: MASTER TABLE NUMBER C IMTV - INTEGER: MASTER TABLE VERSION NUMBER C IOGCE - INTEGER: ORIGINATING CENTER C IMTVL - INTEGER: LOCAL TABLE VERSION NUMBER C TBLTYP - CHARACTER*(*): TABLE TYPE: C 'TableB' = Table B C 'TableD' = Table D C 'CodeFlag' = Code and Flag Tables C C OUTPUT ARGUMENT LIST: C STDFIL - CHARACTER*(*): STANDARD MASTER TABLE PATH/FILENAME C LOCFIL - CHARACTER*(*): LOCAL MASTER TABLE PATH/FILENAME C C REMARKS: C THIS ROUTINE CALLS: BORT2 ERRWRT ISIZE STRSUC C THIS ROUTINE IS CALLED BY: IREADMT 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 /QUIET/ IPRT COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR CHARACTER*(*) STDFIL, LOCFIL, TBLTYP CHARACTER*16 TBLTYP2 CHARACTER*20 FMTF CHARACTER*100 MTDIR CHARACTER*128 BORT_STR LOGICAL FOUND C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STRSUC ( TBLTYP, TBLTYP2, LTBT ) C* Determine the standard master table path/filename. IF ( ( IMT .EQ. 0 ) .AND. ( IMTV .LE. 13 ) ) THEN C* For master table 0, version 13 is a superset of all earlier C* versions. STDFIL = MTDIR(1:LMTD) // '/bufrtab.' // TBLTYP2(1:LTBT) // . '_STD_0_13' ELSE WRITE ( FMTF, '(A,I1,A,I1,A)' ) . '(4A,I', ISIZE(IMT), ',A,I', ISIZE(IMTV), ')' WRITE ( STDFIL, FMTF ) MTDIR(1:LMTD), '/bufrtab.', . TBLTYP2(1:LTBT), '_STD_', IMT, '_', IMTV ENDIF IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('Standard ' // TBLTYP2(1:LTBT) // ':') CALL ERRWRT(STDFIL) ENDIF INQUIRE ( FILE = STDFIL, EXIST = FOUND ) IF ( .NOT. FOUND ) GOTO 900 C* Now determine the local master table path/filename. C* Use the local table corresponding to the originating center C* and local table version number, if such a table exists. C* Otherwise use the local table from NCEP. WRITE ( FMTF, '(A,I1,A,I1,A,I1,A)' ) . '(4A,I', ISIZE(IMT), ',A,I', ISIZE(IOGCE), . ',A,I', ISIZE(IMTVL), ')' WRITE ( LOCFIL, FMTF ) MTDIR(1:LMTD), '/bufrtab.', . TBLTYP2(1:LTBT), '_LOC_', IMT, '_', IOGCE, '_', IMTVL IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('Local ' // TBLTYP2(1:LTBT) // ':') CALL ERRWRT(LOCFIL) ENDIF INQUIRE ( FILE = LOCFIL, EXIST = FOUND ) IF ( .NOT. FOUND ) THEN C* Use the local table from NCEP. LOCFIL = MTDIR(1:LMTD) // '/bufrtab.' // TBLTYP2(1:LTBT) // . '_LOC_0_7_1' IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('Local ' // TBLTYP2(1:LTBT) // . 'not found, so using:') CALL ERRWRT(LOCFIL) ENDIF INQUIRE ( FILE = LOCFIL, EXIST = FOUND ) IF ( .NOT. FOUND ) GOTO 901 ENDIF RETURN 900 BORT_STR = 'BUFRLIB: MTFNAM - COULD NOT FIND STANDARD FILE:' CALL BORT2(BORT_STR,STDFIL) 901 BORT_STR = 'BUFRLIB: MTFNAM - COULD NOT FIND LOCAL FILE:' CALL BORT2(BORT_STR,LOCFIL) END ./mtinfo.f0000644001370400056700000000373313440555365011434 0ustar jator2emc SUBROUTINE MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MTINFO C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY THE DIRECTORY LOCATION C AND FORTRAN LOGICAL UNIT NUMBERS TO USE WHEN READING BUFR MASTER C TABLES ON THE LOCAL FILE SYSTEM. THE INPUT LOGICAL UNIT NUMBERS C SHOULD BE UNIQUE BUT SHOULD NOT ALREADY BE ASSIGNED TO ANY ACTUAL C BUFR MASTER TABLE FILES. IF THIS SUBROUTINE IS NOT CALLED, THEN C DEFAULT VALUES ARE USED AS DEFINED WITHIN BUFR ARCHIVE LIBRARY C SUBROUTINE BFRINI. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL MTINFO ( CMTDIR, LUNMT1, LUNMT2 ) C INPUT ARGUMENT LIST: C CMTDIR - CHARACTER*(*): DIRECTORY LOCATION OF BUFR MASTER TABLES C ON LOCAL FILE SYSTEM (UP TO 100 CHARACTERS) C LUNMT1 - INTEGER: FIRST FORTRAN LOGICAL UNIT NUMBER TO USE WHEN C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM C LUNMT2 - INTEGER: SECOND FORTRAN LOGICAL UNIT NUMBER TO USE WHEN C READING BUFR MASTER TABLES ON LOCAL FILE SYSTEM C C REMARKS: C THIS ROUTINE CALLS: BORT2 STRSUC C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR CHARACTER*(*) CMTDIR CHARACTER*128 BORT_STR CHARACTER*100 MTDIR C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STRSUC ( CMTDIR, MTDIR, LMTD ) IF ( LMTD .LT. 0 ) GOTO 900 LUN1 = LUNMT1 LUN2 = LUNMT2 C EXITS C ----- RETURN 900 BORT_STR = 'BUFRLIB: MTINFO - BAD INPUT MASTER TABLE DIRECTORY:' CALL BORT2(BORT_STR,CMTDIR) END ./mvb.f0000644001370400056700000000473413440555365010726 0ustar jator2emc SUBROUTINE MVB(IB1,NB1,IB2,NB2,NBM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: MVB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A SPECIFIED NUMBER OF BYTES FROM C ONE PACKED BINARY ARRAY TO ANOTHER. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES 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 2005-11-29 J. ATOR -- MAXIMUM NUMBER OF BYTES TO COPY INCREASED C FROM 24000 TO MXIMB C 2014-10-22 J. ATOR -- MERGE TWO DO LOOPS INTO ONE, AND REMOVE C MXIMB PARAMETER AND DIMENSIONING OF NVAL C C USAGE: CALL MVB (IB1, NB1, IB2, NB2, NBM) C INPUT ARGUMENT LIST: C IB1 - INTEGER: *-WORD PACKED INPUT BINARY ARRAY C NB1 - INTEGER: POINTER TO FIRST BYTE IN IB1 TO COPY FROM C NB2 - INTEGER: POINTER TO FIRST BYTE IN IB2 TO COPY TO C NBM - INTEGER: NUMBER OF BYTES TO COPY C C OUTPUT ARGUMENT LIST: C IB2 - INTEGER: *-WORD PACKED OUTPUT BINARY ARRAY C C REMARKS: C THIS ROUTINE CALLS: PKB UPB C THIS ROUTINE IS CALLED BY: ATRCPT CNVED4 CPYUPD MSGUPD C STNDRD 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' CHARACTER*128 BORT_STR DIMENSION IB1(*),IB2(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- JB1 = 8*(NB1-1) JB2 = 8*(NB2-1) DO N=1,NBM CALL UPB(NVAL,8,IB1,JB1) CALL PKB(NVAL,8,IB2,JB2) ENDDO C EXITS C ----- RETURN END ./nemdefs.f0000644001370400056700000000416613440555365011562 0ustar jator2emc SUBROUTINE NEMDEFS ( LUNIT, NEMO, CELEM, CUNIT, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMDEFS C PRGMMR: J. ATOR ORG: NP12 DATE: 2014-10-02 C C ABSTRACT: GIVEN A TABLE B MNEMONIC, THIS SUBROUTINE RETURNS THE C ELEMENT NAME AND UNITS ASSOCIATED WITH THAT MNEMONIC. THIS C SUBROUTINE CAN BE CALLED AT ANY TIME FOLLOWING THE CALL TO BUFR C ARCHIVE LIBRARY SUBROUTINE OPENBF FOR THE ASSOCIATED LUNIT. C C PROGRAM HISTORY LOG: C 2014-10-02 J. ATOR -- ORIGINAL VERSION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEMDEFS (LUNIT, NEMO, CELEM, CUNIT, IRET ) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C NEMO - CHARACTER*(*): TABLE B MNEMONIC C C OUTPUT ARGUMENT LIST: C CELEM - CHARACTER*55: ELEMENT NAME ASSOCIATED WITH NEMO C CUNIT - CHARACTER*24: UNITS ASSOCIATED WITH NEMO C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = REQUESTED MNEMONIC COULD NOT BE FOUND, OR SOME C OTHER ERROR OCCURRED C C REMARKS: C THIS ROUTINE CALLS: NEMTAB STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*1 TAB CHARACTER*(*) NEMO, CELEM, CUNIT C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Get LUN from LUNIT. CALL STATUS( LUNIT, LUN, IL, IM ) IF ( IL .EQ. 0 ) RETURN C Find the requested mnemonic in the internal Table B arrays. CALL NEMTAB( LUN, NEMO, IDN, TAB, ILOC ) IF ( ( ILOC .EQ. 0 ) .OR. ( TAB .NE. 'B' ) ) RETURN C Get the element name and units of the requested mnemonic. CELEM = ' ' LS = MIN(LEN(CELEM),55) CELEM(1:LS) = TABB(ILOC,LUN)(16:15+LS) CUNIT = ' ' LS = MIN(LEN(CUNIT),24) CUNIT(1:LS) = TABB(ILOC,LUN)(71:70+LS) IRET = 0 RETURN END ./nemock.f0000644001370400056700000000467213440555365011417 0ustar jator2emc FUNCTION NEMOCK(NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMOCK C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CHECKS A MNEMONIC TO VERIFY THAT IT HAS A C LENGTH OF BETWEEN ONE AND EIGHT CHARACTERS AND THAT IT ONLY C CONTAINS CHARACTERS FROM THE ALLOWABLE CHARACTER SET. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 -- SPLIT NON-ZERO RETURN INTO -1 FOR LENGTH C NOT 1-8 CHARACTERS AND -2 FOR INVALID C CHARACTERS (RETURN ONLY -1 BEFORE FOR ALL C PROBLEMATIC CASES); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION C C USAGE: NEMOCK (NEMO) C INPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC TO BE CHECKED C C OUTPUT ARGUMENT LIST: C NEMOCK - INTEGER: INDICATOR AS TO WHETHER NEMO IS VALID: C 0 = yes C -1 = no, length not between 1 and 8 characters C -2 = no, it does not contain characters from the C allowable character set C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: RDUSDX SEQSDX SNTBBE SNTBDE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) NEMO CHARACTER*38 CHRSET DATA CHRSET /'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_.'/ DATA NCHR /38/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C GET THE LENGTH OF NEMO C ---------------------- LNEMO = 0 DO I=LEN(NEMO),1,-1 IF(NEMO(I:I).NE.' ') THEN LNEMO = I GOTO 1 ENDIF ENDDO 1 IF(LNEMO.LT.1 .OR. LNEMO.GT.8) THEN NEMOCK = -1 GOTO 100 ENDIF C SCAN NEMO FOR ALLOWABLE CHARACTERS C ---------------------------------- DO 10 I=1,LNEMO DO J=1,NCHR IF(NEMO(I:I).EQ.CHRSET(J:J)) GOTO 10 ENDDO NEMOCK = -2 GOTO 100 10 ENDDO NEMOCK = 0 C EXIT C ---- 100 RETURN END ./nemspecs.f0000644001370400056700000000713613440555365011756 0ustar jator2emc SUBROUTINE NEMSPECS ( LUNIT, NEMO, NNEMO, . NSCL, NREF, NBTS, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMSPECS C PRGMMR: J. ATOR ORG: NP12 DATE: 2014-10-02 C C ABSTRACT: GIVEN A TABLE B MNEMONIC, THIS SUBROUTINE RETURNS THE C SCALE FACTOR, REFERENCE VALUE AND BIT WIDTH CORRESPONDING TO THE C (NNEMO)th OCCURRENCE OF THAT MNEMONIC WITHIN A SUBSET C DEFINITION (COUNTING FROM THE BEGINNING OF THE OVERALL SUBSET C DEFINITION), AND INCLUDING ACCOUNTING FOR ANY TABLE C OPERATORS C (E.G. 2-01-YYY, 2-02-YYY, 2-03-YYY, 2-07-YYY) WHICH MAY BE IN C EFFECT FOR THAT PARTICULAR OCCURRENCE OF THE MNEMONIC. A SUBSET C DEFINITION MUST ALREADY BE IN SCOPE, EITHER VIA A PREVIOUS CALL TO C BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR EQUIVALENT (FOR INPUT C FILES) OR TO SUBROUTINE OPENMB OR EQUIVALENT (FOR OUTPUT FILES). C C PROGRAM HISTORY LOG: C 2014-10-02 J. ATOR -- ORIGINAL VERSION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEMSPECS (LUNIT, NEMO, NNEMO, NSCL, NREF, NBTS, IRET ) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C NEMO - CHARACTER*(*): TABLE B MNEMONIC C NNEMO - INTEGER: ORDINAL OCCURRENCE OF NEMO FOR WHICH C INFORMATION IS TO BE RETURNED, COUNTING FROM THE C BEGINNING OF THE OVERALL SUBSET DEFINITION C C OUTPUT ARGUMENT LIST: C NSCL - INTEGER: SCALE FACTOR CORRESPONDING TO NEMO C NREF - INTEGER: REFERENCE VALUE CORRESPONDING TO NEMO C NBTS - INTEGER: BIT WIDTH CORRESPONDING TO NEMO C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = REQUESTED MNEMONIC COULD NOT BE FOUND, OR SOME C OTHER ERROR OCCURRED C C REMARKS: C THIS ROUTINE CALLS: FSTAG STATUS STRSUC C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES USE MODA_NRV203 INCLUDE 'bufrlib.prm' CHARACTER*10 TAGN CHARACTER*(*) NEMO C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Get LUN from LUNIT. CALL STATUS( LUNIT, LUN, IL, IM ) IF ( IL .EQ. 0 ) RETURN IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN C Starting from the beginning of the subset, locate the (NNEMO)th C occurrence of NEMO. CALL FSTAG( LUN, NEMO, NNEMO, 1, NIDX, IERFST ) IF ( IERFST .NE. 0 ) RETURN C Confirm that NEMO is a Table B mnemonic. NODE = INV(NIDX,LUN) IF ( ( TYP(NODE) .NE. 'NUM' ) .AND. ( TYP(NODE) .NE. 'CHR' ) ) . RETURN C Get the scale factor, reference value and bit width, including C accounting for any Table C operators which may be in scope for C this particular occurrence of NEMO. IRET = 0 NSCL = ISC(NODE) NBTS = IBT(NODE) NREF = IRF(NODE) IF ( NNRV .GT. 0 ) THEN C There are nodes containing redefined reference values (from C one or more 2-03-YYY operators) in the jump/link table, so we C need to check if this node is one of them. TAGN = ' ' CALL STRSUC( NEMO, TAGN, LTN ) IF ( ( LTN .LE. 0 ) .OR. ( LTN .GT. 8 ) ) RETURN DO JJ = 1, NNRV IF ( ( NODE .NE. INODNRV(JJ) ) .AND. . ( TAGN(1:8) .EQ. TAGNRV(JJ) ) .AND. . ( NODE .GE. ISNRV(JJ) ) .AND. . ( NODE .LE. IENRV(JJ) ) ) THEN NREF = NRV(JJ) RETURN END IF END DO END IF RETURN END ./nemtab.f0000644001370400056700000001204313440555365011400 0ustar jator2emc SUBROUTINE NEMTAB(LUN,NEMO,IDN,TAB,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE C INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS C IN MODULE TABABD) AND, IF FOUND, RETURNS INFORMATION ABOUT C THAT MNEMONIC FROM WITHIN THESE ARRAYS. OTHERWISE, IT CHECKS C WHETHER NEMO IS A TABLE C OPERATOR DESCRIPTOR AND, IF SO, DIRECTLY C COMPUTES AND RETURNS SIMILAR INFORMATION ABOUT THAT DESCRIPTOR. C THIS SUBROUTINE MAY BE USEFUL TO APPLICATION PROGRAMS WHICH WANT C TO CHECK WHETHER A PARTICULAR MNEMONIC IS IN THE DICTIONARY. IN C THIS CASE, BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF MUST FIRST BE C CALLED TO STORE THE DICTIONARY TABLE INTERNALLY, AND BUFR ARCHIVE C LIBRARY SUBROUTINE STATUS MUST BE CALLED TO CONNECT THE LOGICAL C UNIT NUMBER FOR THE BUFR FILE OPENED IN OPENBF TO LUN. 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 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 -- ADDED CAPABILITY TO ENCODE AND DECODE DATA C USING THE OPERATOR DESCRIPTORS (BUFR TABLE C C) FOR CHANGING WIDTH AND CHANGING SCALE 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 C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-02-25 J. ATOR -- ALLOW PROCESSING OF 2-2X, 2-3X AND 2-4X C NON-MARKER OPERATORS IN DX TABLES C C USAGE: CALL NEMTAB (LUN, NEMO, IDN, TAB, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C NEMO - CHARACTER*(*): MNEMONIC TO SEARCH FOR C C OUTPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE C CORRESPONDING TO NEMO (IF NEMO WAS FOUND) C TAB - CHARACTER*1: INTERNAL TABLE ARRAY IN WHICH NEMO WAS C FOUND: C 'B' = Table B array C 'C' = Table C array C 'D' = Table D array C IRET - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB C 0 = NEMO was not found within any of the Table C B, C, or D arrays C C REMARKS: C THIS ROUTINE CALLS: IFXY IOKOPER C THIS ROUTINE IS CALLED BY: CHEKSTAB CMSGINI ELEMDX GETCFMNG C IGETRFEL MSGINI NEMDEFS SEQSDX C STSEQ TABSUB UFBDMP UFBQCD C UFDUMP UPFTBV C Also called by application programs C (see ABSTRACT). C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*(*) NEMO CHARACTER*8 NEMT CHARACTER*1 TAB LOGICAL FOLVAL C----------------------------------------------------------------------- C----------------------------------------------------------------------- FOLVAL = NEMO(1:1).EQ.'.' IRET = 0 TAB = ' ' C LOOK FOR NEMO IN TABLE B C ------------------------ DO 1 I=1,NTBB(LUN) NEMT = TABB(I,LUN)(7:14) IF(NEMT.EQ.NEMO) THEN IDN = IDNB(I,LUN) TAB = 'B' IRET = I GOTO 100 ELSEIF(FOLVAL.AND.NEMT(1:1).EQ.'.') THEN DO J=2,LEN(NEMT) IF(NEMT(J:J).NE.'.' .AND. NEMT(J:J).NE.NEMO(J:J)) GOTO 1 ENDDO IDN = IDNB(I,LUN) TAB = 'B' IRET = I GOTO 100 ENDIF 1 ENDDO C DON'T LOOK IN TABLE D FOR FOLLOWING VALUE-MNEMONICS C --------------------------------------------------- IF(FOLVAL) GOTO 100 C LOOK IN TABLE D IF WE GOT THIS FAR C ---------------------------------- DO I=1,NTBD(LUN) NEMT = TABD(I,LUN)(7:14) IF(NEMT.EQ.NEMO) THEN IDN = IDND(I,LUN) TAB = 'D' IRET = I GOTO 100 ENDIF ENDDO C IF STILL NOTHING, CHECK HERE FOR TABLE C OPERATOR DESCRIPTORS C ------------------------------------------------------------- IF (IOKOPER(NEMO).EQ.1) THEN READ(NEMO,'(1X,I2)') IRET IDN = IFXY(NEMO) TAB = 'C' GOTO 100 ENDIF C EXIT C ---- 100 RETURN END ./nemtba.f0000644001370400056700000000574313440555365011411 0ustar jator2emc SUBROUTINE NEMTBA(LUN,NEMO,MTYP,MSBT,INOD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMTBA C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN C MODULE TABABD) AND, IF FOUND, RETURNS INFORMATION ABOUT THAT C MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR ARCHIVE C LIBRARY SUBROUTINE NEMTBAX EXCEPT THAT, IF NEMO IS NOT FOUND, THIS C SUBROUTINE MAKES AN APPROPRIATE CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C 2009-05-07 J. ATOR -- USE NEMTBAX C C USAGE: CALL NEMTBA (LUN, NEMO, MTYP, MSBT, INOD) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR C C OUTPUT ARGUMENT LIST: C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL C JUMP/LINK TABLE C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTBAX C THIS ROUTINE IS CALLED BY: CMSGINI COPYMG CPYMEM LCMGDF C MSGINI OPENMB OPENMG 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' CHARACTER*(*) NEMO CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C LOOK FOR NEMO IN TABLE A C ------------------------ CALL NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) IF(INOD.EQ.0) GOTO 900 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NEMTBA - CAN''T FIND MNEMONIC ",A)') . NEMO CALL BORT(BORT_STR) END ./nemtbax.f0000644001370400056700000000561113440555365011573 0ustar jator2emc SUBROUTINE NEMTBAX(LUN,NEMO,MTYP,MSBT,INOD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMTBAX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 C C ABSTRACT: THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE C INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY TABLE (ARRAYS IN C MODULE TABABD) AND, IF FOUND, RETURNS INFORMATION ABOUT C THAT MNEMONIC FROM WITHIN THESE ARRAYS. IT IS IDENTICAL TO BUFR C ARCHIVE LIBRARY SUBROUTINE NEMTBA EXCEPT THAT, IF NEMO IS NOT C FOUND, THIS SUBROUTINE RETURNS WITH INOD EQUAL TO ZERO, WHEREAS C NEMTBA CALLS BUFR ARCHIVE LIBRARY SUBROUTINE BORT IN SUCH CASES. C C PROGRAM HISTORY LOG: C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR 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 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEMTBAX (LUN, NEMO, MTYP, MSBT, INOD) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C NEMO - CHARACTER*(*): TABLE A MNEMONIC TO SEARCH FOR C C OUTPUT ARGUMENT LIST: C MTYP - INTEGER: MESSAGE TYPE CORRESPONDING TO NEMO C MSBT - INTEGER: MESSAGE SUBTYPE CORRESPONDING TO NEMO C INOD - INTEGER: POSITIONAL INDEX OF NEMO WITHIN INTERNAL C JUMP/LINK TABLE IF NEMO FOUND C 0 = NEMO not found C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: CKTABA IOK2CPY NEMTBA STNDRD C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*(*) NEMO CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- INOD = 0 C LOOK FOR NEMO IN TABLE A C ------------------------ DO I=1,NTBA(LUN) IF(TABA(I,LUN)(4:11).EQ.NEMO) THEN MTYP = IDNA(I,LUN,1) MSBT = IDNA(I,LUN,2) INOD = MTAB(I,LUN) IF(MTYP.LT.0 .OR. MTYP.GT.255) GOTO 900 IF(MSBT.LT.0 .OR. MSBT.GT.255) GOTO 901 GOTO 100 ENDIF ENDDO C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE TYPE (",I4'// . ',") RETURNED FOR MENMONIC ",A)') MTYP,NEMO CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: NEMTBAX - INVALID MESSAGE SUBTYPE ("'// . ',I4,") RETURNED FOR MENMONIC ",A)') MSBT,NEMO CALL BORT(BORT_STR) END ./nemtbb.f0000644001370400056700000001113413440555365011401 0ustar jator2emc SUBROUTINE NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMTBB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS ALL OF THE PROPERTIES (E.G. FXY C VALUE, UNITS, SCALE FACTOR, REFERENCE VALUE, ETC.) OF A SPECIFIED C MNEMONIC WITHIN THE INTERNAL BUFR TABLE B ARRAYS (IN MODULE C TABABD) IN ORDER TO VERIFY THAT THE VALUES OF THOSE PROPERTIES C ARE ALL LEGAL AND WELL-DEFINED. IF ANY ERRORS ARE FOUND, THEN AN C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. 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 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 -- CHANGED CALL TO FUNCTION "VAL$" TO "VALX" C (IT HAS BEEN RENAMED TO REMOVE THE C POSSIBILITY OF THE "$" SYMBOL CAUSING C PROBLEMS ON OTHER PLATFORMS) 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEMTBB (LUN, ITAB, UNIT, ISCL, IREF, IBIT) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C ITAB - INTEGER: POSITIONAL INDEX INTO INTERNAL BUFR TABLE B C ARRAYS FOR MNEMONIC TO BE CHECKED C C OUTPUT ARGUMENT LIST: C UNIT - CHARACTER*24: UNITS OF MNEMONIC C ISCL - INTEGER: SCALE FACTOR OF MNEMONIC C IREF - INTEGER: REFERENCE VALUE OF MNEMONIC C IBIT - INTEGER: BIT WIDTH OF MNEMONIC C C REMARKS: C THIS ROUTINE CALLS: BORT IFXY VALX C THIS ROUTINE IS CALLED BY: CHEKSTAB RESTD TABENT C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*24 UNIT CHARACTER*8 NEMO REAL*8 MXR C----------------------------------------------------------------------- C----------------------------------------------------------------------- MXR = 1E11-1 IF(ITAB.LE.0 .OR. ITAB.GT.NTBB(LUN)) GOTO 900 C PULL OUT TABLE B INFORMATION C ---------------------------- IDN = IDNB(ITAB,LUN) NEMO = TABB(ITAB,LUN)( 7:14) UNIT = TABB(ITAB,LUN)(71:94) ISCL = VALX(TABB(ITAB,LUN)( 95: 98)) IREF = VALX(TABB(ITAB,LUN)( 99:109)) IBIT = VALX(TABB(ITAB,LUN)(110:112)) C CHECK TABLE B CONTENTS C ---------------------- IF(IDN.LT.IFXY('000000')) GOTO 901 IF(IDN.GT.IFXY('063255')) GOTO 901 IF(ISCL.LT.-999 .OR. ISCL.GT.999) GOTO 902 IF(IREF.LE.-MXR .OR. IREF.GE.MXR) GOTO 903 IF(IBIT.LE.0) GOTO 904 IF(UNIT(1:5).NE.'CCITT' .AND. IBIT.GT.32 ) GOTO 904 IF(UNIT(1:5).EQ.'CCITT' .AND. MOD(IBIT,8).NE.0) GOTO 905 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - ITAB (",I7,") NOT FOUND IN '// . 'TABLE B")') ITAB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - INTEGER REPRESENTATION OF '// . 'DESCRIPTOR FOR TABLE B MNEMONIC ",A," (",I7,") IS OUTSIDE '// . 'RANGE 0-16383 (16383 -> 0-63-255)")') NEMO,IDN CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - SCALE VALUE FOR TABLE B '// .'MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE -999 TO 999")') . NEMO,ISCL CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - REFERENCE VALUE FOR TABLE B'// .' MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE +/- 1E11-1")') . NEMO,IREF CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR NON-CHARACTER'// . ' TABLE B MNEMONIC ",A," (",I7,") IS > 32")') NEMO,IBIT CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: NEMTBB - BIT WIDTH FOR CHARACTER '// . 'TABLE B MNEMONIC ",A," (",I7,") IS NOT A MULTIPLE OF 8")') . NEMO,IBIT CALL BORT(BORT_STR) END ./nemtbd.f0000644001370400056700000001670513440555365011414 0ustar jator2emc SUBROUTINE NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEMTBD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RETURNS A LIST OF THE MNEMONICS (I.E., C "CHILD" MNEMONICS) CONTAINED WITHIN A TABLE D SEQUENCE MNEMONIC C (I.E., A "PARENT MNEMONIC"). THIS INFORMATION SHOULD HAVE BEEN C PACKED INTO THE INTERNAL BUFR TABLE D ENTRY FOR THE PARENT C MNEMONIC (IN MODULE TABABD) VIA PREVIOUS CALLS TO BUFR ARCHIVE C LIBRARY SUBROUTINE PKTDD. NOTE THAT NEMTBD DOES NOT RECURSIVELY C RESOLVE CHILD MNEMONICS WHICH ARE THEMSELVES TABLE D SEQUENCE C MNEMONICS; RATHER, SUCH RESOLUTION MUST BE DONE VIA SEPARATE C SUBSEQUENT CALLS TO THIS SUBROUTINE. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- MUST NOW CHECK FOR TABLE C (OPERATOR C DESCRIPTOR) MNEMONICS SINCE THE CAPABILITY C HAS NOW BEEN ADDED TO ENCODE AND DECODE C THESE 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEMTBD (LUN, ITAB, NSEQ, NEMS, IRPS, KNTS) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C ITAB - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN C INTERNAL BUFR TABLE D ARRAY TABD(*,*) C C OUTPUT ARGUMENT LIST: C NSEQ - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS FOR THE C PARENT MNEMONIC GIVEN BY TABD(ITAB,LUN) C NEMS - CHARACTER*8: (NSEQ)-WORD ARRAY OF CHILD MNEMONICS C IRPS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) C KNTS - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS) C C REMARKS: C VALUE FOR OUTPUT ARGUMENT IRPS: C The interpretation of the return value IRPS(I) depends upon the C type of descriptor corresponding to NEMS(I), as follows: C C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) C replication descriptor ) THEN C IRPS(I) = 1 C ELSE IF ( NEMS(I) corresponds to a delayed replicator or C replication factor descriptor ) THEN C IRPS(I) = positional index of corresponding descriptor C within internal replication array IDNR(*,*) C ELSE C IRPS(I) = 0 C END IF C C C VALUE FOR OUTPUT ARGUMENT KNTS: C The interpretation of the return value KNTS(I) depends upon the C type of descriptor corresponding to NEMS(I), as follows: C C IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed) C replication descriptor ) THEN C KNTS(I) = number of replications C ELSE C KNTS(I) = 0 C END IF C C C THIS ROUTINE CALLS: ADN30 BORT IFXY NUMTAB C RSVFVM UPTDD C THIS ROUTINE IS CALLED BY: CHEKSTAB DXDUMP GETABDB TABSUB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MAXCD USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 NEMO,NEMS,NEMT,NEMF CHARACTER*6 ADN30,CLEMON CHARACTER*1 TAB DIMENSION NEMS(*),IRPS(*),KNTS(*) LOGICAL REP C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(ITAB.LE.0 .OR. ITAB.GT.NTBD(LUN)) GOTO 900 REP = .FALSE. C CLEAR THE RETURN VALUES C ----------------------- NSEQ = 0 DO I=1,MAXCD NEMS(I) = ' ' IRPS(I) = 0 KNTS(I) = 0 ENDDO C PARSE THE TABLE D ENTRY C ----------------------- NEMO = TABD(ITAB,LUN)(7:14) IDSC = IDND(ITAB,LUN) CALL UPTDD(ITAB,LUN,0,NDSC) IF(IDSC.LT.IFXY('300000')) GOTO 901 IF(IDSC.GT.IFXY('363255')) GOTO 901 cccc IF(NDSC.LE.0 ) GOTO 902 C Loop through each child mnemonic. c .... DK: What happens here if NDSC=0 ? DO J=1,NDSC IF(NSEQ+1.GT.MAXCD) GOTO 903 CALL UPTDD(ITAB,LUN,J,IDSC) c .... get NEMT from IDSC CALL NUMTAB(LUN,IDSC,NEMT,TAB,IRET) IF(TAB.EQ.'R') THEN IF(REP) GOTO 904 REP = .TRUE. IF(IRET.LT.0) THEN C F=1 regular (i.e. non-delayed) replication. IRPS(NSEQ+1) = 1 KNTS(NSEQ+1) = ABS(IRET) ELSEIF(IRET.GT.0) THEN C Delayed replication. IRPS(NSEQ+1) = IRET ENDIF ELSEIF(TAB.EQ.'F') THEN C Replication factor. IF(.NOT.REP) GOTO 904 IRPS(NSEQ+1) = IRET REP = .FALSE. ELSEIF(TAB.EQ.'D'.OR.TAB.EQ.'C') THEN REP = .FALSE. NSEQ = NSEQ+1 NEMS(NSEQ) = NEMT ELSEIF(TAB.EQ.'B') THEN REP = .FALSE. NSEQ = NSEQ+1 IF((NEMT(1:1).EQ.'.').AND.(J.LT.NDSC)) THEN C This is a "following value" mnemonic. CALL UPTDD(ITAB,LUN,J+1,IDSC) c .... get NEMF from IDSC CALL NUMTAB(LUN,IDSC,NEMF,TAB,IRET) CALL RSVFVM(NEMT,NEMF) IF(TAB.NE.'B') GOTO 906 ENDIF NEMS(NSEQ) = NEMT ELSE GOTO 905 ENDIF ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN '// . 'TABLE D")') ITAB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - INTEGER REPRESENTATION OF '// . 'DESCRIPTOR FOR TABLE D MNEMONIC ",A," (",I7,") IS OUTSIDE '// . 'RANGE 0-65535 (65535 -> 3-63-255)")') NEMO,IDSC CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'// . ' ZERO LENGTH SEQUENCE")') NEMO CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '// . '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '// . 'MNEMONIC ",A)') MAXCD, NEMO CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '// . 'IN TABLE D SEQUENCE MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 905 CLEMON = ADN30(IDSC,6) WRITE(BORT_STR,'("BUFRLIB: NEMTBD - UNRECOGNIZED DESCRIPTOR '// . '",A," IN TABLE D SEQUENCE MNEMONIC ",A)') CLEMON,NEMO CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLIB: NEMTBD - A ''FOLLOWING VALUE'' '// . 'MNEMONIC (",A,") IS FROM TABLE ",A,", IT MUST BE FROM TABLE B'// . '")') NEMF,TAB CALL BORT(BORT_STR) END ./nenubd.f0000644001370400056700000000735613440555365011420 0ustar jator2emc SUBROUTINE NENUBD(NEMO,NUMB,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NENUBD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS A MNEMONIC AND FXY VALUE PAIR THAT C WERE READ FROM A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER C FORMAT, IN ORDER TO MAKE SURE THAT NEITHER VALUE HAS ALREADY BEEN C DEFINED WITHIN INTERNAL BUFR TABLE B OR D (IN MODULE TABABD) FOR C THE GIVEN LUN. IF EITHER VALUE HAS ALREADY BEEN DEFINED FOR THIS C LUN, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR (ENTRY POINT IN NENUCK) C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE C ARRAYS IN ORDER TO HANDLE BIGGER FILES C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" (IN PARENT ROUTINE NENUCK) 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) (IN PARENT C ROUTINE NENUCK) C 2002-05-14 J. WOOLLEN -- CHANGED FROM AN ENTRY POINT TO INCREASE C PORTABILITY TO OTHER PLATFORMS (NENUCK WAS C THEN REMOVED BECAUSE IT WAS JUST A DUMMY C ROUTINE WITH ENTRIES) 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NENUBD (NEMO, NUMB, LUN) C INPUT ARGUMENT LIST: C NEMO - CHARACTER*8: MNEMONIC C NUMB - CHARACTER*6: FXY VALUE ASSOCIATED WITH NEMO C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: STBFDX STNTBI C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 NEMO CHARACTER*6 NUMB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK TABLE B AND D C ------------------- DO N=1,NTBB(LUN) IF(NUMB.EQ.TABB(N,LUN)(1: 6)) GOTO 900 IF(NEMO.EQ.TABB(N,LUN)(7:14)) GOTO 901 ENDDO DO N=1,NTBD(LUN) IF(NUMB.EQ.TABD(N,LUN)(1: 6)) GOTO 902 IF(NEMO.EQ.TABD(N,LUN)(7:14)) GOTO 903 ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B FXY VALUE (",A,") '// . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE B MNEMONIC (",A,") '// . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D FXY VALUE (",A,") '// . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: NENUBD - TABLE D MNEMONIC (",A,") '// . 'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO CALL BORT(BORT_STR) END ./nevn.f0000644001370400056700000000765713440555365011117 0ustar jator2emc FUNCTION NEVN(NODE,LUN,INV1,INV2,I1,I2,I3,USR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEVN C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS FUNCTION LOOKS FOR ALL STACKED DATA EVENTS FOR A C SPECIFIED DATA VALUE AND LEVEL WITHIN THE PORTION OF THE CURRENT C SUBSET BUFFER BOUNDED BY THE INDICES INV1 AND INV2. ALL SUCH C EVENTS ARE ACCUMULATED AND RETURNED TO THE CALLING PROGRAM WITHIN C ARRAY USR. THE VALUE OF THE FUNCTION ITSELF IS THE TOTAL NUMBER C OF EVENTS FOUND. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION C VERSION) 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 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: NEVN (NODE, LUN, INV1, INV2, I1, I2, I3, USR) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX OF NODE TO RETURN C STACKED VALUES FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK FOR STACK VALUES C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK FOR STACK VALUES C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR C C OUTPUT ARGUMENT LIST: C USR - REAL*8:(I1,I2,I3) STARTING ADDRESS OF DATA VALUES READ C FROM DATA SUBSET, EVENTS ARE RETURNED IN THE THIRD C DIMENSION FOR A PARTICULAR DATA VALUE AND LEVEL IN THE C FIRST AND SECOND DIMENSIONS C NEVN - INTEGER: NUMBER OF EVENTS IN STACK (MUST BE LESS THAN C OR EQUAL TO I3) C C REMARKS: C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY ROUTINE UFBIN3, C WHICH, ITSELF, IS CALLED ONLY BY VERIFICATION C APPLICATION PROGRAM GRIDTOBS, WHERE IT WAS PREVIOUSLY C AN IN-LINE SUBROUTINE. IN GENERAL, NEVN DOES NOT WORK C PROPERLY IN OTHER APPLICATION PROGRAMS AT THIS TIME. C C THIS ROUTINE CALLS: BORT INVWIN LSTJPB C THIS ROUTINE IS CALLED BY: UFBIN3 C Should NOT be called by any C application programs!!! C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR DIMENSION USR(I1,I2,I3) REAL*8 USR C---------------------------------------------------------------------- C---------------------------------------------------------------------- NEVN = 0 C FIND THE ENCLOSING EVENT STACK DESCRIPTOR C ----------------------------------------- NDRS = LSTJPB(NODE,LUN,'DRS') IF(NDRS.LE.0) GOTO 100 INVN = INVWIN(NDRS,LUN,INV1,INV2) IF(INVN.EQ.0) GOTO 900 NEVN = VAL(INVN,LUN) IF(NEVN.GT.I3) GOTO 901 C SEARCH EACH STACK LEVEL FOR THE REQUESTED NODE AND COPY THE VALUE C ----------------------------------------------------------------- N2 = INVN + 1 DO L=1,NEVN N1 = N2 N2 = N2 + VAL(N1,LUN) DO N=N1,N2 IF(INV(N,LUN).EQ.NODE) USR(1,1,L) = VAL(N,LUN) ENDDO ENDDO C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: NEVN - CAN''T FIND THE EVENT STACK!!!!!!') 901 WRITE(BORT_STR,'("BUFRLIB: NEVN - THE NO. OF EVENTS FOR THE '// . 'REQUESTED STACK (",I3,") EXCEEDS THE VALUE OF THE 3RD DIM. OF'// . ' THE USR ARRAY (",I3,")")') NEVN,I3 CALL BORT(BORT_STR) END ./newwin.f0000644001370400056700000000657613440555365011457 0ustar jator2emc SUBROUTINE NEWWIN(LUN,IWIN,JWIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NEWWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: GIVEN AN INDEX WITHIN THE INTERNAL JUMP/LINK TABLE WHICH C POINTS TO THE START OF AN "RPC" WINDOW (I.E. ITERATION OF AN 8-BIT C OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE COMPUTES C THE ENDING INDEX OF THE WINDOW. ALTERNATIVELY, IF THE GIVEN INDEX C POINTS TO THE START OF A "SUB" WINDOW (I.E. THE FIRST NODE OF A C SUBSET), THE SUBROUTINE RETURNS THE INDEX OF THE LAST NODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NEWWIN (LUN, IWIN, JWIN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IWIN - INTEGER: STARTING INDEX OF WINDOW ITERATION C C OUTPUT ARGUMENT LIST: C JWIN - INTEGER: ENDING INDEX OF WINDOW ITERATION C C REMARKS: C C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. C C THIS ROUTINE CALLS: BORT LSTJPB C THIS ROUTINE IS CALLED BY: DRSTPL UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(IWIN.EQ.1) THEN C This is a "SUB" (subset) node, so return JWIN as pointing to C the last value of the entire subset. JWIN = NVAL(LUN) GOTO 100 ENDIF C Confirm that IWIN points to an RPC node and then compute JWIN. NODE = INV(IWIN,LUN) IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 JWIN = IWIN+VAL(IWIN,LUN) C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NEWWIN - LSTJPB FOR NODE",I6,'// . '" (LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC '// . '(IWIN =",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN CALL BORT(BORT_STR) END ./nmsub.f0000644001370400056700000000500513440555365011256 0ustar jator2emc FUNCTION NMSUB(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NMSUB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION RETURNS THE NUMBER OF SUBSETS IN A BUFR C MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE READMG OR EQUIVALENT. THE SUBSETS THEMSELVES DO NOT C HAVE TO BE READ. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 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 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: NMSUB (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C NMSUB - INTEGER: NUMBER OF SUBSETS IN BUFR MESSAGE C C REMARKS: C THIS ROUTINE CALLS: BORT STATUS C THIS ROUTINE IS CALLED BY: UFBMNS UFBPOS UFBTAB UFBTAM C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- NMSUB = 0 C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 NMSUB = MSUB(LUN) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST '// . 'BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT,'// . ' IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') END ./nmwrd.f0000644001370400056700000000263713440555365011271 0ustar jator2emc FUNCTION NMWRD(MBAY) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NMWRD C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: GIVEN AN INTEGER ARRAY CONTAINING SECTION ZERO FROM A C BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT OF MACHINE WORDS C (I.E. INTEGER ARRAY MEMBERS) THAT WILL HOLD THE ENTIRE MESSAGE. C NOTE THAT THIS COUNT MAY BE GREATER THAN THE MINIMUM NUMBER C OF WORDS REQUIRED TO HOLD THE MESSAGE. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: NMWRD (MBAY) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD ARRAY CONTAINING SECTION ZERO C FROM A BUFR MESSAGE C C OUTPUT ARGUMENT LIST: C NMWRD - INTEGER: BUFR MESSAGE LENGTH (IN MACHINE WORDS) C C REMARKS: C THIS ROUTINE CALLS: IUPBS01 C THIS ROUTINE IS CALLED BY: CNVED4 CPDXMM LMSG MSGWRT C PADMSG UFBMEM UFBMEX C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- LENM = IUPBS01(MBAY,'LENM') IF(LENM.EQ.0) THEN NMWRD = 0 ELSE NMWRD = ((LENM/8)+1)*(8/NBYTW) ENDIF RETURN END ./numbck.f0000644001370400056700000000572613440555365011423 0ustar jator2emc FUNCTION NUMBCK(NUMB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NUMBCK C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION CHECKS THE INPUT CHARACTER STRING TO DETERMINE C WHETHER IT CONTAINS A VALID FXY (DESCRIPTOR) VALUE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 -- SPLIT NON-ZERO RETURN INTO -1 FOR INVALID C CHARACTER IN POSITION 1, -2 FOR INVALID C CHARACTERS IN POSITIONS 2 THROUGH 6, -3 FOR C INVALID CHARACTERS IN POSITIONS 2 AND 3 DUE C TO BEING OUT OF RANGE, AND -4 FOR INVALID C CHARACTERS IN POSITIONS 4 THROUGH 6 DUE TO C BEING OUT OF RANGE (RETURN ONLY -1 BEFORE C FOR ALL PROBLEMATIC CASES); UNIFIED/ C PORTABLE FOR WRF; ADDED HISTORY C DOCUMENTATION C 2007-01-19 J. ATOR -- CLEANED UP AND SIMPLIFIED LOGIC C C USAGE: NUMBCK (NUMB) C INPUT ARGUMENT LIST: C NUMB - CHARACTER*6: FXY VALUE TO BE CHECKED C C OUTPUT ARGUMENT LIST: C NUMBCK - INTEGER: INDICATOR AS TO WHETHER NUMB IS VALID: C 0 = YES C -1 = NO - first character ("F" value) is not '0', C '1', '2' OR '3' C -2 = NO - remaining characters (2-6) ("X" and "Y" C values) are not all numeric C -3 = NO - characters 2-3 ("X" value) are not C between '00' and '63' C -4 = NO - characters 4-6 ("Y" value) are not C between '000' and '255' C C REMARKS: C THIS ROUTINE CALLS: DIGIT C THIS ROUTINE IS CALLED BY: IGETFXY RDUSDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*6 NUMB LOGICAL DIGIT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FIRST CHARACTER OF NUMB C --------------------------------- IF( LLT(NUMB(1:1),'0') .OR. LGT(NUMB(1:1),'3') ) THEN NUMBCK = -1 RETURN ENDIF C CHECK FOR A VALID DESCRIPTOR C ---------------------------- IF(DIGIT(NUMB(2:6))) THEN READ(NUMB,'(1X,I2,I3)') IX,IY ELSE NUMBCK = -2 RETURN ENDIF IF(IX.LT.0 .OR. IX.GT. 63) THEN NUMBCK = -3 RETURN ELSE IF(IY.LT.0 .OR. IY.GT.255) THEN NUMBCK = -4 RETURN ENDIF NUMBCK = 0 RETURN END ./nummtb.c0000644001370400056700000000366213440555365011440 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NUMMTB C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS ROUTINE SEARCHES FOR AN ENTRY CORRESPONDING TO IDN C IN THE BUFR MASTER TABLE (EITHER 'B' OR 'D', DEPENDING ON THE VALUE C OF IDN). THE SEARCH USES BINARY SEARCH LOGIC, SO ALL OF THE ENTRIES C IN THE TABLE MUST BE SORTED IN ASCENDING ORDER (BY FXY NUMBER) IN C ORDER FOR THIS ROUTINE TO WORK PROPERLY. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL NUMMTB( IDN, TAB, IPT ) C INPUT ARGUMENT LIST: C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE TO BE C SEARCHED FOR C C OUTPUT ARGUMENT LIST: C TAB - CHARACTER: TABLE IN WHICH IDN WAS FOUND ('B' OR 'D') C IPT - INTEGER: INDEX OF ENTRY FOR IDN IN MASTER TABLE TAB C C REMARKS: C THIS ROUTINE CALLS: BORT CADN30 CMPIA C THIS ROUTINE IS CALLED BY: STSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "mstabs.h" void nummtb( f77int *idn, char *tab, f77int *ipt ) { f77int *pifxyn, *pbs, nmt; char adn[7], errstr[129]; if ( *idn >= ifxy( "300000", 6 ) ) { *tab = 'D'; pifxyn = &MSTABS_BASE(idfxyn)[0]; nmt = MSTABS_BASE(nmtd); } else { *tab = 'B'; pifxyn = &MSTABS_BASE(ibfxyn)[0]; nmt = MSTABS_BASE(nmtb); } pbs = ( f77int * ) bsearch( idn, pifxyn, ( size_t ) nmt, sizeof( f77int ), ( int (*) ( const void *, const void * ) ) cmpia ); if ( pbs == NULL ) { cadn30( idn, adn, sizeof( adn ) ); adn[6] = '\0'; sprintf( errstr, "BUFRLIB: NUMMTB - COULD NOT FIND DESCRIPTOR " "%s IN MASTER TABLE %c", adn, *tab ); bort( errstr, ( f77int ) strlen( errstr ) ); } *ipt = pbs - pifxyn; return; } ./numtab.f0000644001370400056700000001606113440555365011424 0ustar jator2emc SUBROUTINE NUMTAB(LUN,IDN,NEMO,TAB,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NUMTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE FIRST SEARCHES FOR AN INTEGER IDN, C CONTAINING THE BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, C WITHIN THE INTERNAL BUFR REPLICATION ARRAYS IN COMMON BLOCK /REPTAB/ C TO SEE IF IDN IS A REPLICATION DESCRIPTOR OR A REPLICATION FACTOR C DESCRIPTOR. IF THIS SEARCH IS UNSUCCESSFUL, IT SEACHES FOR IDN C WITHIN THE INTERNAL BUFR TABLE D AND B ARRAYS TO SEE IF IDN IS A C TABLE D OR TABLE B DESCRIPTOR. IF THIS SEARCH IS ALSO UNSUCCESSFUL, C IT SEARCHES TO SEE IF IDN IS A TABLE C OPERATOR DESCRIPTOR. IF IDN C IS FOUND IN ANY OF THESE SEARCHES, THIS SUBROUTINE RETURNS THE C CORRESPONDING MNEMONIC AND OTHER INFORMATION FROM WITHIN EITHER THE C INTERNAL ARRAYS FOR REPLICATION, REPLICATION FACTOR, TABLE D OR C TABLE B DESCRIPTORS, OR ELSE FROM THE KNOWN VALUES FOR TABLE C C DESCRIPTORS. IF IDN IS NOT FOUND, IT RETURNS WITH IRET=0. 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 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 -- ADDED CAPABILITY TO ENCODE AND DECODE DATA C USING THE OPERATOR DESCRIPTORS (BUFR TABLE C C) FOR CHANGING WIDTH AND CHANGING SCALE 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; CORRECTED TYPO ("IDN" WAS C SPECIFIED AS "ID" IN CALCULATION OF IRET C FOR TAB='C') C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS C 2009-04-21 J. ATOR -- USE NUMTBD C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 AND 205 OPERATORS C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR C 2015-02-25 J. ATOR -- ALLOW PROCESSING OF 2-2X, 2-3X AND 2-4X C NON-MARKER OPERATORS IN DX TABLES C C USAGE: CALL NUMTAB (LUN, IDN, NEMO, TAB, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) C VALUE C C OUTPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE C REPRESENTED BY IDN: C 'B' = BUFR Table B descriptor C 'C' = BUFR Table C descriptor C 'D' = BUFR Table D descriptor C 'R' = BUFR replication descriptor C 'F' = BUFR replication factor descriptor C IRET - INTEGER: RETURN VALUE (SEE REMARKS) C C REMARKS: C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE C RETURN VALUE OF TAB AND THE INPUT VALUE IDN, AS FOLLOWS: C C IF ( TAB = 'B' ) THEN C IRET = positional index of IDN within internal BUFR Table B C array C ELSE IF ( TAB = 'C') THEN C IRET = the X portion of the FXY value that is bit-wise C represented by IDN C ELSE IF ( TAB = 'D') THEN C IRET = positional index of IDN within internal BUFR Table D C array C ELSE IF ( TAB = 'R') THEN C IF ( IDN denoted regular (i.e. non-delayed) replication ) THEN C IRET = ((-1)*Y), where Y is the number of replications C ELSE ( i.e. delayed replication ) C IRET = positional index (=I) of IDN within internal C replication descriptor array IDNR(I,1), where: C IRET (=I) =2 --> 16-bit delayed replication descriptor C IRET (=I) =3 --> 8-bit delayed replication descriptor C IRET (=I) =4 --> 8-bit delayed replication descriptor C (stack) C IRET (=I) =5 --> 1-bit delayed replication descriptor C END IF C ELSE IF ( TAB = 'F') THEN C IRET = positional index (=I) of IDN within internal replication C factor array IDNR(I,2), where: C IRET (=I) =2 --> 16-bit replication factor C IRET (=I) =3 --> 8-bit replication factor C IRET (=I) =4 --> 8-bit replication factor C (stack) C IRET (=I) =5 --> 1-bit replication factor C ELSE IF ( IRET = 0 ) THEN C IDN was not found in internal BUFR Table B or D, nor does it C represent a Table C operator descriptor, a replication C descriptor, or a replication factor descriptor C END IF C C C THIS ROUTINE CALLS: ADN30 IOKOPER NUMTBD C THIS ROUTINE IS CALLED BY: CKTABA NEMTBD SEQSDX STNDRD C UFBQCP 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' C Note that the values within the COMMON /REPTAB/ arrays were C initialized within subroutine BFRINI. COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) CHARACTER*(*) NEMO CHARACTER*6 ADN30,CID CHARACTER*3 TYPS CHARACTER*1 REPS,TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- NEMO = ' ' IRET = 0 TAB = ' ' C LOOK FOR A REPLICATOR OR A REPLICATION FACTOR DESCRIPTOR C -------------------------------------------------------- IF(IDN.GE.IDNR(1,1) .AND. IDN.LE.IDNR(1,2)) THEN C Note that the above test is checking whether IDN is the bit- C wise representation of a FXY (descriptor) value denoting F=1 C regular (i.e. non-delayed) replication, since, as was C initialized within subroutine BFRINI, C IDNR(1,1) = IFXY('101000'), and IDNR(1,2) = IFXY('101255'). TAB = 'R' IRET = -MOD(IDN,256) GOTO 100 ENDIF DO I=2,5 IF(IDN.EQ.IDNR(I,1)) THEN TAB = 'R' IRET = I GOTO 100 ELSEIF(IDN.EQ.IDNR(I,2)) THEN TAB = 'F' IRET = I GOTO 100 ENDIF ENDDO C LOOK FOR IDN IN TABLE B AND TABLE D C ----------------------------------- CALL NUMTBD(LUN,IDN,NEMO,TAB,IRET) IF(IRET.NE.0) GOTO 100 C LOOK FOR IDN IN TABLE C C ----------------------- CID = ADN30(IDN,6) IF (IOKOPER(CID).EQ.1) THEN NEMO = CID(1:6) READ(NEMO,'(1X,I2)') IRET TAB = 'C' GOTO 100 ENDIF C EXIT C ---- 100 RETURN END ./numtbd.f0000644001370400056700000000635113440555365011430 0ustar jator2emc SUBROUTINE NUMTBD(LUN,IDN,NEMO,TAB,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NUMTBD C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE SEARCHES FOR AN INTEGER IDN, CONTAINING THE C BIT-WISE REPRESENTATION OF A DESCRIPTOR (FXY) VALUE, WITHIN THE C INTERNAL BUFR TABLE B AND D ARRAYS IN MODULE TABABD. IF FOUND, C IT RETURNS THE CORRESPONDING MNEMONIC AND OTHER INFORMATION FROM C WITHIN THESE ARRAYS. IF IDN IS NOT FOUND, IT RETURNS WITH IRET=0. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR 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) C 2009-04-21 J. ATOR -- USE IFXY FOR MORE EFFICIENT SEARCHING C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NUMTBD (LUN, IDN, NEMO, TAB, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IDN - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR (FXY) C VALUE C C OUTPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC CORRESPONDING TO IDN C TAB - CHARACTER*1: TYPE OF FXY VALUE THAT IS BIT-WISE C REPRESENTED BY IDN: C 'B' = BUFR Table B descriptor C 'D' = BUFR Table D descriptor C IRET - INTEGER: RETURN VALUE (SEE REMARKS) C C REMARKS: C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE C RETURN VALUE OF TAB, AS FOLLOWS: C C IF ( TAB = 'B' ) THEN C IRET = positional index of IDN within internal BUFR Table B C array C ELSE IF ( TAB = 'D') THEN C IRET = positional index of IDN within internal BUFR Table D C array C ELSE IF ( IRET = 0 ) THEN C IDN was not found in internal BUFR Table B or D C END IF C C C THIS ROUTINE CALLS: IFXY C THIS ROUTINE IS CALLED BY: GETCFMNG NUMTAB RESTD STSEQ C UFDUMP C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*(*) NEMO CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- NEMO = ' ' IRET = 0 TAB = ' ' IF(IDN.GE.IFXY('300000')) THEN C LOOK FOR IDN IN TABLE D C ----------------------- DO I=1,NTBD(LUN) IF(IDN.EQ.IDND(I,LUN)) THEN NEMO = TABD(I,LUN)(7:14) TAB = 'D' IRET = I GOTO 100 ENDIF ENDDO ELSE C LOOK FOR IDN IN TABLE B C ----------------------- DO I=1,NTBB(LUN) IF(IDN.EQ.IDNB(I,LUN)) THEN NEMO = TABB(I,LUN)(7:14) TAB = 'B' IRET = I GOTO 100 ENDIF ENDDO ENDIF C EXIT C ---- 100 RETURN END ./nvnwin.f0000644001370400056700000000755513440555365011465 0ustar jator2emc FUNCTION NVNWIN(NODE,LUN,INV1,INV2,INVN,NMAX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NVNWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION LOOKS FOR AND RETURNS ALL OCCURRENCES OF A C SPECIFIED NODE WITHIN THE PORTION OF THE CURRENT SUBSET BUFFER C BOUNDED BY THE INDICES INV1 AND INV2. THE RESULTING LIST IS A C STACK OF "EVENT" INDICES FOR THE REQUESTED NODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C UNUSUAL THINGS HAPPEN C 2009-03-23 J. ATOR -- USE 1E9 TO PREVENT OVERFLOW WHEN C INITIALIZING INVN; USE ERRWRT C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: NVNWIN (NODE, LUN, INV1, INV2, INVN, NMAX) C INPUT ARGUMENT LIST: C NODE - INTEGER: JUMP/LINK TABLE INDEX TO LOOK FOR C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INV1 - INTEGER: STARTING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C INV2 - INTEGER: ENDING INDEX OF THE PORTION OF THE SUBSET C BUFFER IN WHICH TO LOOK C NMAX - INTEGER: DIMENSIONED SIZE OF INVN; USED BY THE C FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW THE C INVN ARRAY C C OUTPUT ARGUMENT LIST: C INVN - INTEGER: ARRAY OF STACK "EVENT" INDICES FOR NODE C NVNWIN - INTEGER: NUMBER OF INDICES RETURNED WITHIN INVN C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT C THIS ROUTINE IS CALLED BY: UFBEVN C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR DIMENSION INVN(NMAX) C---------------------------------------------------------------------- C---------------------------------------------------------------------- NVNWIN = 0 IF(NODE.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT('BUFRLIB: NVNWIN - NODE=0, IMMEDIATE RETURN') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF DO I=1,NMAX INVN(I) = 1E9 ENDDO C SEARCH BETWEEN INV1 AND INV2 C ---------------------------- DO N=INV1,INV2 IF(INV(N,LUN).EQ.NODE) THEN IF(NVNWIN+1.GT.NMAX) GOTO 900 NVNWIN = NVNWIN+1 INVN(NVNWIN) = N ENDIF ENDDO C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NVNWIN - THE NUMBER OF EVENTS, '// . 'NVNWIN (",I5,") EXCEEDS THE LIMIT, NMAX (",I5,")")') NVNWIN,NMAX CALL BORT(BORT_STR) END ./nwords.f0000644001370400056700000000411213440555365011444 0ustar jator2emc FUNCTION NWORDS(N,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NWORDS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1996-10-09 C C ABSTRACT: THIS FUNCTION ADDS UP THE COMPLETE LENGTH OF THE DELAYED C REPLICATION SEQUENCE BEGINNING AT INDEX N OF THE DATA SUBSET. C C PROGRAM HISTORY LOG: C 1996-10-09 J. WOOLLEN -- ORIGINAL AUTHOR 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE) C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: NWORDS (N, LUN) C INPUT ARGUMENT LIST: C N - INTEGER: INDEX TO START OF DELAYED REPLICATION SEQUENCE C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C NWORDS - INTEGER: COMPLETE LENGTH OF DELAYED REPLICATION C SEQUENCE WITHIN DATA SUBSET C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: INVMRG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- NWORDS = 0 DO K=1,NINT(VAL(N,LUN)) NWORDS = NWORDS + NINT(VAL(NWORDS+N+1,LUN)) ENDDO RETURN END ./nxtwin.f0000644001370400056700000000664713440555365011476 0ustar jator2emc SUBROUTINE NXTWIN(LUN,IWIN,JWIN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: NXTWIN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: GIVEN INDICES WITHIN THE INTERNAL JUMP/LINK TABLE WHICH C POINT TO THE START AND END OF AN "RPC" WINDOW (I.E. ITERATION OF C AN 8-BIT OR 16-BIT DELAYED REPLICATION SEQUENCE), THIS SUBROUTINE C COMPUTES THE START AND END INDICES OF THE NEXT WINDOW. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2009-03-31 J. WOOLLEN -- ADDED ADDITIONAL DOCUMENTATION C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL NXTWIN (LUN, IWIN, JWIN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IWIN - INTEGER: STARTING INDEX OF CURRENT WINDOW ITERATION C JWIN - INTEGER: ENDING INDEX OF CURRENT WINDOW ITERATION C C OUTPUT ARGUMENT LIST: C IWIN - INTEGER: STARTING INDEX OF NEXT WINDOW ITERATION C JWIN - INTEGER: ENDING INDEX OF NEXT WINDOW ITERATION C C REMARKS: C C SEE THE DOCBLOCK IN BUFR ARCHIVE LIBRARY SUBROUTINE GETWIN FOR AN C EXPLANATION OF "WINDOWS" WITHIN THE CONTEXT OF A BUFR DATA SUBSET. C C THIS ROUTINE CALLS: BORT LSTJPB C THIS ROUTINE IS CALLED BY: UFBEVN UFBIN3 UFBRW C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(JWIN.EQ.NVAL(LUN)) THEN IWIN = 0 GOTO 100 ENDIF C FIND THE NEXT SEQUENTIAL WINDOW C ------------------------------- NODE = INV(IWIN,LUN) IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 IF(VAL(JWIN,LUN).EQ.0) THEN IWIN = 0 ELSE IWIN = JWIN JWIN = IWIN+VAL(IWIN,LUN) ENDIF C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '// . '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN '// . '=",I8,")")') NODE,LSTJPB(NODE,LUN,'RPC'),IWIN CALL BORT(BORT_STR) END ./openbf.F0000644001370400056700000003221713440555365011350 0ustar jator2emc SUBROUTINE OPENBF(LUNIT,IO,LUNDX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: OPENBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE NORMALLY (I.E. EXCEPT WHEN INPUT ARGUMENT C IO IS 'QUIET') IDENTIFIES A NEW LOGICAL UNIT TO THE BUFR ARCHIVE C LIBRARY SOFTWARE FOR INPUT OR OUTPUT OPERATIONS. HOWEVER, THE C FIRST TIME IT IS CALLED, IT ALSO FIGURES OUT SOME IMPORTANT C INFORMATION ABOUT THE LOCAL MACHINE ON WHICH THE SOFTWARE IS BEING C RUN (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE WRDLEN), AND IT C ALSO INITIALIZES ARRAYS IN MANY BUFR ARCHIVE LIBRARY COMMON BLOCKS C (VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE BFRINI). UP TO 32 C LOGICAL UNITS CAN BE CONNECTED TO THE BUFR ARCHIVE LIBRARY SOFTWARE C AT ANY ONE TIME. C C NOTE: IF IO IS PASSED IN AS 'QUIET', THEN OPENBF PERFORMS ONLY ONE C FUNCTION - IT SIMPLY SETS THE "DEGREE OF PRINTOUT" SWITCH IPRT (IN C COMMON BLOCK /QUIET/) TO THE VALUE OF INPUT ARGUMENT LUNDX, C OVERRIDING ITS PREVIOUS VALUE. A DEFAULT IPRT VALUE OF 0 (I.E. C "LIMITED PRINTOUT") IS SET DURING THE FIRST CALL TO THIS ROUTINE, C BUT THIS OR ANY OTHER IPRT VALUE MAY BE SET AND RESET AS OFTEN AS C DESIRED VIA SUCCESSIVE CALLS TO OPENBF WITH IO = 'QUIET'. C IN ALL SUCH CASES, OPENBF SIMPLY (RE)SETS IPRT AND THEN RETURNS C WITHOUT ACTUALLY OPENING ANY FILES. THE DEGREE OF PRINTOUT C INCREASES AS IPRT INCREASES FROM "-1" TO "0" TO "1" TO "2". C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 IO='NUL' OPTION IN ORDER TO PREVENT C LATER WRITING TO BUFR FILE IN LUNIT (WAS IN C DECODER VERSION); 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, UNUSUAL THINGS HAPPEN OR FOR C INFORMATIONAL PURPOSES C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IO="NODX" C OPTION C 2005-11-29 J. ATOR -- ADDED COMMON /MSGFMT/ AND ICHKSTR CALL C 2009-03-23 J. ATOR -- ADDED IO='SEC3' OPTION; REMOVED CALL TO C POSAPN; CLARIFIED COMMENTS; USE ERRWRT C 2010-05-11 J. ATOR -- ADDED COMMON /STCODE/ C 2012-06-18 J. ATOR -- ADDED IO='INUL' OPTION C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE INQUIRE TO OBTAIN THE FILENAME; C CALL C ROUTINES OPENRB, OPENWB, AND C OPENAB TO CONNECT BUFR FILES TO C; C ADDED IO TYPE 'INX' TO ENABLE OPEN AND C CLOSE FOR C FILE WITHOUT CLOSING FORTRAN C FILE; ADD IO TYPE 'FIRST' TO SUPPORT CALLS C TO BFRINI AND WRDLEN PRIOR TO USER RESET C OF BUFRLIB PARAMETERS FOUND IN NEW ROUTINES C SETBMISS AND SETBLOCK C 2014-11-07 J. ATOR -- ALLOW DYNAMIC ALLOCATION OF CERTAIN ARRAYS C 2015-03-03 J. ATOR -- USE MODA_IFOPBF INSTEAD OF IFIRST C C USAGE: CALL OPENBF (LUNIT, IO, LUNDX) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C (UNLESS IO IS 'QUIET', THEN A DUMMY) C IO - CHARACTER*(*): FLAG INDICATING HOW LUNIT IS TO BE C USED BY THE SOFTWARE: C 'IN' = input operations with table processing C 'INX' = input operations w/o table processing C 'OUX' = output operations w/o table processing C 'OUT' = output operations with table processing C 'SEC3' = same as 'IN', except use Section 3 of input C messages for decoding rather than dictionary C table information from LUNDX; in this case C LUNDX is ignored, and user must provide C appropriate BUFR master tables within C directory specified by a subsequent call C to subroutine MTINFO C 'NODX' = same as 'OUT', except don't write dictionary C (i.e. DX) table messages to LUNIT C 'APN' = same as 'NODX', except begin writing at end C of file ("append") C 'APX' = same as 'APN', except backspace before C appending C 'NUL' = same as 'OUT', except don't write any C messages whatsoever to LUNIT (e.g. when C subroutine WRITSA is to be used) C 'INUL' = same as 'IN', except don't read any C messages whatsoever from LUNIT (e.g. when C subroutine READERME is to be used) C 'QUIET' = LUNIT is ignored, this is an indicator C that the value for IPRT in COMMON block C /QUIET/ is being reset (see LUNDX) C 'FIRST' = calls bfrini and wrdlen as a prelude to user c resetting of bufrlib parameters such as c missing value or output block type C LUNDX - INTEGER: IF IO IS NOT 'QUIET': C FORTRAN logical unit number containing C dictionary table information to be used in C reading/writing from/to LUNIT (depending C on the case); may be set equal to LUNIT if C dictionary table information is already C embedded in LUNIT C IF IO IS 'QUIET': C Indicator for degree of printout: C -1 = NO printout except for ABORT C messages C 0 = LIMITED printout (default) C 1 = ALL warning messages are printed C out C 2 = ALL warning AND informational C messages are printed out C (Note: this does not change until OPENBF C is again called with IO equal to C 'QUIET') C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: ARALLOCC ARALLOCF BFRINI BORT C DXINIT ERRWRT POSAPX READDX C STATUS WRDLEN WRITDX WTSTAT C OPENRB OPENWB OPENAB C THIS ROUTINE IS CALLED BY: COPYBF GETBMISS IGETMXBY MESGBC C MESGBF PKVS01 RDMGSB UFBINX C UFBMEM UFBMEX UFBTAB SETBMISS C SETBLOCK C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_STBFR USE MODA_SC3BFR USE MODA_LUSHR USE MODA_NULBFR USE MODA_STCODE USE MODA_IFOPBF INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*(*) IO CHARACTER*255 filename,fileacc CHARACTER*128 BORT_STR,ERRSTR CHARACTER*28 CPRINT(0:3) CHARACTER*1 BSTR(4) DATA CPRINT/ . ' (only ABORTs) ', . ' (limited - default) ', . ' (all warnings) ', . ' (all warning+informational)'/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C If this is the first call to this subroutine, initialize C IPRT in /QUIET/ as 0 (limited printout - except for abort C messages) IF(IFOPBF.EQ.0) IPRT = 0 IF(IO.EQ.'QUIET') THEN c .... override previous IPRT value (printout indicator) IF(LUNDX.LT.-1) LUNDX = -1 IF(LUNDX.GT. 2) LUNDX = 2 IF(LUNDX.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,A,I3,A)' ) . 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR '// . 'CHNGED FROM',IPRT,CPRINT(IPRT+1),' TO',LUNDX,CPRINT(LUNDX+1) CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF IPRT = LUNDX ENDIF IF(IFOPBF.EQ.0) THEN C This is the first call to this subroutine, so take care of some C initial housekeeping tasks. Note that ARALLOCF, ARALLOCC, and C WRDLEN must all be called prior to calling BFRINI. #ifdef DYNAMIC_ALLOCATION C Allocate any arrays which are being dynamically sized. CALL ARALLOCF CALL ARALLOCC #endif C Figure out some important information about the local machine. CALL WRDLEN C Initialize some global variables. CALL BFRINI IFOPBF = 1 ENDIF IF(IO.EQ.'FIRST') GOTO 100 IF(IO.EQ.'QUIET') GOTO 100 C SEE IF A FILE CAN BE OPENED C --------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(LUN.EQ.0) GOTO 900 IF(IL .NE.0) GOTO 901 NULL(LUN) = 0 ISC3(LUN) = 0 ISCODES(LUN) = 0 LUS(LUN) = 0 C USE INQUIRE TO OBTAIN THE FILENAME ASSOCIATED WITH UNIT LUNIT C ------------------------------------------------------------- IF (IO.NE.'NUL' .AND. IO.NE.'INUL') THEN INQUIRE(LUNIT,ACCESS=FILEACC) IF(FILEACC=='UNDEFINED') OPEN(LUNIT) INQUIRE(LUNIT,NAME=FILENAME) FILENAME=TRIM(FILENAME)//CHAR(0) ENDIF C SET INITIAL OPEN DEFAULTS (CLEAR OUT A MSG CONTROL WORD PARTITION) C ------------------------------------------------------------------ NMSG (LUN) = 0 NSUB (LUN) = 0 MSUB (LUN) = 0 INODE(LUN) = 0 IDATE(LUN) = 0 C DECIDE HOW TO OPEN THE FILE AND SETUP THE DICTIONARY C ---------------------------------------------------- IF(IO.EQ.'IN') THEN CALL OPENRB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN,-1,0) CALL READDX(LUNIT,LUN,LUNDX) ELSE IF(IO.EQ.'INUL') THEN CALL WTSTAT(LUNIT,LUN,-1,0) IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) NULL(LUN) = 1 ELSE IF(IO.EQ.'NUL') THEN CALL WTSTAT(LUNIT,LUN, 1,0) IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) NULL(LUN) = 1 ELSE IF(IO.EQ.'INX') THEN CALL OPENRB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN,-1,0) NULL(LUN) = 1 ELSE IF(IO.EQ.'OUX') THEN CALL OPENWB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN, 1,0) ELSE IF(IO.EQ.'SEC3') THEN CALL OPENRB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN,-1,0) ISC3(LUN) = 1 ELSE IF(IO.EQ.'OUT') THEN CALL OPENWB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN, 1,0) CALL WRITDX(LUNIT,LUN,LUNDX) ELSE IF(IO.EQ.'NODX') THEN CALL OPENWB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN, 1,0) CALL READDX(LUNIT,LUN,LUNDX) ELSE IF(IO.EQ.'APN' .OR. IO.EQ.'APX') THEN CALL OPENAB(LUN,FILENAME) CALL WTSTAT(LUNIT,LUN, 1,0) IF(LUNIT.NE.LUNDX) CALL READDX(LUNIT,LUN,LUNDX) CALL POSAPX(LUNIT) ELSE GOTO 904 ENDIF GOTO 100 C FILE OPENED FOR INPUT IS EMPTY - LET READMG OR READERME GIVE C THE BAD NEWS LATER 200 REWIND LUNIT IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) . 'BUFRLIB: OPENBF - INPUT BUFR FILE IN UNIT ', LUNIT, . ' IS EMPTY' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL WTSTAT(LUNIT,LUN,-1,0) C INITIALIZE THE DICTIONARY TABLE PARTITION C ----------------------------------------- CALL DXINIT(LUN,0) C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3,'// . '" BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') . NFILES,LUNIT CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT"'// . ',I5," IS ALREADY OPEN")') LUNIT CALL BORT(BORT_STR) 904 CALL BORT('BUFRLIB: OPENBF - SECOND (INPUT) ARGUMENT MUST BE'// . ' "IN", "OUT", "NODX", "NUL", "APN", "APX", "SEC3"'// . ' OR "QUIET"') END ./openbt.f0000644001370400056700000000536213440555365011427 0ustar jator2emc SUBROUTINE OPENBT(LUNDX,MTYP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: OPENBT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1998-07-08 C C ABSTRACT: THIS IS A DUMMY SUBROUTINE WHICH ALWAYS RETURNS LUNDX = 0. C OPENBT MUST BE PRESENT BECAUSE IT IS CALLED BY BUFR ARCHIVE LIBRARY C SUBROUTINE CKTABA AS A LAST RESORT TO TRY AND FIND AN EXTERNAL C USER-SUPPLIED BUFR DICTIONARY TABLE FILE IN CHARACTER FORMAT FROM C WHICH A TABLE A MNEMONIC CAN BE LOCATED. IF THE APPLICATION C PROGRAM DOES NOT HAVE AN IN-LINE VERSION OF OPENBT (OVERRIDING THIS C ONE), THEN THE RETURNED LUNDX = 0 WILL RESULT IN CKTABA RETURNING C WITHOUT FINDING A TABLE A MNEMONIC BECAUSE THERE IS NO LINK TO ANY C EXTERNAL BUFR TABLES. NORMALLY, IT IS EXPECTED THAT AN IN-LINE C VERSION OF THIS SUBROUTINE WILL ACTUALLY FIND THE APPROPRIATE C EXTERNAL BUFR TABLE. C C PROGRAM HISTORY LOG: C 1998-07-08 J. WOOLLEN -- ORIGINAL AUTHOR 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); ADDED C MORE COMPLETE DIAGNOSTIC INFO WHEN UNUSUAL C THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL OPENBT (LUNDX, MTYP) C INPUT ARGUMENT LIST: C MTYP - INTEGER: DUMMY {IN AN APPLICATION PROGRAM (IN-LINE) C THIS WOULD BE THE BUFR MESSAGE TYPE} C C OUTPUT ARGUMENT LIST: C LUNDX - INTEGER: DUMMY, ALWAYS RETURNED AS ZERO {IN AN C APPLICATION PROGRAM (IN-LINE) THIS WOULD BE THE C FORTRAN LOGICAL UNIT NUMBER CONNECTED TO THE FILE C CONTAINING THE EXTERNAL BUFR TABLE} C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE (IN BUFR C ARCHIVE LIBRARY): Called by CKTABA only to allow the C BUFR ARCHIVE LIBRARY to compile, CKTABA C and any application programs should C always call a version of OPENBT in-line C in the application program. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /QUIET / IPRT CHARACTER*128 ERRSTR IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE'// . ' CALLED BY CKTABA OR APPL. PGM; OPENBT SHOULD BE INCL.'// . ' IN-LINE IN APPL. PGM' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF LUNDX = 0 RETURN END ./openmb.f0000644001370400056700000000776313440555365011427 0ustar jator2emc SUBROUTINE OPENMB(LUNIT,SUBSET,JDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: OPENMB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR C ARCHIVE LIBRARY SUBROUTINE OPENMG, HOWEVER UNLIKE OPENMG, IT WILL C NOT OPEN A NEW MESSAGE IF THERE IS ALREADY A BUFR MESSAGE OPEN C WITHIN MEMORY FOR THIS LUNIT WHICH HAS THE SAME SUBSET AND JDATE C VALUES (IN WHICH CASE IT DOES NOTHING AND RETURNS TO THE CALLING C ROUTINE/PROGRAM). OTHERWISE, IF THERE IS ALREADY A BUFR MESSAGE C OPEN WITHIN MEMORY FOR THIS LUNIT BUT WHICH HAS A DIFFERENT SUBSET C OR JDATE VALUE, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO C LUNIT BEFORE OPENING THE NEW ONE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL OPENMB (LUNIT, SUBSET, JDATE) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING OPENED C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C C REMARKS: C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI C NEMTBA STATUS USRTPL WTSTAT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' CHARACTER*(*) SUBSET LOGICAL OPEN C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 C GET SOME SUBSET PARTICULARS C --------------------------- c .... Given SUBSET, returns MTYP,MSTB,INOD CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) OPEN = IM.EQ.0.OR.INOD.NE.INODE(LUN).OR.I4DY(JDATE).NE.IDATE(LUN) C MAYBE(?) OPEN A NEW OR DIFFERENT TYPE OF MESSAGE C ------------------------------------------------ IF(OPEN) THEN CALL CLOSMG(LUNIT) CALL WTSTAT(LUNIT,LUN,IL, 1) c .... Set pos. index for new Tbl A mnem. INODE(LUN) = INOD c .... Set date for new message IDATE(LUN) = I4DY(JDATE) C INITIALIZE THE OPEN MESSAGE C --------------------------- CALL MSGINI(LUN) CALL USRTPL(LUN,1,1) ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') END ./openmg.f0000644001370400056700000000706013440555365011422 0ustar jator2emc SUBROUTINE OPENMG(LUNIT,SUBSET,JDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: OPENMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE OPENS AND INITIALIZES A NEW BUFR MESSAGE C WITHIN MEMORY. IT SHOULD ONLY BE CALLED WHEN LOGICAL UNIT LUNIT C HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT IS SIMILAR TO BUFR C ARCHIVE LIBRARY SUBROUTINE OPENMB, HOWEVER UNLIKE OPENMB, IT WILL C ALWAYS OPEN A NEW MESSAGE REGARDLESS OF THE VALUES OF SUBSET AND C JDATE. IF THERE IS ALREADY A BUFR MESSAGE OPEN WITHIN MEMORY FOR C THIS LUNIT, THEN THAT MESSAGE WILL BE CLOSED AND FLUSHED TO LUNIT C BEFORE OPENING THE NEW ONE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL OPENMG (LUNIT, SUBSET, JDATE) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C SUBSET - CHARACTER*(*): TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING OPENED C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING OPENED, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C C REMARKS: C THIS ROUTINE CALLS: BORT CLOSMG I4DY MSGINI C NEMTBA STATUS USRTPL WTSTAT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' CHARACTER*(*) SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.NE.0) CALL CLOSMG(LUNIT) CALL WTSTAT(LUNIT,LUN,IL, 1) C GET SOME SUBSET PARTICULARS C --------------------------- c .... Given SUBSET, returns MTYP,MSTB,INOD CALL NEMTBA(LUN,SUBSET,MTYP,MSTB,INOD) c .... Set pos. index for new Tbl A mnem. INODE(LUN) = INOD c .... Set date for new message IDATE(LUN) = I4DY(JDATE) C INITIALIZE THE OPEN MESSAGE C --------------------------- CALL MSGINI(LUN) CALL USRTPL(LUN,1,1) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') END ./pad.f0000644001370400056700000000717113440555365010704 0ustar jator2emc SUBROUTINE PAD(IBAY,IBIT,IBYT,IPADB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PAD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE FIRST PACKS THE VALUE FOR THE NUMBER OF C BITS BEING "PADDED" (WE'LL GET TO THAT LATER), STARTING WITH BIT C IBIT+1 AND USING EIGHT BITS IN THE PACKED ARRAY IBAY (WHICH C REPRESENTS A SUBSET PACKED INTO IBIT BITS). THEN, STARTING WITH C IBIT+9, IT PACKS ZEROES (I.E., "PADS") TO THE SPECIFIED BIT C BOUNDARY (IPADB). (NOTE: IT'S THE NUMBER OF BITS PADDED HERE THAT C WAS PACKED IN BITS IBIT+1 THROUGH IBIT+8 - THIS IS ACTUALLY A C DELAYED REPLICATION FACTOR). IPADB MUST BE A MULTIPLE OF EIGHT AND C REPRESENTS THE BIT BOUNDARY ON WHICH THE PACKED SUBSET IN IBAY C SHOULD END AFTER PADDING. FOR EXAMPLE, IF IPABD IS "8", THEN THE C NUMBER OF BITS IN IBAY ACTUALLY CONSUMED BY PACKED DATA (INCLUDING C THE PADDING) WILL BE A MULTIPLE OF EIGHT. IF IPADB IS "16", IT C WILL BE A MULTIPLE OF SIXTEEN. IN EITHER (OR ANY) CASE, THIS C ENSURES THAT THE PACKED SUBSET WILL ALWAYS END ON A FULL BYTE C BOUNDARY. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C USAGE: CALL PAD (IBAY, IBIT, IBYT, IPADB) C INPUT ARGUMENT LIST: C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET PADDED C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START PADDING FROM C IPADB - INTEGER: BIT BOUNDARY TO PAD TO (MUST BE A MULTIPLE OF C 8) C C OUTPUT ARGUMENT LIST: C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW PADDED C IBIT - INTEGER: NUMBER OF BITS WITHIN IBAY CONTAINING PACKED C DATA (INCLUDING PADDING, MUST BE A MULTIPLE OF 8) C IBYT - INTEGER: NUMBER OF BYTES WITHIN IBAY CONTAINING PACKED C DATA (INCLUDING PADDING) (I.E., IBIT/8) C C REMARKS: C THIS ROUTINE CALLS: BORT PKB C THIS ROUTINE IS CALLED BY: MSGUPD C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*128 BORT_STR DIMENSION IBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- C PAD THE SUBSET TO AN IPADB BIT BOUNDARY C ---------------------------------------- IPAD = IPADB - MOD(IBIT+8,IPADB) c .... First pack the # of bits being padded (this is a delayed c .... replication factor) CALL PKB(IPAD,8,IBAY,IBIT) c .... Now pad with zeroes to the byte boundary CALL PKB(0,IPAD,IBAY,IBIT) IBYT = IBIT/8 IF(MOD(IBIT,IPADB).NE.0) GOTO 900 IF(MOD(IBIT,8 ).NE.0) GOTO 901 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: PAD - THE INPUT BIT BOUNDARY TO PAD '// . 'TO (",I8,") IS NOT A MULTIPLE OF 8")') IPADB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: PAD - THE NUMBER OF BITS IN A PACKED'// . ' SUBSET AFTER PADDING (",I8,") IS NOT A MULTIPLE OF 8")') IBIT CALL BORT(BORT_STR) END ./padmsg.f0000644001370400056700000000363013440555365011407 0ustar jator2emc SUBROUTINE PADMSG(MESG,LMESG,NPBYT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PADMSG C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE PADS A BUFR MESSAGE WITH ZEROED-OUT BYTES C FROM THE END OF THE MESSAGE UP TO THE NEXT 8-BYTE BOUNDARY. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL PADMSG (MESG, LMESG, NPBYT ) C INPUT ARGUMENT LIST: C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE C LMESG - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MESG; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE MESG ARRAY C C OUTPUT ARGUMENT LIST: C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE WITH NPBYT ZEROED-OUT BYTES APPENDED TO THE END C NPBYT - INTEGER: NUMBER OF ZEROED-OUT BYTES APPENDED TO MESG C C REMARKS: C THIS ROUTINE CALLS: BORT IUPBS01 NMWRD PKB C THIS ROUTINE IS CALLED BY: MSGWRT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION MESG(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Make sure that the array is big enough to hold the additional C byte padding that will be appended to the end of the message. NMW = NMWRD(MESG) IF(NMW.GT.LMESG) GOTO 900 C Pad from the end of the message up to the next 8-byte boundary. NMB = IUPBS01(MESG,'LENM') IBIT = NMB*8 NPBYT = ( NMW * NBYTW ) - NMB DO I = 1, NPBYT CALL PKB(0,8,MESG,IBIT) ENDDO RETURN 900 CALL BORT('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE '// . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./parstr.f0000644001370400056700000000641613440555365011454 0ustar jator2emc SUBROUTINE PARSTR(STR,TAGS,MTAG,NTAG,SEP,LIMIT80) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PARSTR C PRGMMR: J. ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE C SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS. THE SEPARATOR FOR THE C SUBSTRINGS IS SPECIFIED DURING INPUT, AND MULTIPLE ADJACENT C OCCURRENCES OF THIS CHARACTER WILL BE TREATED AS A SINGLE C OCCURRENCE WHEN THE STRING IS ACTUALLY PARSED. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- BASED UPON SUBROUTINE PARSEQ C C USAGE: CALL PARSTR (STR, TAGS, MTAG, NTAG, SEP, LIMIT80) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING C MTAG - INTEGER: MAXIMUM NUMBER OF SUBSTRINGS TO BE PARSED C FROM STRING C SEP - CHARACTER*1: SEPARATOR CHARACTER FOR SUBSTRINGS C LIMIT80 - LOGICAL: .TRUE. IF AN ABORT SHOULD OCCUR WHEN STR IS C LONGER THAN 80 CHARACTERS; INCLUDED FOR HISTORICAL C CONSISTENCY WITH OLD SUBROUTINE PARSEQ C C OUTPUT ARGUMENT LIST: C TAGS - CHARACTER*(*): MTAG-WORD ARRAY OF SUBSTRINGS (FIRST C NTAG WORDS FILLED) C NTAG - INTEGER: NUMBER OF SUBSTRINGS RETURNED C C REMARKS: C THIS ROUTINE CALLS: BORT2 C THIS ROUTINE IS CALLED BY: FSTAG GETCFMNG GETNTBE GETTBH C PARUSR READLC SEQSDX SNTBBE C SNTBDE SNTBFE UFBSEQ UFBTAB C UFBTAM WRITLC C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR,TAGS(MTAG) CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*1 SEP LOGICAL SUBSTR,LIMIT80 C----------------------------------------------------------------------- C----------------------------------------------------------------------- LSTR = LEN(STR) LTAG = LEN(TAGS(1)) IF( LIMIT80 .AND. (LSTR.GT.80) ) GOTO 900 NTAG = 0 NCHR = 0 SUBSTR = .FALSE. DO I=1,LSTR IF( .NOT.SUBSTR .AND. (STR(I:I).NE.SEP) ) THEN NTAG = NTAG+1 IF(NTAG.GT.MTAG) GOTO 901 TAGS(NTAG) = ' ' ENDIF IF( SUBSTR .AND. (STR(I:I).EQ.SEP) ) NCHR = 0 SUBSTR = STR(I:I).NE.SEP IF(SUBSTR) THEN NCHR = NCHR+1 IF(NCHR.GT.LTAG) GOTO 902 TAGS(NTAG)(NCHR:NCHR) = STR(I:I) ENDIF ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") HAS ")') . STR WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') . LSTR CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") '// . 'CONTAINS",I4)') STR,NTAG WRITE(BORT_STR2,'(18X,"SUBSTRINGS, EXCEEDING THE LIMIT {",I4,'// . '" - THIRD (INPUT) ARGUMENT}")') MTAG CALL BORT2(BORT_STR1,BORT_STR2) 902 WRITE(BORT_STR1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") ")') STR WRITE(BORT_STR2,'(18X,"CONTAINS A PARSED SUBSTRING WITH LENGTH '// . 'EXCEEDING THE MAXIMUM OF",I4," CHARACTERS")') LTAG CALL BORT2(BORT_STR1,BORT_STR2) END ./parusr.f0000644001370400056700000001523413440555365011453 0ustar jator2emc SUBROUTINE PARUSR(STR,LUN,I1,IO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PARUSR C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE INITATES THE PROCESS TO PARSE OUT MNEMONICS C (NODES) FROM A USER-SPECIFIED CHARACTER STRING, AND SEPARATES THEM C INTO STORE AND CONDITION NODES. INFORMATION ABOUT THE STRING C "PIECES" (I.E., THE MNEMONICS) IS STORED IN ARRAYS IN COMMON BLOCK C /USRSTR/. CONDITION NODES ARE SORTED IN THE ORDER EXPECTED IN THE C INTERNAL JUMP/LINK TABLES AND SEVERAL CHECKS ARE PERFORMED ON THE C NODES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; IMPROVED MACHINE C PORTABILITY 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; CHANGED CALL FROM C BORT TO BORT2; RESPONDED TO CHANGE IN C PARUTG (WHICH THIS ROUTINE CALLS) TO NO C LONGER EXPECT AN ALTERNATE RETURN TO A C STATEMENT NUMBER IN THIS ROUTINE WHICH C CALLED BORT (BORT IS NOW CALLED IN PARUTG) C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-05-07 J. ATOR -- USE LSTJPB INSTEAD OF LSTRPC C C USAGE: CALL PARUSR (STR, LUN, I1, IO) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER C OF BLANK-SEPARATED MNEMONICS IN STR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C REMARKS: C THIS ROUTINE CALLS: BORT2 LSTJPB PARSTR PARUTG C THIS ROUTINE IS CALLED BY: STRING C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /ACMODE/ IAC CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*80 UST CHARACTER*20 UTG(30) LOGICAL BUMP DATA MAXUSR /30/ DATA MAXNOD /20/ DATA MAXCON /10/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- UST = STR IF(LEN(STR).GT.80) GOTO 900 NCON = 0 NNOD = 0 C PARSE OUT STRING PIECES(S) (UTG's or MNEMONICS) C ----------------------------------------------- CALL PARSTR(UST,UTG,MAXUSR,NTOT,' ',.TRUE.) DO N=1,NTOT C DETERMINE IF THIS UTG IS A CONDITION NODE OR A STORE NODE C --------------------------------------------------------- CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL) IF(KON.NE.0) THEN c .... it is a condition node NCON = NCON+1 IF(NCON.GT.MAXCON) GOTO 901 NODC(NCON) = NOD KONS(NCON) = KON IVLS(NCON) = NINT(VAL) ELSE c .... it is a store node NNOD = NNOD+1 IF(NNOD.GT.MAXNOD) GOTO 902 NODS(NNOD) = NOD ENDIF ENDDO C SORT CONDITION NODES IN JUMP/LINK TABLE ORDER C --------------------------------------------- DO I=1,NCON DO J=I+1,NCON IF(NODC(I).GT.NODC(J)) THEN NOD = NODC(I) NODC(I) = NODC(J) NODC(J) = NOD KON = KONS(I) KONS(I) = KONS(J) KONS(J) = KON VAL = IVLS(I) IVLS(I) = IVLS(J) IVLS(J) = VAL ENDIF ENDDO ENDDO C CHECK ON SPECIAL RULES FOR CONDITIONAL NODES THAT ARE BUMP NODES C ---------------------------------------------------------------- BUMP = .FALSE. DO N=1,NCON IF(KONS(N).EQ.5) THEN IF(IO.EQ.0) GOTO 903 IF(N.NE.NCON) GOTO 904 BUMP = .TRUE. ENDIF ENDDO C CHECK STORE NODE COUNT AND ALIGNMENT C ------------------------------------ IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905 IF(NNOD.GT.I1) GOTO 906 IRPC = -1 DO I=1,NNOD IF(NODS(I).GT.0) THEN IF(IRPC.LT.0) IRPC = LSTJPB(NODS(I),LUN,'RPC') IF(IRPC.NE.LSTJPB(NODS(I),LUN,'RPC').AND.IAC.EQ.0) GOTO 907 ENDIF ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') . STR WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') . LEN(STR) CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION '// . 'NODES IN INPUT STRING")') WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') . STR,MAXCON CALL BORT2(BORT_STR1,BORT_STR2) 902 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES '// . 'IN INPUT STRING")') WRITE(BORT_STR2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') . STR,MAXNOD CALL BORT2(BORT_STR1,BORT_STR2) 903 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT '// . 'STRING ",A)') STR WRITE(BORT_STR2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR '// . 'INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")') CALL BORT2(BORT_STR1,BORT_STR2) 904 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// . 'CONTAINS")') STR WRITE(BORT_STR2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP '// . 'NODE - THE BUMP MUST BE ON THE INNER NODE")') CALL BORT2(BORT_STR1,BORT_STR2) 905 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') . STR WRITE(BORT_STR2,'(18X,"NO STORE NODES")') CALL BORT2(BORT_STR1,BORT_STR2) 906 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') STR WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// . 'LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') NNOD,I1 CALL BORT2(BORT_STR1,BORT_STR2) 907 WRITE(BORT_STR1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") '// . 'CONTAINS")') STR WRITE(BORT_STR2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE'// . ' THAN ONE REPLICATION GROUP")') CALL BORT2(BORT_STR1,BORT_STR2) END ./parutg.f0000644001370400056700000002510413440555365011436 0ustar jator2emc SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PARUTG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC) C (UTG) THAT REPRESENTS A VALUE EITHER BEING DECODED FROM A BUFR FILE C (IF IT IS BEING READ) OR ENCODED INTO A BUFR FILE (IF IT IS BEING C WRITTEN). THIS SUBROUTINE FIRST CHECKS TO SEE IF THE TAG CONTAINS C A CONDITION CHARACTER ('=', '!', '<', '>', '^' OR '#'). IF IT DOES C NOT, NOTHING HAPPENS AT THIS POINT. IF IT DOES, THEN THE TYPE OF C CONDITION CHARACTER IS NOTED AND THE TAG IS STRIPPED OF ALL C CHARACTERS AT AND BEYOND THE CONDITION CHARACTER. IN EITHER EVENT, C THE RESULTANT TAG IS CHECKED AGAINST THOSE IN THE INTERNAL JUMP/ C LINK SUBSET TABLE (IN MODULE TABLES). IF FOUND, THE NODE C ASSOCIATED WITH THE TAG IS RETURNED (AND IT IS EITHER A "CONDITION" C NODE OR A "STORE" NODE DEPENDING OF THE PRESENCE OR ABSENCE OF A C CONDITION CHARACTER IN UTG). OTHERWISE THE NODE IS RETURNED AS C ZERO. IF THE TAG REPRESENTS A CONDITION NODE, THEN THE CONDITION C VALUE (NUMERIC CHARACTERS BEYOND THE CONDITION CHARACTER IN THE C USER-SPECIFIED TAG INPUT HERE) IS RETURNED. C C AS AN EXAMPLE OF CONDITION CHARACTER USAGE, CONSIDER THE FOLLOWING C EXAMPLE OF A CALL TO UFBINT: C C REAL*8 USR(4,50) C .... C .... C CALL UFBINT(LUNIN,USR,4,50,IRET,'PRLC<50000 TMDB WDIR WSPD') C C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), C THEN THE USR ARRAY NOW CONTAINS IRET LEVELS OF DATA (UP TO A MAXIMUM C OF 50!) WHERE THE VALUE OF PRLC IS/WAS LESS THAN 50000, ALONG WITH C THE CORRESPONDING VALUES FOR TMDB, WDIR AND WSPD AT THOSE LEVELS. C C AS ANOTHER EXAMPLE, CONSIDER THE FOLLOWING EXAMPLE OF A CALL TO C READLC FOR A LONG CHARACTER STRING: C C CHARACTER*200 LCHR C .... C .... C CALL READLC(LUNIN,LCHR,'NUMID#3') C C ASSUMING THAT LUNIN POINTS TO A BUFR FILE OPEN FOR INPUT (READING), C THEN THE LCHR STRING NOW CONTAINS THE VALUE CORRESPONDING TO THE C THIRD OCCURRENCE OF NUMID WITHIN THE CURRENT SUBSET. C C VALID CONDITION CODES INCLUDE: C '<' - LESS THAN C '>' - GREATER THAN C '=' - EQUAL TO C '!' - NOT EQUAL TO C '#' - ORDINAL IDENTIFIER FOR A PARTICULAR OCCURRENCE OF A LONG C CHARACTER STRING C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY; C CHANGED CALL FROM BORT TO BORT2 IN SOME C CASES; REPLACED PREVIOUS "RETURN 1" C STATEMENT WITH "GOTO 900" (AND CALL TO C BORT) SINCE THE ONLY ROUTINE THAT CALLS C THIS ROUTINE, PARUSR, USED THIS ALTERNATE C RETURN TO GO TO A STATEMENT WHICH CALLED C BORT C 2005-04-22 J. ATOR -- HANDLED SITUATION WHERE INPUT TAG CONTAINS C 1-BIT DELAYED REPLICATION, AND IMPROVED C DOCUMENTATION C 2009-03-23 J. ATOR -- ADDED '#' CONDITION CODE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL PARUTG (LUN, IO, UTG, NOD, KON, VAL) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C UTG CHARACTER*(*): USER-SUPPLIED TAG REPRESENTING A VALUE TO C BE ENCODED/DECODED TO/FROM BUFR FILE C C OUTPUT ARGUMENT LIST: C NOD - INTEGER: POSITIONAL INDEX IN INTERNAL JUMP/LINK SUBSET C TABLE FOR TAG C 0 = tag not found in table C KON - INTEGER: INDICATOR FOR TYPE OF CONDITION CHARACTER C FOUND IN UTG: C 0 = no condition character found (NOD is a store C node) C 1 = character '=' found C 2 = character '!' found C 3 = character '<' found C 4 = character '>' found C 5 = character '^' found C 6 = character '#' found C (1-6 means NOD is a condition node, and C specifically 5 is a "bump" node) C VAL - REAL: CONDITION VALUE ASSOCIATED WITH CONDITION C CHARACTER FOUND IN UTG C 0 = UTG does not have a condition character C C REMARKS: C THIS ROUTINE CALLS: BORT BORT2 STRNUM C THIS ROUTINE IS CALLED BY: PARUSR READLC WRITLC C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /UTGPRM/ PICKY CHARACTER*(*) UTG CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*20 ATAG CHARACTER*3 ATYP,BTYP CHARACTER*1 COND(6) DIMENSION BTYP(8),IOK(8) LOGICAL PICKY DATA NCHK / 8/ DATA BTYP /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/ DATA IOK / -1 , -1 , -1 , -1 , -1 , 0 , 0 , 0 / C---------------------------------------------------------------------- C For now, set PICKY (see below) to always be .FALSE. PICKY = .FALSE. COND(1) = '=' COND(2) = '!' COND(3) = '<' COND(4) = '>' COND(5) = '^' COND(6) = '#' NCOND = 6 C---------------------------------------------------------------------- ATAG = ' ' ATYP = ' ' KON = 0 NOD = 0 VAL = 0 LTG = MIN(20,LEN(UTG)) C PARSE UTG, SAVING INTO ATAG ONLY CHARACTERS PRIOR TO CONDITION CHAR. C -------------------------------------------------------------------- C But first, take care of the special case where UTG denotes the C short (i.e. 1-bit) delayed replication of a Table D mnemonic. C This will prevent confusion later on since '<' and '>' are each C also valid as condition characters. IF((UTG(1:1).EQ.'<').AND.(INDEX(UTG(3:),'>').NE.0)) THEN ATAG = UTG GO TO 1 ENDIF DO I=1,LTG IF(UTG(I:I).EQ.' ') GOTO 1 DO J=1,NCOND IF(UTG(I:I).EQ.COND(J)) THEN KON = J ICV = I+1 GOTO 1 ENDIF ENDDO ATAG(I:I) = UTG(I:I) ENDDO C FIND THE NODE ASSOCIATED WITH ATAG IN THE SUBSET TABLE C ------------------------------------------------------ 1 INOD = INODE(LUN) DO NOD=INOD,ISC(INOD) IF(ATAG.EQ.TAG(NOD)) GOTO 2 ENDDO C ATAG NOT FOUND IN SUBSET TABLE C ------------------------------ C So what do we want to do? We could be "picky" and abort right C here, or we could allow for the possibility that, e.g. a user C application has been streamlined to always call UFBINT with the C same STR, even though some of the mnemonics contained within that C STR may not exist within the sequence definition of every C possible type/subtype that is being written by the application. C In such cases, by not being "picky", we could just allow BUFRLIB C to subsequently (and quietly, if IPRT happened to be set to -1 C in COMMON /QUIET/!) not actually store the value corresponding C to such mnemonics, rather than loudly complaining and aborting. IF(KON.EQ.0 .AND. (IO.EQ.0.OR.ATAG.EQ.'NUL'.OR..NOT.PICKY)) THEN C i.e. (if this tag does not contain any condition characters) C .AND. C ((either the file is open for input) .OR. C (the tag consists of 'NUL') .OR. C (we aren't being "picky")) NOD = 0 GOTO 100 ELSE C abort... GOTO 900 ENDIF C ATAG IS FOUND IN SUBSET TABLE, MAKE SURE IT HAS A VALID NODE TYPE C ----------------------------------------------------------------- 2 IF(KON.EQ.5) THEN c .... Cond. char "^" must be assoc. with a delayed replication c sequence (this is a "bump" node) (Note: This is obsolete but c remains for "old" programs using the BUFR ARCHIVE LIBRARY) IF(TYP(NOD-1).NE.'DRP' .AND. TYP(NOD-1).NE.'DRS') GOTO 901 ELSEIF(KON.NE.6) THEN C Allow reading (but not writing) of delayed replication factors. ATYP = TYP(NOD) DO I=1,NCHK IF(ATYP.EQ.BTYP(I) .AND. IO.GT.IOK(I)) GOTO 902 ENDDO ENDIF C IF CONDITION NODE, GET CONDITION VALUE WHICH IS A NUMBER FOLLOWING IT C --------------------------------------------------------------------- IF(KON.NE.0) THEN CALL STRNUM(UTG(ICV:LTG),NUM) IF(NUM.LT.0) GOTO 903 VAL = NUM ENDIF C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'// . ' (",A,") WHICH DOES NOT EXIST IN SUBSET TABLE")') ATAG WRITE(BORT_STR2,'(18X,"(UPON INPUT, IT CONTAINED THE CONDITION '// . 'CHARACTER ",A,")")') UTG(ICV-1:ICV-1) CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'// . ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS "'// . ',A)') ATAG,TYP(NOD-1) CALL BORT(BORT_STR1) 902 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," '// . 'FOR MNEMONIC ",A)') ATYP,ATAG CALL BORT(BORT_STR1) 903 WRITE(BORT_STR1,'("BUFRLIB: PARUTG - CONDITION VALUE IN '// . 'MNEMONIC ",A," ILLEGAL BECAUSE ALL OTHER CHARACTERS IN '// . 'MNEMONIC MUST BE NUMERIC")') UTG CALL BORT(BORT_STR1) END ./pkb.f0000644001370400056700000000733213440555365010713 0ustar jator2emc SUBROUTINE PKB(NVAL,NBITS,IBAY,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER VALUE (NVAL) INTO NBITS C BITS OF AN INTEGER ARRAY (IBAY), STARTING WITH BIT (IBIT+1). ON C OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS PACKED. C C NOTE THAT THIS SUBROUTINE WILL NOT WORK PROPERLY IF NBITS IS C GREATER THAN NBITW (I.E. THE NUMBER OF BITS IN A MACHINE WORD); C IN SUCH CASES SUBROUTINE PKX SHOULD BE CALLED INSTEAD TO ENSURE C THAT ALL BITS PRIOR TO THE LAST MACHINE WORD ARE PROPERLY C ZERO'ED OUT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) 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 C 2014-12-03 J. ATOR -- CALL BORT IF NBITS > NBITW C C USAGE: CALL PKB (NVAL, NBITS, IBAY, IBIT) C INPUT ARGUMENT LIST: C NVAL - INTEGER: INTEGER TO BE PACKED C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO PACK C NVAL C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET CONTAINING C PACKED NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER C WHICH TO START PACKING C C OUTPUT ARGUMENT LIST: C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING C PACKED NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT C THAT WAS PACKED C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C UPB. C C THIS ROUTINE CALLS: BORT IREV C THIS ROUTINE IS CALLED BY: ATRCPT CMSGINI CNVED4 CPYUPD C DXMINI MSGINI MSGUPD MSGWRT C MVB PAD PADMSG PKBS1 C PKX STNDRD WRCMPS WRDXTB C WRTREE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION IBAY(*) CHARACTER*156 BORT_STR C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NBITS.GT.NBITW) GOTO 900 NWD = IBIT/NBITW + 1 NBT = MOD(IBIT,NBITW) IVAL = NVAL IF(ISHFT(IVAL,-NBITS).GT.0) IVAL = -1 INT = ISHFT(IVAL,NBITW-NBITS) INT = ISHFT(INT,-NBT) MSK = ISHFT( -1,NBITW-NBITS) MSK = ISHFT(MSK,-NBT) IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) IF(NBT+NBITS.GT.NBITW) THEN C There are less than NBITS bits remaining within the current C word (i.e. array member) of IBAY, so store as many bits as C will fit within the current word and then store the remaining C bits within the next word. INT = ISHFT(IVAL,2*NBITW-(NBT+NBITS)) MSK = ISHFT( -1,2*NBITW-(NBT+NBITS)) IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) ENDIF IBIT = IBIT + NBITS RETURN 900 WRITE(BORT_STR,'("BUFRLIB: PKB - NUMBER OF BITS BEING PACKED '// . ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS '// . 'MACHINE, NBITW (",I3,"); USE SUBROUTINE PKX INSTEAD")') . NBITS,NBITW CALL BORT(BORT_STR) END ./pkbs1.f0000644001370400056700000001121613440555365011153 0ustar jator2emc SUBROUTINE PKBS1(IVAL,MBAY,S1MNEM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKBS1 C PRGMMR: J. ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE STORES A SPECIFIED INTEGER VALUE INTO A C SPECIFIED LOCATION WITHIN SECTION 1 OF THE BUFR MESSAGE STORED IN C ARRAY MBAY, OVERWRITING THE VALUE PREVIOUSLY STORED AT THAT C LOCATION. IT WILL WORK ON ANY MESSAGE ENCODED USING BUFR EDITION C 2, 3 OR 4. THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") C MUST BE ALIGNED ON THE FIRST FOUR BYTES OF MBAY, AND THE LOCATION C WITHIN WHICH TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC C S1MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2006-04-14 D. KEYSER -- ADDED OPTIONS FOR 'MTYP', 'MSBT', 'YEAR', C 'MNTH', 'DAYS', 'HOUR', 'YCEN' AND 'CENT' C C USAGE: PKBS1 (IVAL, MBAY, S1MNEM) C INPUT ARGUMENT LIST: C IVAL - INTEGER: VALUE TO BE STORED C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE PRIOR TO STORING IVAL C S1MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL C IS TO BE STORED WITHIN SECTION 1 OF BUFR MESSAGE: C 'BMT' = BUFR MASTER TABLE C 'OGCE' = ORIGINATING CENTER C 'GSES' = ORIGINATING SUBCENTER C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 3 OR 4 MESSAGES!) C 'USN' = UPDATE SEQUENCE NUMBER C 'MTYP' = DATA CATEGORY C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MSBT' = DATA SUBCATEGORY (LOCAL) C 'MTV' = VERSION NUMBER OF MASTER TABLE C 'MTVL' = VERSION NUMBER OF LOCAL TABLES C 'YCEN' = YEAR OF CENTURY (1-100) C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, C 21 FOR YEARS 2001-2100) C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'YEAR' = YEAR (4-DIGIT) C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MNTH' = MONTH C 'DAYS' = DAY C 'HOUR' = HOUR C 'MINU' = MINUTE C 'SECO' = SECOND C (NOTE: THIS VALUE IS STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C C OUTPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE WITH IVAL NOW STORED AS REQUESTED C C REMARKS: C THIS ROUTINE CALLS: BORT GETS1LOC IUPBS01 PKB C THIS ROUTINE IS CALLED BY: MINIMG MSGWRT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) CHARACTER*(*) S1MNEM CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Note that the following call to function IUPBS01 will ensure C that subroutine WRDLEN has been called. IBEN = IUPBS01(MBAY,'BEN') C Determine where to store the value. CALL GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) IF ( (IRET.EQ.0) .AND. . ( (S1MNEM.EQ.'USN') .OR. (S1MNEM.EQ.'BMT') .OR. . (S1MNEM.EQ.'OGCE') .OR. (S1MNEM.EQ.'GSES') .OR. . (S1MNEM.EQ.'MTYP') .OR. (S1MNEM.EQ.'MSBTI') .OR. . (S1MNEM.EQ.'MSBT') .OR. (S1MNEM.EQ.'MTV') .OR. . (S1MNEM.EQ.'MTVL') .OR. (S1MNEM.EQ.'YCEN') .OR. . (S1MNEM.EQ.'CENT') .OR. (S1MNEM.EQ.'YEAR') .OR. . (S1MNEM.EQ.'MNTH') .OR. (S1MNEM.EQ.'DAYS') .OR. . (S1MNEM.EQ.'HOUR') .OR. (S1MNEM.EQ.'MINU') .OR. . (S1MNEM.EQ.'SECO') ) ) THEN C Store the value. IBIT = (IUPBS01(MBAY,'LEN0')+ISBYT-1)*8 CALL PKB(IVAL,IWID,MBAY,IBIT) ELSE GOTO 900 ENDIF RETURN 900 WRITE(BORT_STR,'("BUFRLIB: PKBS1 - CANNOT OVERWRITE LOCATION '// . 'CORRESPONDING TO MNEMONIC (",A,") WITHIN BUFR EDITION '// . '(",I1,")")') S1MNEM, IBEN CALL BORT(BORT_STR) END ./pkc.f0000644001370400056700000001006113440555365010705 0ustar jator2emc SUBROUTINE PKC(CHR,NCHR,IBAY,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKC C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER STRING (CHR) CONTAINING C NCHR CHARACTERS INTO NCHR BYTES OF AN INTEGER ARRAY (IBAY), C STARTING WITH BIT (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO C THE LAST BIT THAT WAS PACKED. NOTE THAT THERE IS NO GUARANTEE THAT C THE NCHR CHARACTERS WILL BE ALIGNED ON BYTE BOUNDARIES WHEN PACKED C WITHIN IBAY. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) 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 2004-08-18 J. ATOR -- MODIFIED TO BE COMPATIBLE WITH WRITLC C C USAGE: CALL PKC (CHR, NCHR, IBAY, IBIT) C INPUT ARGUMENT LIST: C CHR - CHARACTER*(*): CHARACTER STRING TO BE PACKED C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO PACK C CHR (I.E., THE NUMBER OF CHARACTERS IN CHR) C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER C WHICH TO START PACKING C C OUTPUT ARGUMENT LIST: C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING C PACKED CHR C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT C THAT WAS PACKED C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C UPC. C C THIS ROUTINE CALLS: IPKM IREV IUPM C THIS ROUTINE IS CALLED BY: CMSGINI DXMINI MSGINI MSGWRT C STNDRD WRCMPS WRDXTB WRITLC C WRTREE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*(*) CHR CHARACTER*1 CVAL(8) DIMENSION IBAY(*),IVAL(2) EQUIVALENCE (CVAL,IVAL) C---------------------------------------------------------------------- C---------------------------------------------------------------------- LB = IORD(NBYTW) C LB now points to the "low-order" (i.e. least significant) byte C within a machine word. IVAL(1) = 0 NBIT = 8 DO I=1,NCHR IF(I.LE.LEN(CHR)) THEN CVAL(LB) = CHR(I:I) ELSE CVAL(LB) = ' ' ENDIF C If the machine is EBCDIC, then translate character CVAL(LB) from C EBCDIC to ASCII. IF(IASCII.EQ.0) CALL IPKM(CVAL(LB),1,IETOA(IUPM(CVAL(LB),8))) NWD = IBIT/NBITW + 1 NBT = MOD(IBIT,NBITW) INT = ISHFT(IVAL(1),NBITW-NBIT) INT = ISHFT(INT,-NBT) MSK = ISHFT( -1,NBITW-NBIT) MSK = ISHFT(MSK,-NBT) IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT)) IF(NBT+NBIT.GT.NBITW) THEN C This character will not fit within the current word (i.e. C array member) of IBAY, because there are less than 8 bits of C space left. Store as many bits as will fit within the current C word and then store the remaining bits within the next word. INT = ISHFT(IVAL(1),2*NBITW-(NBT+NBIT)) MSK = ISHFT( -1,2*NBITW-(NBT+NBIT)) IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT)) ENDIF IBIT = IBIT + NBIT ENDDO C EXITS C ----- RETURN END ./pkftbv.f0000644001370400056700000000275213440555365011434 0ustar jator2emc REAL*8 FUNCTION PKFTBV(NBITS,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKFTBV C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION COMPUTES AND RETURNS THE VALUE EQUIVALENT C TO THE SETTING OF BIT# IBIT WITHIN A FLAG TABLE OF NBITS BITS. C IF THE COMPUTATION FAILS FOR ANY REASON, THEN THE VALUE BMISS C (10E10) IS RETURNED. NOTE THAT THIS SUBROUTINE IS THE LOGICAL C INVERSE OF BUFRLIB SUBROUTINE UPFTBV. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL VERSION C C USAGE: PKFTBV (NBITS,IBIT) C INPUT ARGUMENT LIST: C NBITS - INTEGER: NUMBER OF BITS IN FLAG TABLE C IBIT - INTEGER: NUMBER OF BIT TO BE SET WITHIN FLAG TABLE C C OUTPUT ARGUMENT LIST: C PKFTBV - REAL*8: VALUE EQUIVALENT TO THE SETTING OF BIT# IBIT C WITHIN A FLAG TABLE OF NBITS BITS. C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF((NBITS.LE.0).OR.(IBIT.LE.0).OR.(IBIT.GT.NBITS)) THEN PKFTBV = BMISS ELSE PKFTBV = (2.)**(NBITS-IBIT) ENDIF RETURN END ./pktdd.f0000644001370400056700000001174413440555365011247 0ustar jator2emc SUBROUTINE PKTDD(ID,LUN,IDN,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKTDD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD" C MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (IN MODULE C TABABD) FOR A TABLE D SEQUENCE ("PARENT") MNEMONIC WHEN THE C "CHILD" MNEMONIC IS CONTAINED WITHIN THE SEQUENCE REPRESENTED BY C THE "PARENT" MNEMONIC (AS DETERMINED WITHIN BUFR ARCHIVE LIBRARY C SUBROUTINE SEQSDX). 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 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; ADDED MORE COMPLETE C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL PKTDD (ID, LUN, IDN, IRET) C INPUT ARGUMENT LIST: C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN C INTERNAL BUFR TABLE D ARRAY TABD(*,*) C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE C CORRESPONDING TO CHILD MNEMONIC C 0 = delete all information about all child C mnemonics from within TABD(ID,LUN) C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS STORED THUS C FAR (INCLUDING IDN) FOR THE PARENT MNEMONIC GIVEN BY C TABD(ID,LUN) C 0 = information was cleared from TABD(ID,LUN) C because input IDN value was 0 C -1 = bad counter value or maximum number of C child mnemonics already stored for this C parent mnemonic C C REMARKS: C THIS ROUTINE CALLS: ERRWRT IPKM IUPM C THIS ROUTINE IS CALLED BY: DXINIT SEQSDX STBFDX STSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MAXCD USE MODA_TABABD INCLUDE 'bufrlib.prm' COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) COMMON /QUIET / IPRT CHARACTER*128 ERRSTR CHARACTER*56 DXSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- LDD = LDXD(IDXV+1)+1 C LDD points to the byte within TABD(ID,LUN) which contains (in C packed integer format) a count of the number of child mnemonics C stored thus far for this parent mnemonic. C ZERO THE COUNTER IF IDN IS ZERO C ------------------------------- IF(IDN.EQ.0) THEN CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,0) IRET = 0 GOTO 100 ENDIF C UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY C --------------------------------------------------------- ND = IUPM(TABD(ID,LUN)(LDD:LDD),8) C ND is the (unpacked) count of the number of child mnemonics C stored thus far for this parent mnemonic. IF(ND.LT.0 .OR. ND.EQ.MAXCD) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') IF(ND.LT.0) THEN WRITE ( UNIT=ERRSTR, FMT='(A,I4,A)' ) . 'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', ND, . ') - RETURN WITH IRET = -1' ELSE WRITE ( UNIT=ERRSTR, FMT='(A,I4,A,A)' ) . 'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=', . MAXCD, ') ALREADY STORED FOR THIS PARENT - RETURN WITH ', . 'IRET = -1' ENDIF CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IRET = -1 GOTO 100 ELSE ND = ND+1 CALL IPKM(TABD(ID,LUN)(LDD:LDD),1,ND) IRET = ND ENDIF C PACK AND STORE THE DESCRIPTOR C ----------------------------- IDM = LDD+1 + (ND-1)*2 C IDM points to the starting byte within TABD(ID,LUN) at which C the IDN value for this child mnemonic will be stored (as a C packed integer of width = 2 bytes). CALL IPKM(TABD(ID,LUN)(IDM:IDM),2,IDN) C EXIT C ---- 100 RETURN END ./pkvs01.F0000644001370400056700000001260313440555365011220 0ustar jator2emc SUBROUTINE PKVS01(S01MNEM,IVAL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKVS01 C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY A VALUE TO BE WRITTEN C INTO A SPECIFIED LOCATION WITHIN SECTION 0 OR SECTION 1 OF ALL BUFR C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, C WRITSB, COPYMG, WRITSA, ETC.). IT WILL WORK ON ANY MESSAGE ENCODED C USING BUFR EDITION 2, 3 OR 4, AND IT CAN BE CALLED AT ANY TIME, C INCLUDING BEFORE THE FIRST CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C OPENBF IF IT IS DESIRED FOR THE NEW VALUE TO ALSO BE INCLUDED IN ANY C DX DICTIONARY TABLE MESSAGES THAT WILL BE OUTPUT BY BUFR ARCHIVE C LIBRARY SUBROUTINE WRITDX. IN ANY CASE, THE LOCATION WITHIN WHICH C TO STORE THE VALUE IS SPECIFIED VIA THE MNEMONIC S01MNEM, AS C EXPLAINED IN FURTHER DETAIL BELOW. IF MULTIPLE VALUES ARE DESIRED C TO BE CHANGED WITHIN SECTION 0 OR SECTION 1 OF FUTURE OUTPUT C MESSAGES, THEN EACH SUCH VALUE (AND CORRESPONDING LOCATION) C SHOULD BE SPECIFIED USING A SEPARATE CALL TO THIS SUBROUTINE. C NOTE THAT EACH CALL TO THIS SUBROUTINE WITH A PARTICULAR LOCATION C SPECIFICATION WILL OVERRIDE THE EFFECT OF ANY PREVIOUS CALL WITH C THAT SAME SPECIFICATION (OR, IN THE CASE OF THE FIRST CALL WITH A C PARTICULAR LOCATION SPECIFICATION, IT WILL OVERRIDE THE DEFAULT C SECTION 0 OR SECTION 1 VALUE FOR THE CORRESPONDING LOCATION!). C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2006-04-14 D. KEYSER -- UPDATED DOCBLOCK C 2015-03-03 J. ATOR -- USE MODULE MODA_S01CM C C USAGE: CALL PKVS01(S01MNEM,IVAL) C INPUT ARGUMENT LIST: C S01MNEM - CHARACTER*(*): MNEMONIC SPECIFYING LOCATION WHERE IVAL C IS TO BE STORED WITHIN SECTION 0 OR SECTION 1 OF ALL C FUTURE OUTPUT BUFR MESSAGES: C 'BEN' = BUFR EDITION NUMBER C 'BMT' = BUFR MASTER TABLE C 'OGCE' = ORIGINATING CENTER C 'GSES' = ORIGINATING SUBCENTER C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 3 OR 4 MESSAGES!) C 'USN' = UPDATE SEQUENCE NUMBER C 'MTYP' = DATA CATEGORY C 'MSBTI' = DATA SUBCATEGORY (INTERNATIONAL) C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MSBT' = DATA SUBCATEGORY (LOCAL) C 'MTV' = VERSION NUMBER OF MASTER TABLE C 'MTVL' = VERSION NUMBER OF LOCAL TABLES C 'YCEN' = YEAR OF CENTURY (1-100) C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'CENT' = CENTURY (I.E., 20 FOR YEARS 1901-2000, C 21 FOR YEARS 2001-2100) C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 2 AND 3 MESSAGES!) C 'YEAR' = YEAR (4-DIGIT) C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C 'MNTH' = MONTH C 'DAYS' = DAY C 'HOUR' = HOUR C 'MINU' = MINUTE C 'SECO' = SECOND C (NOTE: THIS VALUE WILL BE STORED ONLY IN C BUFR EDITION 4 MESSAGES!) C IVAL - INTEGER: NEW VALUE FOR LOCATION POINTED TO BY S01MNEM C C REMARKS: C THIS ROUTINE CALLS: BORT OPENBF C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_S01CM INCLUDE 'bufrlib.prm' CHARACTER*(*) S01MNEM CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- #ifdef DYNAMIC_ALLOCATION C CONFIRM THAT THE ARRAYS NEEDED BY THIS SUBROUTINE HAVE ALREADY C BEEN ALLOCATED (AND IF NOT, GO AHEAD AND ALLOCATE THEM NOW), SINCE C IT'S POSSIBLE FOR THIS SUBROUTINE TO BE CALLED BEFORE THE FIRST C CALL TO SUBROUTINE OPENBF. IF ( ( .NOT. ALLOCATED(CMNEM) ) .OR. . ( .NOT. ALLOCATED(IVMNEM) ) ) THEN CALL OPENBF(0,'FIRST',0) ENDIF #endif C IF AN IVAL HAS ALREADY BEEN ASSIGNED FOR THIS PARTICULAR S01MNEM, C THEN OVERWRITE THAT ENTRY IN COMMON /S01CM/ USING THE NEW IVAL. IF(NS01V.GT.0) THEN DO I=1,NS01V IF(S01MNEM.EQ.CMNEM(I)) THEN IVMNEM(I) = IVAL RETURN ENDIF ENDDO ENDIF C OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN COMMON /S01CM/. IF(NS01V.GE.MXS01V) GOTO 900 NS01V = NS01V + 1 CMNEM(NS01V) = S01MNEM IVMNEM(NS01V) = IVAL C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: PKVS01 - CANNOT OVERWRITE MORE THAN '// . '",I2," DIFFERENT LOCATIONS WITHIN SECTION 0 OR SECTION 1")') . MXS01V CALL BORT(BORT_STR) END ./pkx.f0000644001370400056700000000453413440555365010742 0ustar jator2emc SUBROUTINE PKX(NVAL,NBITS,IBAY,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: PKX C PRGMMR: WOOLLEN ORG: NP20 DATE: 2014-11-21 C C ABSTRACT: THIS SUBROUTINE WORKS JUST LIKE SUBROUTINE PKB, IN THAT IT C PACKS AN INTEGER VALUE (NVAL) INTO NBITS BITS OF AN INTEGER ARRAY C (IBAY) STARTING WITH BIT (IBIT+1) AND THEN UPDATES IBIT TO POINT TO C THE LAST BIT THAT WAS PACKED. THE DIFFERENCE IS THAT THIS SUBROUTINE C WILL WORK FOR CASES WHERE NBITS IS GREATER THAN NBITW (I.E. THE C NUMBER OF BITS IN A MACHINE WORD) BY ZERO'ING OUT ALL OF THE BITS C IN NBITS UP TO THE LAST MACHINE WORD, BEFORE THEN STORING NVAL C WITHIN THE LAST MACHINE WORD. C C PROGRAM HISTORY LOG: C 2014-11-21 J. WOOLLEN -- ORIGINAL AUTHOR, JEFF ATOR'S IDEA C C USAGE: CALL PKX (NVAL, NBITS, IBAY, IBIT) C INPUT ARGUMENT LIST: C NVAL - INTEGER: INTEGER TO BE PACKED C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO PACK C NVAL C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET CONTAINING C PACKED NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER C WHICH TO START PACKING C C OUTPUT ARGUMENT LIST: C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING C PACKED NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT C THAT WAS PACKED C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C UPB. C C THIS ROUTINE CALLS: PKB C THIS ROUTINE IS CALLED BY: WRCMPS C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION IBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- C IF NBITS IS > NBITW THEN ZERO BITS UP TO NBITS-NBITW NWRD=NBITS/NBITW IF(NWRD>0) THEN JBIT=IBIT DO N=1,NWRD CALL PKB(0,NBITW,IBAY,JBIT) ENDDO IBIT=IBIT+NBITS-NBITW ENDIF C STORE NVAL IN THE LAST WORD OF THE BIT STRING CALL PKB(NVAL,MIN(NBITW,NBITS),IBAY,IBIT) RETURN END ./posapx.f0000644001370400056700000000672313440555365011454 0ustar jator2emc SUBROUTINE POSAPX(LUNXX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: POSAPX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS TO THE END OF THE FILE POINTED TO BY C ABS(LUNXX) AND POSITIONS IT FOR APPENDING. THE FILE MUST HAVE C ALREADY BEEN OPENED FOR OUTPUT OPERATIONS. IF LUNXX > 0, THE FILE C IS BACKSPACED BEFORE BEING POSITIONED FOR APPEND. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE C (DICTIONARY) MESSAGES; ADDED LUNXX < 0 C OPTION TO SIMULATE POSAPN C 2010-05-11 J. ATOR -- SET ISCODES TO -1 IF UNSUCCESSFUL C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR C REMOVE UNECESSARY ERROR CHECKING LOGIC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL POSAPX (LUNXX) C INPUT ARGUMENT LIST: C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE (IF LUNXX < 0, THEN THE FILE IS NOT C BACKSPACED BEFORE POSITIONING FOR APPEND) C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IDXMSG RDBFDX RDMSGW C STATUS BACKBUFR C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- LUNIT = ABS(LUNXX) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 901 IF(IL.LT.0) GOTO 902 C TRY TO READ TO THE END OF THE FILE C ---------------------------------- 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.LT.0) RETURN IF(IDXMSG(MGWA).EQ.1) THEN C This is an internal dictionary message that was generated by the C BUFR archive library software. Backspace the file pointer and C then read and store all such dictionary messages (they should be C stored consecutively!) and reset the internal tables. CALL BACKBUFR(LUN) !BACKSPACE LUNIT CALL RDBFDX(LUNIT,LUN) ENDIF GOTO 1 C ERROR EXITS C ----------- 901 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT'// . ', IT MUST BE OPEN FOR OUTPUT') END ./rbytes.c0000644001370400056700000000364213440555365011444 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RBYTES C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS FUNCTION READS A SPECIFIED NUMBER OF BYTES FROM C THE SYSTEM FILE MOST RECENTLY OPENED FOR READING/INPUT VIA C BUFR ARCHIVE LIBRARY ROUTINE COBFL. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C C USAGE: RBYTES( BMG, MXMB, ISLOC, NEWBYTES ) C INPUT ARGUMENT LIST: C MXMB - INTEGER: DIMENSIONED SIZE (IN BYTES) OF BMG; USED C BY THE FUNCTION TO ENSURE THAT IT DOES NOT OVERFLOW C THE BMG ARRAY C ISLOC - INTEGER: STARTING BYTE NUMBER WITHIN BMG INTO C WHICH TO READ THE NEXT NEWBYTES BYTES C NEWBYTES - INTEGER: NUMBER OF BYTES TO READ FROM THE SYSTEM C FILE MOST RECENTLY OPENED FOR READING/INPUT VIA C BUFR ARCHIVE LIBRARY ROUTINE COBFL C C OUTPUT ARGUMENT LIST: C BMG - CHARACTER*1: ARRAY CONTAINING THE NEWBYTES BYTES C THAT WERE READ, BEGINNING AT BYTE NUMBER ISLOC C RBYTES - INTEGER: RETURN CODE: C 0 = normal return C 1 = overflow of BMG array C -1 = end-of-file encountered while reading C -2 = I/O error encountered while reading C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: CRBMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cobfl.h" f77int rbytes( char *bmg, f77int *mxmb, f77int isloc, f77int newbytes ) { short iret; if ( ( isloc + newbytes ) > *mxmb ) { iret = 1; } else if ( fread( &bmg[isloc], 1, newbytes, pbf[0] ) != newbytes ) { iret = ( feof(pbf[0]) ? -1 : -2 ); } else { iret = 0; } return (f77int) iret; } ./rcstpl.f0000644001370400056700000001573713440555365011456 0ustar jator2emc SUBROUTINE RCSTPL(LUN,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RCSTPL C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL C SUBSET ARRAYS IN MODULES USRINT AND USRBIT. THIS IS IN C PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE C LIBRARY SUBROUTINE RDTREE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); MAXRCR (MAXIMUM C NUMBER OF RECURSION LEVELS) INCREASED FROM C 50 TO 100 (WAS IN VERIFICATION VERSION); C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY; COMMENTED OUT C HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT C IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN C MACHINES) C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2016-11-09 J. ATOR -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY C CORRUPT SUBSETS C C USAGE: CALL RCSTPL (LUN,IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = NORMAL RETURN C -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A C CORRUPT SUBSET IN THE INPUT MESSAGE C C REMARKS: C THIS ROUTINE CALLS: BORT IGETRFEL STRBTM UPBB C THIS ROUTINE IS CALLED BY: RDTREE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_USRBIT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES USE MODA_USRTMP INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR DIMENSION NBMP(2,MAXRCR),NEWN(2,MAXRCR) DIMENSION KNX(MAXRCR) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C SET THE INITIAL VALUES FOR THE TEMPLATE C --------------------------------------- c .... Positional index of Table A mnem. INV(1,LUN) = INODE(LUN) VAL(1,LUN) = 0 NBMP(1,1) = 1 NBMP(2,1) = 1 NODI = INODE(LUN) NODE = INODE(LUN) MBMP = 1 KNVN = 1 NR = 0 DO I=1,MAXRCR KNX(I) = 0 ENDDO C SET UP THE PARAMETERS FOR A LEVEL OF RECURSION C ---------------------------------------------- 10 CONTINUE NR = NR+1 IF(NR.GT.MAXRCR) GOTO 900 NBMP(1,NR) = 1 NBMP(2,NR) = MBMP N1 = ISEQ(NODE,1) N2 = ISEQ(NODE,2) IF(N1.EQ.0 ) GOTO 901 IF(N2-N1+1.GT.MAXJL) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: RCSTPL - MAXJL OVERFLOW; SUBSET SKIPPED') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ENDIF IRET = -1 RETURN ENDIF NEWN(1,NR) = 1 NEWN(2,NR) = N2-N1+1 DO N=1,NEWN(2,NR) NN = JSEQ(N+N1-1) IUTMP(N,NR) = NN VUTMP(N,NR) = VALI(NN) ENDDO C STORE NODES AT SOME RECURSION LEVEL C ----------------------------------- 20 DO I=NBMP(1,NR),NBMP(2,NR) IF(KNX(NR).EQ.0000) KNX(NR) = KNVN IF(I.GT.NBMP(1,NR)) NEWN(1,NR) = 1 DO J=NEWN(1,NR),NEWN(2,NR) IF(KNVN+1.GT.MAXSS) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: RCSTPL - MAXSS OVERFLOW; SUBSET SKIPPED') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ENDIF IRET = -1 RETURN ENDIF KNVN = KNVN+1 NODE = IUTMP(J,NR) c .... INV is positional index in internal jump/link table for packed c subset element KNVN in MBAY INV(KNVN,LUN) = NODE c .... MBIT is the bit in MBAY pointing to where the packed subset c element KNVN begins MBIT(KNVN) = MBIT(KNVN-1)+NBIT(KNVN-1) c .... NBIT is the number of bits in MBAY occupied by packed subset c element KNVN NRFELM(KNVN,LUN) = IGETRFEL(KNVN,LUN) NBIT(KNVN) = IBT(NODE) IF(TAG(NODE)(1:5).EQ.'DPRI ') THEN c .... This is a bitmap entry, so get and store the corresponding value CALL UPBB(IDPRI,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN)) IF(IDPRI.EQ.0) THEN VAL(KNVN,LUN) = 0.0 ELSE VAL(KNVN,LUN) = BMISS ENDIF CALL STRBTM(KNVN,LUN) ENDIF c .... Actual unpacked subset values (VAL) are initialized here c (numbers as BMISS) VAL(KNVN,LUN) = VUTMP(J,NR) IF(ITP(NODE).EQ.1) THEN CALL UPBB(MBMP,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN)) NEWN(1,NR) = J+1 NBMP(1,NR) = I GOTO 10 ENDIF ENDDO NEW = KNVN-KNX(NR) VAL(KNX(NR)+1,LUN) = VAL(KNX(NR)+1,LUN) + NEW KNX(NR) = 0 ENDDO C CONTINUE AT ONE RECURSION LEVEL BACK C ------------------------------------ IF(NR-1.NE.0) THEN NR = NR-1 GOTO 20 ENDIF C FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE C ------------------------------------------------------------------- NVAL(LUN) = KNVN C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '// . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') MAXRCR CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)') . TAG(NODI) CALL BORT(BORT_STR) END ./rdbfdx.f0000644001370400056700000001322713440555365011410 0ustar jator2emc SUBROUTINE RDBFDX(LUNIT,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDBFDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: BEGINNING AT THE CURRENT FILE POINTER LOCATION WITHIN LUNIT, C THIS SUBROUTINE READS A COMPLETE DICTIONARY TABLE (I.E. ONE OR MORE C ADJACENT BUFR DX (DICTIONARY) MESSAGES) INTO INTERNAL MEMORY ARRAYS C IN MODULE 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 2009-03-23 J. ATOR -- USE STNTBIA; MODIFY LOGIC TO HANDLE BUFR C TABLE MESSAGES ENCOUNTERED ANYWHERE IN THE C FILE (AND NOT JUST AT THE BEGINNING!) C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS 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 C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE RDUSDX, EXCEPT THAT RDUSDX READS FROM A FILE CONTAINING C A USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT. SEE THE C DOCBLOCK IN RDUSDX FOR A DESCRIPTION OF THE ARRAYS THAT ARE FILLED C IN MODULE TABABD. C C THIS SUBROUTINE PERFORMS A FUNCTION SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE CPDXMM, EXCEPT THAT CPDXMM WRITES TO THE INTERNAL MEMORY C ARRAYS IN MODULE MSGMEM, FOR USE WITH A FILE OF BUFR MESSAGES THAT C IS BEING READ AND STORED INTO INTERNAL MEMORY BY BUFR ARCHIVE C LIBRARY SUBROUTINE UFBMEM. C C THIS ROUTINE CALLS: BORT DXINIT ERRWRT IDXMSG C IUPBS3 MAKESTAB RDMSGW STBFDX C BACKBUFR C THIS ROUTINE IS CALLED BY: POSAPX READDX READMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT CHARACTER*128 ERRSTR LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL DXINIT(LUN,0) ICT = 0 DONE = .FALSE. C Read a complete dictionary table from LUNIT, as a set of one or C more DX dictionary messages. DO WHILE ( .NOT. DONE ) CALL RDMSGW ( LUNIT, MGWA, IER ) IF ( IER .EQ. -1 ) THEN C Don't abort for an end-of-file condition, since it may be C possible for a file to end with dictionary messages. C Instead, backspace the file pointer and let the calling C routine diagnose the end-of-file condition and deal with C it as it sees fit. CALL BACKBUFR(LUN) DONE = .TRUE. ELSE IF ( IER .EQ. -2 ) THEN GOTO 900 ELSE IF ( IDXMSG(MGWA) .NE. 1 ) THEN C This is a non-DX dictionary message. Assume we've reached C the end of the dictionary table, and backspace LUNIT so that C the next read (e.g. in the calling routine) will get this C same message. CALL BACKBUFR(LUN) DONE = .TRUE. ELSE IF ( IUPBS3(MGWA,'NSUB') .EQ. 0 ) THEN C This is a DX dictionary message, but it doesn't contain any C actual dictionary information. Assume we've reached the end C of the dictionary table. DONE = .TRUE. ELSE C Store this message into MODULE TABABD. ICT = ICT + 1 CALL STBFDX(LUN,MGWA) ENDIF ENDDO IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) . 'BUFRLIB: RDBFDX - STORED NEW DX TABLE CONSISTING OF (', . ICT, ') MESSAGES;' CALL ERRWRT(ERRSTR) ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA IN '// . 'FILE UNTIL NEXT DX TABLE IS FOUND' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL MAKESTAB RETURN 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// . 'MESSAGE') END ./rdcmps.f0000644001370400056700000001520613440555365011426 0ustar jator2emc SUBROUTINE RDCMPS(LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDCMPS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 C C ABSTRACT: THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET C FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN MODULE C BITBUF) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL C ARRAY VAL(*,LUN) IN MODULE USRINT. C C PROGRAM HISTORY LOG: C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS C WOULD NOT RECOGNIZE COMPRESSED DELAYED C REPLICATION AS A LEGITIMATE DATA STRUCTURE 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION C 2004-08-18 J. ATOR -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC; C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS C THE SAME FOR ALL SUBSETS IN A MESSAGE; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- PREVENT OVERFLOW OF CVAL AND CREF FOR C STRINGS LONGER THAN 8 CHARACTERS C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN C CORRESPONDING CHARACTER FIELD HAS ALL BITS C SET TO 1 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL RDCMPS (LUN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: BORT ICBFMS IGETRFEL STRBTM C UPB UPC UPS USRTPL C THIS ROUTINE IS CALLED BY: READSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES USE MODA_RLCCMN INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 CREF,CVAL EQUIVALENCE (CVAL,RVAL) REAL*8 RVAL,UPS C----------------------------------------------------------------------- C Statement function to compute BUFR "missing value" for field C of length LBIT bits (all bits "on"): LPS(LBIT) = MAX(2**(LBIT)-1,1) C----------------------------------------------------------------------- C SETUP THE SUBSET TEMPLATE C ------------------------- CALL USRTPL(LUN,1,1) C UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B C ----------------------------------------------------------- NSBS = NSUB(LUN) C Note that we are going to unpack the (NSBS)th subset from within C the current BUFR message. IBIT = MBYT(LUN) NRST = 0 C Loop through each element of the subset. N = 0 1 DO N=N+1,NVAL(LUN) NODE = INV(N,LUN) NRFELM(N,LUN) = IGETRFEL(N,LUN) NBIT = IBT(NODE) ITYP = ITP(NODE) C In each of the following code blocks, the "local reference value" C for the element is determined first, followed by the 6-bit value C which indicates how many bits are used to store the increment C (i.e. offset) from this "local reference value". Then, we jump C ahead to where this increment is stored for this particular subset, C unpack it, and add it to the "local reference value" to determine C the final uncompressed value for this element from this subset. C Note that, if an element has the same final uncompressed value C for each subset in the message, then the encoding rules for BUFR C compression dictate that the "local reference value" will be equal C to this value, the 6-bit increment length indicator will have C a value of zero, and the actual increments themselves will be C omitted from the message. IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN C This is a numeric element. CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) JBIT = IBIT + LINC*(NSBS-1) CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) IF(NINC.EQ.LPS(LINC)) THEN IVAL = LPS(NBIT) ELSE IVAL = LREF+NINC ENDIF IF(ITYP.EQ.1) THEN CALL USRTPL(LUN,N,IVAL) GOTO 1 ENDIF IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE) CALL STRBTM(N,LUN) IBIT = IBIT + LINC*MSUB(LUN) ELSEIF(ITYP.EQ.3) THEN C This is a character element. If there are more than 8 C characters, then only the first 8 will be unpacked by this C routine, and a separate subsequent call to BUFR archive library C subroutine READLC will be required to unpack the remainder of C the string. In this case, pointers will be saved within C COMMON /RLCCMN/ for later use within READLC. C Unpack the local reference value. LELM = NBIT/8 NCHR = MIN(8,LELM) IBSV = IBIT CREF = ' ' CALL UPC(CREF,NCHR,MBAY(1,LUN),IBIT,.TRUE.) IF(LELM.GT.8) THEN IBIT = IBIT + (LELM-8)*8 NRST = NRST + 1 IF(NRST.GT.MXRST) GOTO 900 CRTAG(NRST) = TAG(NODE) ENDIF C Unpack the increment length indicator. For character elements, C this length is in bytes rather than bits. CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) IF(LINC.EQ.0) THEN IF(LELM.GT.8) THEN IRNCH(NRST) = LELM IRBIT(NRST) = IBSV ENDIF CVAL = CREF ELSE JBIT = IBIT + LINC*(NSBS-1)*8 IF(LELM.GT.8) THEN IRNCH(NRST) = LINC IRBIT(NRST) = JBIT ENDIF NCHR = MIN(8,LINC) CVAL = ' ' CALL UPC(CVAL,NCHR,MBAY(1,LUN),JBIT,.TRUE.) ENDIF IF (LELM.LE.8 .AND. ICBFMS(CVAL,NCHR).NE.0) THEN VAL(N,LUN) = BMISS ELSE VAL(N,LUN) = RVAL ENDIF IBIT = IBIT + 8*LINC*MSUB(LUN) ENDIF ENDDO RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' // . 'STRINGS EXCEEDS THE LIMIT (",I4,")")') MXRST CALL BORT(BORT_STR) END ./rdmemm.f0000644001370400056700000001770313440555365011423 0ustar jator2emc SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMEMM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM C INTERNAL MEMORY (ARRAY MSGS IN MODULE MSGMEM) INTO A MESSAGE C BUFFER (ARRAY MBAY IN MODULE BITBUF). IT IS IDENTICAL C TO BUFR ARCHIVE LIBRARY SUBROUTINE READMM EXCEPT IT DOES C NOT ADVANCE THE VALUE OF IMSG PRIOR TO RETURNING TO CALLING C PROGRAM. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT 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); THE MAXIMUM C NUMBER OF BYTES REQUIRED TO STORE ALL C MESSAGES INTERNALLY WAS INCREASED FROM 4 C MBYTES TO 8 MBYTES C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD C BEEN REPLICATED IN THIS AND OTHER READ C ROUTINES AND CONSOLIDATED IT INTO A NEW C ROUTINE CKTABA, CALLED HERE, WHICH IS C ENHANCED TO ALLOW COMPRESSED AND STANDARD C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE C LENGTH INCREASED FROM 10,000 TO 20,000 C BYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE C (DICTIONARY) MESSAGES; USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C C USAGE: CALL RDMEMM (IMSG, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = IMSG is either zero or greater than the C number of messages in memory C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT C MAKESTAB STATUS STBFDX WTSTAT C THIS ROUTINE IS CALLED BY: READMM UFBMMS UFBRMS UFBTAM C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_MGWA USE MODA_MSGMEM INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 SUBSET LOGICAL KNOWN C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE MESSAGE REQUEST AND FILE STATUS C ----------------------------------------- CALL STATUS(MUNIT,LUN,IL,IM) CALL WTSTAT(MUNIT,LUN,IL, 1) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IRET = 0 IF(IMSG.EQ.0 .OR.IMSG.GT.MSGP(0)) THEN CALL WTSTAT(MUNIT,LUN,IL,0) IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') IF(IMSG.EQ.0) THEN ERRSTR = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '// . 'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '// . 'IRET = -1' ELSE WRITE ( UNIT=ERRSTR, FMT='(A,I6,A,I6,A)' ) . 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', IMSG, . ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (', . MSGP(0), '), RETURN WITH IRET = -1' ENDIF CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IRET = -1 GOTO 100 ENDIF C ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE C --------------------------------------------------- C Determine which table applies to this message. KNOWN = .FALSE. JJ = NDXTS DO WHILE ((.NOT.KNOWN).AND.(JJ.GE.1)) IF (IPMSGS(JJ).LE.IMSG) THEN KNOWN = .TRUE. ELSE JJ = JJ - 1 ENDIF ENDDO IF (.NOT.KNOWN) GOTO 902 C Is this table the one that is currently in scope? IF (JJ.NE.LDXTS) THEN C No, so reset the software to use the proper table. IF(IPRT.GE.2) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I3,A,I6)' ) . 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', JJ, . ' INSTEAD OF DX TABLE #', LDXTS, . ' FOR REQUESTED MESSAGE #', IMSG CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF CALL DXINIT(LUN,0) C Store each of the DX dictionary messages which constitute C this table. DO II = IFDXTS(JJ), (IFDXTS(JJ)+ICDXTS(JJ)-1) IF (II.EQ.NDXM) THEN NWRD = LDXM - IPDXM(II) + 1 ELSE NWRD = IPDXM(II+1) - IPDXM(II) ENDIF DO KK = 1, NWRD MGWA(KK) = MDX(IPDXM(II)+KK-1) ENDDO CALL STBFDX(LUN,MGWA) ENDDO C Rebuild the internal jump/link table. CALL MAKESTAB LDXTS = JJ ENDIF C READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER C ----------------------------------------------------- IPTR = MSGP(IMSG) IF(IMSG.LT.MSGP(0)) LPTR = MSGP(IMSG+1)-IPTR IF(IMSG.EQ.MSGP(0)) LPTR = MLAST-IPTR+1 IPTR = IPTR-1 DO I=1,LPTR MBAY(I,LUN) = MSGS(IPTR+I) ENDDO C PARSE THE MESSAGE SECTION CONTENTS C ---------------------------------- CALL CKTABA(LUN,SUBSET,JDATE,JRET) NMSG(LUN) = IMSG C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 WRITE(BORT_STR,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '// . 'REQUESTED MESSAGE #",I5)') IMSG CALL BORT(BORT_STR) END ./rdmems.f0000644001370400056700000001370713440555365011431 0ustar jator2emc SUBROUTINE RDMEMS(ISUB,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMEMS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET FROM A BUFR C MESSAGE IN INTERNAL MEMORY (ARRAY MBAY IN MODULE BITBUF) INTO C INTERNAL SUBSET ARRAYS BASED ON THE SUBSET NUMBER IN THE MESSAGE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL RDMEMS (ISUB, IRET) C INPUT ARGUMENT LIST: C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = ISUB is greater than the number of subsets C in memory C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT IUPB READSB C STATUS C THIS ROUTINE IS CALLED BY: UFBMMS UFBMNS UFBRMS C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_UNPTYP USE MODA_BITBUF USE MODA_MSGMEM INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR,ERRSTR COMMON /QUIET / IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE MESSAGE REQUEST AND FILE STATUS C ----------------------------------------- CALL STATUS(MUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(NSUB(LUN).NE.0) GOTO 903 IF(ISUB.GT.MSUB(LUN)) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I5,A,A,I5,A)' ) . 'BUFRLIB: RDMEMS - REQ. SUBSET #', ISUB, ' (= 1st INPUT ', . 'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', MSUB(LUN), ')' CALL ERRWRT(ERRSTR) CALL ERRWRT('RETURN WITH IRET = -1') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IRET = -1 GOTO 100 ENDIF MBYM = MBYT(LUN) NBYT = 0 C POSITION TO SUBSET NUMBER ISUB IN MEMORY MESSAGE C ------------------------------------------------ IF(MSGUNP(LUN).EQ.0) THEN NSUB(LUN) = ISUB-1 DO I=1,ISUB-1 MBYT(LUN) = MBYT(LUN) + IUPB(MBAY(1,LUN),MBYT(LUN)+1,16) ENDDO ELSEIF(MSGUNP(LUN).EQ.1) THEN c .... message with "standard" Section 3 DO I=1,ISUB-1 CALL READSB(MUNIT,IRET) ENDDO ELSEIF(MSGUNP(LUN).EQ.2) THEN c .... compressed message NSUB(LUN) = ISUB-1 ENDIF C NOW READ SUBSET NUMBER ISUB FROM MEMORY MESSAGE C ----------------------------------------------- CALL READSB(MUNIT,IRET) c .... This should have already been accounted for with stmt. 902 or c IRET = -1 above IF(IRET.NE.0) GOTO 904 C RESET SUBSET POINTER BACK TO ZERO (BEGINNING OF MESSAGE) AND RETURN C ------------------------------------------------------------------- MBYT(LUN) = MBYM NSUB(LUN) = 0 C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: RDMEMS - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN '// . 'INPUT BUFR FILE, NONE ARE') 903 WRITE(BORT_STR,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER '// . 'IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," SUBSETS HAVE '// . 'BEEN READ, SHOULD BE 0)")') NSUB(LUN) CALL BORT(BORT_STR) 904 CALL BORT('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED '// . 'WITH IRET = -1 (EITHER MEMORY MESSAGE NOT OPEN OR ALL '// . 'SUBSETS IN MESSAGE READ') END ./rdmgsb.f0000644001370400056700000000760313440555365011416 0ustar jator2emc SUBROUTINE RDMGSB(LUNIT,IMSG,ISUB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMGSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE IN LOGICAL UNIT LUNIT FOR C INPUT OPERATIONS, THEN READS A PARTICULAR SUBSET INTO INTERNAL C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. C THIS IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE C NUMBER IN THE BUFR FILE. THE MESSAGE NUMBER DOES NOT INCLUDE THE C DICTIONARY MESSAGES AT THE BEGINNING OF THE FILE. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION C VERSION AT ONE TIME AND THEN REMOVED) C 2003-11-04 D. KEYSER -- INCORPORATED INTO "UNIFIED" BUFR ARCHIVE C LIBRARY; UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT C JUST AT THE BEGINNING!) C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL RDMGSB (LUNIT, IMSG, ISUB) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN C BUFR FILE C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT OPENBF READMG READSB C STATUS UPB C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C OPEN THE FILE AND SKIP TO MESSAGE # IMSG C ---------------------------------------- CALL OPENBF(LUNIT,'IN',LUNIT) CALL STATUS(LUNIT,LUN,IL,IM) C Note that we need to use subroutine READMG to actually read in all C of the messages (including the first (IMSG-1) messages!), just in C case there are any embedded dictionary messages in the file. DO I=1,IMSG CALL READMG(LUNIT,SUBSET,JDATE,IRET) IF(IRET.LT.0) GOTO 901 ENDDO C POSITION AT SUBSET # ISUB C ------------------------- DO I=1,ISUB-1 IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 ENDDO CALL READSB(LUNIT,IRET) IF(IRET.NE.0) GOTO 902 C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ERROR READING MESSAGE '// . '(RECORD) NUMBER",I5," IN INPUT BUFR FILE CONNECTED TO UNIT",'// . 'I4)') I,LUNIT CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - HIT END OF FILE BEFORE '// . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// . ' UNIT",I4)') IMSG,LUNIT CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: RDMGSB - ALL SUBSETS READ BEFORE '// . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT CALL BORT(BORT_STR) END ./rdmsgw.f0000644001370400056700000000427713440555365011447 0ustar jator2emc SUBROUTINE RDMSGW(LUNIT,MESG,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMSGW C PRGMMR: ATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL C UNIT LUNIT AS AN ARRAY OF INTEGER WORDS. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL AUTHOR C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MESG OVERFLOW C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; C USE C ROUTINE CRDBUFR TO OBTAIN BUFR C MESSAGE; REMOVE CODE WHICH CHECKS SEC0 C AND MESSAGE LENGTH AS CRDBUFR DOES THAT C C USAGE: CALL RDMSGW (LUNIT, MESG, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C MESG - *-WORD ARRAY CONTAINING BUFR MESSAGE READ FROM LUNIT C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = end-of-file encountered while reading C from LUNIT C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: CRDBUFR ERRWRT STATUS C THIS ROUTINE IS CALLED BY: COPYBF CPDXMM DATEBF DUMPBF C MESGBC MESGBF POSAPX RDBFDX C READMG UFBMEM UFBMEX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MXMSGL INCLUDE 'bufrlib.prm' COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION MESG(*) CHARACTER*128 BORT_STR INTEGER CRDBUFR C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) 1 IRET=CRDBUFR(LUN,MESG,MXMSGL) IF(IRET.eq.-3) + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE') IF(IRET.eq.-2) + CALL ERRWRT('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE') IF(IRET.LT.-1) GOTO 1 RETURN END ./rdmtbb.f0000644001370400056700000001207413440555365011410 0ustar jator2emc SUBROUTINE RDMTBB ( LUNSTB, LUNLTB, MXMTBB, . IMT, IMTV, IOGCE, ILTV, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMTBB C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE B INFORMATION FROM TWO C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN C MERGES IT INTO A UNIFIED SET OF MASTER TABLE B ARRAYS FOR OUTPUT. C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL RDMTBB ( LUNSTB, LUNLTB, MXMTBB, IMT, IMTV, IOGCE, C ILTV, NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, C CMUNIT, CMMNEM, CMDSC, CMELEM ) C INPUT ARGUMENT LIST: C LUNSTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING STANDARD TABLE B INFORMATION C LUNLTB - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING LOCAL TABLE B INFORMATION C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS C C OUTPUT ARGUMENT LIST: C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM C STANDARD ASCII FILE C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM C LOCAL ASCII FILE C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B C ARRAYS C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF FXY NUMBERS C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH C SNTBBE WRDLEN C THIS ROUTINE IS CALLED BY: IREADMT C Not normally called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*200 STLINE, LTLINE CHARACTER*128 BORT_STR CHARACTER*120 CMELEM(*) CHARACTER*14 CMUNIT(*) CHARACTER*12 CMSREF(*) CHARACTER*8 CMMNEM(*) CHARACTER*6 CMATCH, ADN30 CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) INTEGER IMFXYN(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Call WRDLEN to initialize some important information about the C local machine, just in case it hasn't already been called. CALL WRDLEN C Read and parse the header lines of both files. CALL GETTBH ( LUNSTB, LUNLTB, 'B', IMT, IMTV, IOGCE, ILTV ) C Read through the remainder of both files, merging the C contents into a unified set of master Table B arrays. NMTBB = 0 CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN IF ( ISFXYN .EQ. ILFXYN ) THEN CMATCH = ADN30 ( ISFXYN, 6 ) GOTO 900 ELSE IF ( ISFXYN .LT. ILFXYN ) THEN CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) ELSE CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) ENDIF ELSE IF ( IERS .EQ. 0 ) THEN CALL SNTBBE ( ISFXYN, STLINE, MXMTBB, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) CALL GETNTBE ( LUNSTB, ISFXYN, STLINE, IERS ) ELSE IF ( IERL .EQ. 0 ) THEN CALL SNTBBE ( ILFXYN, LTLINE, MXMTBB, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) CALL GETNTBE ( LUNLTB, ILFXYN, LTLINE, IERL ) ENDIF ENDDO RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBB - STANDARD AND LOCAL'// . ' TABLE B FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) CALL BORT(BORT_STR) END ./rdmtbd.f0000644001370400056700000001310413440555365011405 0ustar jator2emc SUBROUTINE RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, . IMT, IMTV, IOGCE, ILTV, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMTBD C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE READS MASTER TABLE D INFORMATION FROM TWO C SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES AND THEN C MERGES IT INTO A UNIFIED SET OF MASTER TABLE D ARRAYS FOR OUTPUT. C EACH OF THE TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN C ASCENDING ORDER WITH RESPECT TO THE FXY NUMBERS. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, C IMT, IMTV, IOGCE, ILTV, C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, C NMELEM, IEFXYN, CEELEM ) C INPUT ARGUMENT LIST: C LUNSTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING STANDARD TABLE D INFORMATION C LUNLTD - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING LOCAL TABLE D INFORMATION C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW C THESE ARRAYS C C OUTPUT ARGUMENT LIST: C IMT - INTEGER: MASTER TABLE, READ FROM EACH ASCII FILE C (NOTE: THESE VALUES MUST BE THE SAME IN EACH FILE!) C IMTV - INTEGER: VERSION NUMBER OF MASTER TABLE, READ FROM C STANDARD ASCII FILE C IOGCE - INTEGER: ORIGINATING CENTER, READ FROM LOCAL ASCII FILE C ILTV - INTEGER: VERSION NUMBER OF LOCAL TABLE, READ FROM C LOCAL ASCII FILE C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D C ARRAYS C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE C DESCRIPTORS) C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS C STORED FOR EACH ENTRY C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF ELEMENT FXY NUMBERS C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH C SNTBDE WRDLEN C THIS ROUTINE IS CALLED BY: IREADMT C Not normally called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*200 STLINE, LTLINE CHARACTER*128 BORT_STR CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) CHARACTER*8 CMMNEM(*) CHARACTER*6 CMATCH, ADN30 CHARACTER*4 CMDSC(*) INTEGER IMFXYN(*), NMELEM(*), . IEFXYN(MXMTBD,MXELEM) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Call WRDLEN to initialize some important information about the C local machine, just in case it hasn't already been called. CALL WRDLEN C Read and parse the header lines of both files. CALL GETTBH ( LUNSTD, LUNLTD, 'D', IMT, IMTV, IOGCE, ILTV ) C Read through the remainder of both files, merging the C contents into a unified set of master Table D arrays. NMTBD = 0 CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN IF ( ISFXYN .EQ. ILFXYN ) THEN CMATCH = ADN30 ( ISFXYN, 6 ) GOTO 900 ELSE IF ( ISFXYN .LT. ILFXYN ) THEN CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) ELSE CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) ENDIF ELSE IF ( IERS .EQ. 0 ) THEN CALL SNTBDE ( LUNSTD, ISFXYN, STLINE, MXMTBD, MXELEM, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) CALL GETNTBE ( LUNSTD, ISFXYN, STLINE, IERS ) ELSE IF ( IERL .EQ. 0 ) THEN CALL SNTBDE ( LUNLTD, ILFXYN, LTLINE, MXMTBD, MXELEM, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) CALL GETNTBE ( LUNLTD, ILFXYN, LTLINE, IERL ) ENDIF ENDDO RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBD - STANDARD AND LOCAL'// . ' TABLE D FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) CALL BORT(BORT_STR) END ./rdmtbf.f0000644001370400056700000000605313440555365011414 0ustar jator2emc SUBROUTINE RDMTBF ( LUNSTF, LUNLTF ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDMTBF C PRGMMR: ATOR ORG: NCEP DATE: 2017-10-17 C C ABSTRACT: THIS SUBROUTINE READS MASTER CODE/FLAG TABLE INFORMATION C FROM TWO SEPARATE (I.E. ONE STANDARD AND ONE LOCAL) ASCII FILES C AND THEN MERGES IT INTO AN INTERNAL MEMORY STRUCTURE. EACH OF THE C TWO INPUT FILES MUST ALREADY BE INDIVIDUALLY SORTED IN ASCENDING C ORDER WITH RESPECT TO THE FXY NUMBERS. C C PROGRAM HISTORY LOG: C 2017-10-17 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL RDMTBF ( LUNSTF, LUNLTF ) C C INPUT ARGUMENT LIST: C LUNSTF - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING STANDARD CODE/FLAG TABLE INFORMATION C LUNLTF - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING LOCAL CODE/FLAG TABLE INFORMATION C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT GETNTBE GETTBH C INITTBF SNTBFE SORTTBF WRDLEN C THIS ROUTINE IS CALLED BY: IREADMT C Not normally called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*160 STLINE, LTLINE CHARACTER*128 BORT_STR CHARACTER*6 CMATCH, ADN30 C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Call WRDLEN to initialize some important information about the C local machine, just in case it hasn't already been called. CALL WRDLEN C Initialize the internal memory structure, including allocating C space for it in case this hasn't already been done. CALL INITTBF C Read and parse the header lines of both files. CALL GETTBH ( LUNSTF, LUNLTF, 'F', IMT, IMTV, IOGCE, ILTV ) C Read through the remainder of both files, merging the C contents into a unified internal memory structure. CALL GETNTBE ( LUNSTF, ISFXYN, STLINE, IERS ) CALL GETNTBE ( LUNLTF, ILFXYN, LTLINE, IERL ) DO WHILE ( ( IERS .EQ. 0 ) .OR. ( IERL .EQ. 0 ) ) IF ( ( IERS .EQ. 0 ) .AND. ( IERL .EQ. 0 ) ) THEN IF ( ISFXYN .EQ. ILFXYN ) THEN CMATCH = ADN30 ( ISFXYN, 6 ) GOTO 900 ELSE IF ( ISFXYN .LT. ILFXYN ) THEN CALL SNTBFE ( LUNSTF, ISFXYN, STLINE ) CALL GETNTBE ( LUNSTF, ISFXYN, STLINE, IERS ) ELSE CALL SNTBFE ( LUNLTF, ILFXYN, LTLINE ) CALL GETNTBE ( LUNLTF, ILFXYN, LTLINE, IERL ) ENDIF ELSE IF ( IERS .EQ. 0 ) THEN CALL SNTBFE ( LUNSTF, ISFXYN, STLINE ) CALL GETNTBE ( LUNSTF, ISFXYN, STLINE, IERS ) ELSE IF ( IERL .EQ. 0 ) THEN CALL SNTBFE ( LUNLTF, ILFXYN, LTLINE ) CALL GETNTBE ( LUNLTF, ILFXYN, LTLINE, IERL ) ENDIF ENDDO C Sort the contents of the internal memory structure. CALL SORTTBF RETURN 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBF - STANDARD AND LOCAL'// . ' CODE/FLAG TABLE FILES BOTH CONTAIN SAME FXY NUMBER: ",5A)') . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) CALL BORT(BORT_STR) END ./rdtree.f0000644001370400056700000001200413440555365011414 0ustar jator2emc SUBROUTINE RDTREE(LUN,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RDTREE C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL C UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN MODULE BITBUF) AND C STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN) C IN MODULE USRINT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN C THE LAST ELEMENT IN A SUBSET IS A CHARACTER C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER C THAN 8 CHARACTERS C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN C CORRESPONDING CHARACTER FIELD HAS ALL BITS C SET TO 1 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2016-11-09 J. ATOR -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY C CORRUPT SUBSETS C C USAGE: CALL RDTREE (LUN,IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = NORMAL RETURN C -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A C CORRUPT SUBSET IN THE INPUT MESSAGE C C REMARKS: C THIS ROUTINE CALLS: RCSTPL ICBFMS UPBB UPC C UPS C THIS ROUTINE IS CALLED BY: READSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_USRBIT USE MODA_IVAL USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 CVAL EQUIVALENCE (CVAL,RVAL) REAL*8 RVAL,UPS C----------------------------------------------------------------------- C Statement function to compute BUFR "missing value" for field C of length IBT(NODE)) bits (all bits "on"): MPS(NODE) = 2**(IBT(NODE))-1 C----------------------------------------------------------------------- IRET = 0 C CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE C ---------------------------------------------- MBIT(1) = IBIT NBIT(1) = 0 CALL RCSTPL(LUN,IER) IF(IER.NE.0) THEN IRET = -1 RETURN ENDIF C UNPACK A SUBSET INTO THE USER ARRAY IVAL C ---------------------------------------- DO N=1,NVAL(LUN) CALL UPBB(IVAL(N),NBIT(N),MBIT(N),MBAY(1,LUN)) ENDDO C LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED C VALUES TO THE PROPER TYPES C ---------------------------------------------------------------- DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN C The unpacked value is a delayed descriptor replication factor. VAL(N,LUN) = IVAL(N) ELSEIF(ITP(NODE).EQ.2) THEN C The unpacked value is a real. IF (IVAL(N).LT.MPS(NODE)) THEN VAL(N,LUN) = UPS(IVAL(N),NODE) ELSE VAL(N,LUN) = BMISS ENDIF ELSEIF(ITP(NODE).EQ.3) THEN C The value is a character string, so unpack it using an C equivalenced REAL*8 value. Note that a maximum of 8 characters C will be unpacked here, so a separate subsequent call to BUFR C archive library subroutine READLC will be needed to fully C unpack any string longer than 8 characters. CVAL = ' ' KBIT = MBIT(N) NBT = MIN(8,NBIT(N)/8) CALL UPC(CVAL,NBT,MBAY(1,LUN),KBIT,.TRUE.) IF (NBIT(N).LE.64 .AND. ICBFMS(CVAL,NBT).NE.0) THEN VAL(N,LUN) = BMISS ELSE VAL(N,LUN) = RVAL ENDIF ENDIF ENDDO IBIT = NBIT(NVAL(LUN))+MBIT(NVAL(LUN)) RETURN END ./rdusdx.f0000644001370400056700000002407413440555365011452 0ustar jator2emc 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 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 CONTENTS OF INTERNAL ARRAYS WRITTEN INTO MODULE 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$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' 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 ./readdx.f0000644001370400056700000001367713440555365011417 0ustar jator2emc SUBROUTINE READDX(LUNIT,LUN,LUNDX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE GENERATES INTERNAL ARRAYS CONTAINING BUFR C DICTIONARY TABLES WHICH ARE NEEDED TO READ, WRITE, INITIALIZE OR C APPEND A BUFR FILE. THE INFORMATION USED TO CREATE THE INTERNAL C DICTIONARY TABLE ARRAYS (IN MODULE TABABD) AND THE DICTIONARY C MESSAGE CONTROL WORD PARTITION ARRAYS (IN MODULE MSGCWD) C (WHICH ARE ALWAYS THEN ASSOCIATED WITH THE BUFR FILE IN LUNIT) C MAY COME FROM AN EXTERNAL, USER-SUPPLIED, BUFR DICTIONARY C TABLE FILE IN CHARACTER FORMAT (I.E., A BUFR MNEMONIC TABLE), FROM C THE BUFR FILE BEING ACTED UPON (IN WHICH CASE THE FILE MUST BE C OPENED FOR INPUT PROCESSING AND POSITIONED AT A DICTIONARY TABLE C MESSAGE SOMEWHERE IN THE FILE), OR FROM ANOTHER CURRENTLY OPENED C AND DEFINED BUFR FILE. IN THIS LATTER CASE, THE BUFR FILE WOULD C MOST LIKELY BE OPENED FOR INPUT, HOWEVER THERE IS NOTHING C PREVENTING THE USE OF A FILE OPEN FOR OUTPUT AS LONG AS IT IS C ASSOCIATED WITH INTERNAL DICTIONARY ARRAYS THAT CAN BE USED. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 OR FOR INFORMATIONAL C PURPOSES C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL READDX (LUNIT, LUN, LUNDX) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C BEING READ, WRITTEN, INITIALIZED OR APPENDED C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING C DICTIONARY TABLE INFORMATION TO BE USED IN READING/ C WRITING FROM/TO LUNIT (DEPENDING ON THE CASE); MAY BE C SET EQUAL TO LUNIT IF DICTIONARY TABLE INFORMATION IS C ALREADY EMBEDDED IN LUNIT (BUT ONLY IF LUNIT IS BEING C READ) C C REMARKS: C THIS ROUTINE CALLS: BORT CPBFDX ERRWRT MAKESTAB C RDBFDX RDUSDX STATUS C THIS ROUTINE IS CALLED BY: OPENBF WRITDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /QUIET/ IPRT CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C GET THE BUFR STATUS OF UNIT LUNDX C --------------------------------- CALL STATUS(LUNDX,LUD,ILDX,IMDX) C READ A DICTIONARY TABLE FROM THE INDICATED SOURCE C ------------------------------------------------- IF (LUNIT.EQ.LUNDX) THEN c .... Source is input BUFR file in LUNIT IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', . 'INPUT BUFR FILE IN UNIT ', LUNDX, ' INTO INTERNAL ARRAYS' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') CALL ERRWRT(' ') ENDIF REWIND LUNIT CALL RDBFDX(LUNIT,LUN) ELSEIF(ILDX.EQ.-1) THEN c .... Source is input BUFR file in LUNDX c .... BUFR file in LUNIT may be input or output IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', . 'ARRAYS ASSOC. W/ INPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', . 'W/ UNIT ', LUNIT CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') CALL ERRWRT(' ') ENDIF CALL CPBFDX(LUD,LUN) CALL MAKESTAB ELSEIF(ILDX.EQ.1) THEN c .... Source is output BUFR file in LUNDX c .... BUFR file in LUNIT may be input or output IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A,A,I3)' ) . 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', . 'ARRAYS ASSOC. W/ OUTPUT UNIT ', LUNDX, ' TO THOSE ASSOC. ', . 'W/ UNIT ', LUNIT CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') CALL ERRWRT(' ') ENDIF CALL CPBFDX(LUD,LUN) CALL MAKESTAB ELSEIF(ILDX.EQ.0) THEN c .... Source is user-supplied character table in LUNDX c .... BUFR file in LUNIT may be input or output IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I3,A)' ) . 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', . 'USER-SUPPLIED TEXT FILE IN UNIT ', LUNDX, . ' INTO INTERNAL ARRAYS' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') CALL ERRWRT(' ') ENDIF REWIND LUNDX CALL RDUSDX(LUNDX,LUN) ELSE GOTO 900 ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: READDX - CANNOT DETERMINE SOURCE OF '// . 'INPUT DICTIONARY TABLE') END ./readerme.f0000644001370400056700000002057713440555365011731 0ustar jator2emc SUBROUTINE READERME(MESG,LUNIT,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READERME C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-06-28 C C ABSTRACT: THIS SUBROUTINE READS INFORMATION FROM A BUFR DATA MESSAGE C ALREADY IN MEMORY, PASSED IN AS AN INPUT ARGUMENT. IT IS SIMILAR C TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG EXCEPT, INSTEAD OF C READING BUFR MESSAGES DIRECTLY FROM A BUFR FILE THAT IS PHYSICALLY C STORED ON THE LOCAL SYSTEM AND INTERFACED TO THE SOFTWARE VIA A C LOGICAL UNIT NUMBER, IT READS BUFR MESSAGES DIRECTLY FROM A MEMORY C ARRAY WITHIN THE APPLICATION PROGRAM ITSELF. THIS PROVIDES USERS C WITH GREATER FLEXIBILITY FROM AN INPUT/OUTPUT PERSPECTIVE. C READERME CAN BE USED IN ANY CONTEXT IN WHICH READMG MIGHT OTHERWISE C BE USED. IF THIS MESSAGE IS NOT A BUFR MESSAGE, THEN AN C APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1995-06-28 J. WOOLLEN -- ORIGINAL AUTHOR (FOR ERS DATA) C 1997-07-29 J. WOOLLEN -- MODIFIED TO PROCESS GOES SOUNDINGS FROM C NESDIS C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT; IMPROVED MACHINE PORTABILITY 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); INCREASED THE C MAXIMUM NUMBER OF POSSIBLE DESCRIPTORS IN A C SUBSET FROM 1000 TO 3000 C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD C BEEN REPLICATED IN THIS AND OTHER READ C ROUTINES AND CONSOLIDATED IT INTO A NEW C ROUTINE CKTABA, CALLED HERE, WHICH IS C ENHANCED TO ALLOW COMPRESSED AND STANDARD C BUFR MESSAGES TO BE READ (ROUTINE UNCMPS, C WHICH HAD BEEN CALLED BY THIS AND OTHER C ROUTINES IS NOW OBSOLETE AND HAS BEEN C REMOVED FROM THE BUFRLIB; MAXIMUM MESSAGE C LENGTH INCREASED FROM 10,000 TO 20,000 C 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-18 J. ATOR -- MODIFIED 'BUFR' STRING TEST FOR PORTABILITY C TO EBCDIC MACHINES; MAXIMUM MESSAGE LENGTH C INCREASED FROM 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- USE ICHKSTR C 2009-03-23 D. KEYSER -- CALL BORT IN CASE OF MBAY OVERFLOW C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; C ADD LOGIC TO PROCESS DICTIONARY MESSAGES C 2012-06-07 J. ATOR -- DON'T RESPOND TO DX TABLE MESSAGES IF C SECTION 3 DECODING IS BEING USED C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL READERME (MESG, LUNIT, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = unrecognized Table A message type C 11 = this is a BUFR table (dictionary) message C C REMARKS: C THIS ROUTINE CALLS: BORT CKTABA DXINIT ERRWRT C ICHKSTR IDXMSG IUPBS3 LMSG C MAKESTAB READS3 STATUS STBFDX C WTSTAT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_SC3BFR USE MODA_IDRDM USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) COMMON /QUIET/ IPRT CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 SUBSET,SEC0 CHARACTER*1 CEC0(8) DIMENSION MESG(*),IEC0(2) LOGICAL ENDTBL EQUIVALENCE (SEC0,IEC0,CEC0) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 CALL WTSTAT(LUNIT,LUN,IL, 1) C COPY THE INPUT MESSAGE INTO THE INTERNAL MESSAGE BUFFER C ------------------------------------------------------- IEC0(1) = MESG(1) IEC0(2) = MESG(2) LNMSG = LMSG(SEC0) IF(LNMSG*NBYTW.GT.MXMSGL) GOTO 902 DO I=1,LNMSG MBAY(I,LUN) = MESG(I) ENDDO C Confirm that the first 4 bytes of SEC0 contain 'BUFR' encoded in C CCITT IA5 (i.e. ASCII). IF(ICHKSTR('BUFR',CEC0,4).NE.0) GOTO 903 C PARSE THE MESSAGE SECTION CONTENTS C ---------------------------------- IF(ISC3(LUN).NE.0) CALL READS3(LUN) CALL CKTABA(LUN,SUBSET,JDATE,IRET) IF(ISC3(LUN).NE.0) RETURN C CHECK FOR A DX DICTIONARY MESSAGE C --------------------------------- C A new DX dictionary table can be passed in as a consecutive set of C DX dictionary messages. Each message should be passed in one at a C time, via input argument MESG during consecutive calls to this C subroutine, and will be processed as a single dictionary table up C until the next message is passed in which either contains no data C subsets or else is a non-DX dictionary message. ENDTBL = .FALSE. IF(IDXMSG(MBAY(1,LUN)).EQ.1) THEN C This is a DX dictionary message that was generated by the C BUFRLIB archive library software. IF(IUPBS3(MBAY(1,LUN),'NSUB').EQ.0) THEN C But it doesn't contain any actual dictionary information, so C assume we've reached the end of the dictionary table. IF(IDRDM(LUN).GT.0) THEN ENDTBL = .TRUE. ENDIF ELSE IF(IDRDM(LUN).EQ.0) THEN C This is the first DX dictionary message that is part of a C new dictionary table. CALL DXINIT(LUN,0) ENDIF IDRDM(LUN) = IDRDM(LUN) + 1 CALL STBFDX(LUN,MBAY(1,LUN)) ENDIF ELSE IF(IDRDM(LUN).GT.0) THEN C This is the first non-DX dictionary message received following a C string of DX dictionary messages, so assume we've reached the C end of the dictionary table. ENDTBL = .TRUE. ENDIF IF(ENDTBL) THEN IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) . 'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (', . IDRDM(LUN), ') MESSAGES;' CALL ERRWRT(ERRSTR) ERRSTR = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA '// . 'MESSAGES UNTIL NEXT DX TABLE IS PASSED IN' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF IDRDM(LUN) = 0 CALL MAKESTAB ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 WRITE(BORT_STR,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH", . 1X,I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")') . LNMSG*NBYTW,MXMSGL CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD'// . ' NOT "BUFR", DOES NOT CONTAIN BUFR DATA') END ./readlc.f0000644001370400056700000001417213440555365011371 0ustar jator2emc SUBROUTINE READLC(LUNIT,CHR,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READLC C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER DATA ELEMENT ASSOCIATED C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER C (ARRAY MBAY IN MODULE BITBUF). IT IS DESIGNED TO BE USED TO RETURN C CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT BYTES. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY OR UNUSUAL THINGS HAPPEN C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-03-23 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES; C ADDED CHECK FOR OVERFLOW OF CHR; ADDED '#' C OPTION FOR MORE THAN ONE OCCURRENCE OF STR C 2009-04-21 J. ATOR -- USE ERRWRT C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS C WHEN USED WITH '#' OCCURRENCE CODE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL READLC (LUNIT, CHR, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C STR - CHARACTER*(*): STRING (I.E., MNEMONIC) C C OUTPUT ARGUMENT LIST: C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT PARSTR PARUTG C STATUS UPC C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP WRTREE C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_USRBIT USE MODA_UNPTYP USE MODA_BITBUF USE MODA_TABLES USE MODA_RLCCMN INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*(*) CHR,STR CHARACTER*128 BORT_STR,ERRSTR CHARACTER*10 CTAG CHARACTER*14 TGS(10) DATA MAXTG /10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- CHR = ' ' C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) C ------------------------------------------------------------------ CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) IF(NTG.GT.1) GOTO 903 C Check if a specific occurrence of the input string was requested; C if not, then the default is to return the first occurrence. CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID) IF(KON.EQ.6) THEN IOID=NINT(ROID) IF(IOID.LE.0) IOID = 1 CTAG = ' ' II = 1 DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) CTAG(II:II)=TGS(1)(II:II) II = II + 1 ENDDO ELSE IOID = 1 CTAG = TGS(1)(1:10) ENDIF C LOCATE AND DECODE THE LONG CHARACTER STRING C ------------------------------------------- IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN C The message is uncompressed ITAGCT = 0 DO N=1,NVAL(LUN) NOD = INV(N,LUN) IF(CTAG.EQ.TAG(NOD)) THEN ITAGCT = ITAGCT + 1 IF(ITAGCT.EQ.IOID) THEN IF(ITP(NOD).NE.3) GOTO 904 NCHR = NBIT(N)/8 IF(NCHR.GT.LEN(CHR)) GOTO 905 KBIT = MBIT(N) CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT,.TRUE.) GOTO 100 ENDIF ENDIF ENDDO ELSEIF(MSGUNP(LUN).EQ.2) THEN C The message is compressed IF(NRST.GT.0) THEN ITAGCT = 0 DO II=1,NRST IF(CTAG.EQ.CRTAG(II)) THEN ITAGCT = ITAGCT + 1 IF(ITAGCT.EQ.IOID) THEN NCHR = IRNCH(II) IF(NCHR.GT.LEN(CHR)) GOTO 905 KBIT = IRBIT(II) CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT,.TRUE.) GOTO 100 ENDIF ENDIF ENDDO ENDIF ELSE GOTO 906 ENDIF C If we made it here, then we couldn't find the requested string. IF(IPRT.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) // . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH BLANK' // . ' STRING FOR CHARACTER DATA ELEMENT' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'// . 'I3,")")') STR,NTG CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD) CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '// . 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LEN(CHR) CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'// . '" IS NOT RECOGNIZED")') MSGUNP CALL BORT(BORT_STR) END ./readmg.f0000644001370400056700000001620513440555365011375 0ustar jator2emc SUBROUTINE READMG(LUNXX,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READMG C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS THE NEXT BUFR MESSAGE FROM LOGICAL C UNIT NUMBER ABS(LUNXX) INTO AN INTERNAL MESSAGE BUFFER (I.E. ARRAY C MBAY IN MODULE BITBUF). ABS(LUNXX) SHOULD ALREADY BE OPENED C FOR INPUT OPERATIONS. IF LUNXX < 0, THEN A READ ERROR FROM C ABS(LUNXX) IS TREATED THE SAME AS THE END-OF-FILE (EOF) CONDITION; C OTHERWISE, BUFR ARCHIVE LIBRARY SUBROUTINE BORT IS NORMALLY CALLED C IN SUCH SITUATIONS. ANY DX DICTIONARY MESSAGES ENCOUNTERED WITHIN C ABS(LUNXX) ARE AUTOMATICALLY PROCESSED AND STORED INTERNALLY, SO A C SUCCESSFUL RETURN FROM THIS SUBROUTINE WILL ALWAYS RESULT IN A BUFR C MESSAGE CONTAINING ACTUAL DATA VALUES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-11-25 J. WOOLLEN -- MODIFIED TO EXIT GRACEFULLY WHEN THE BUFR C FILE IS POSITIONED AFTER AN "END-OF-FILE" C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; MODIFIED TO MAKE Y2K C COMPLIANT 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); MODIFIED WITH C SEMANTIC ADJUSTMENTS TO AMELIORATE COMPILER C COMPLAINTS FROM LINUX BOXES (INCREASES C PORTABILITY) C 2000-09-19 J. WOOLLEN -- REMOVED MESSAGE DECODING LOGIC THAT HAD C BEEN REPLICATED IN THIS AND OTHER READ C ROUTINES AND CONSOLIDATED IT INTO A NEW C ROUTINE CKTABA, CALLED HERE, WHICH IS C ENHANCED TO ALLOW COMPRESSED AND STANDARD C BUFR MESSAGES TO BE READ; MAXIMUM MESSAGE C LENGTH INCREASED FROM 10,000 TO 20,000 C BYTES C 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT DATELEN (IT BECAME A C SEPARATE ROUTINE IN THE BUFRLIB TO INCREASE C PORTABILITY TO OTHER PLATFORMS) 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 C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-11-29 J. ATOR -- ADDED RDMSGW AND RDMSGB CALLS TO SIMULATE C READIBM; ADDED LUNXX < 0 OPTION TO SIMULATE C READFT C 2009-03-23 J. ATOR -- ADD LOGIC TO ALLOW SECTION 3 DECODING; C ADD LOGIC TO PROCESS INTERNAL DICTIONARY C MESSAGES C 2012-06-07 J. ATOR -- DON'T RESPOND TO INTERNAL DICTIONARY C MESSAGES IF SECTION 3 DECODING IS BEING USED C 2012-09-15 J. WOOLLEN -- CONVERT TO C LANGUAGE I/O INTERFACE; C REMOVE CODE TO REREAD MESSAGE AS BYTES; C REPLACE FORTRAN BACKSPACE WITH C BACKBUFR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL READMG (LUNXX, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE (IF LUNXX IS LESS THAN ZERO, THEN READ C ERRORS FROM ABS(LUNXX) ARE TREATED THE SAME AS EOF) C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more BUFR mesages in ABS(LUNXX) C C REMARKS: C THIS ROUTINE CALLS: BORT CKTABA ERRWRT IDXMSG C RDBFDX RDMSGW READS3 STATUS C WTSTAT BACKBUFR C THIS ROUTINE IS CALLED BY: IREADMG READNS RDMGSB REWNBF C UFBINX UFBPOS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_SC3BFR USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 ERRSTR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 LUNIT = ABS(LUNXX) C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 CALL WTSTAT(LUNIT,LUN,IL,1) C READ A MESSAGE INTO THE INTERNAL MESSAGE BUFFER C ----------------------------------------------- 1 CALL RDMSGW(LUNIT,MBAY(1,LUN),IER) IF(IER.EQ.-1) GOTO 200 C PARSE THE MESSAGE SECTION CONTENTS C ---------------------------------- IF(ISC3(LUN).NE.0) CALL READS3(LUN) CALL CKTABA(LUN,SUBSET,JDATE,IRET) C LOOK FOR A DICTIONARY MESSAGE C ----------------------------- IF(IDXMSG(MBAY(1,LUN)).NE.1) RETURN C This is an internal dictionary message that was C generated by the BUFRLIB archive library software. IF(ISC3(LUN).NE.0) RETURN C Section 3 decoding isn't being used, so backspace the C file pointer and then use subroutine RDBFDX to read in C all such dictionary messages (they should be stored C consecutively!) and reset the internal tables. CALL BACKBUFR(LUN) CALL RDBFDX(LUNIT,LUN) IF(IPRT.GE.1) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') ERRSTR = 'BUFRLIB: READMG - INTERNAL DICTIONARY MESSAGE READ;'// .' ACCOUNT FOR IT THEN READ IN NEXT MESSAGE WITHOUT RETURNING' CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C Now go read another message. GOTO 1 C EOF ON ATTEMPTED READ C --------------------- 200 CALL WTSTAT(LUNIT,LUN,IL,0) INODE(LUN) = 0 IDATE(LUN) = 0 SUBSET = ' ' JDATE = 0 IRET = -1 RETURN C EXITS C ----- 900 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: READMG - ERROR READING A BUFR MESSAGE') END ./readmm.f0000644001370400056700000000643413440555365011406 0ustar jator2emc SUBROUTINE READMM(IMSG,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READMM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 C C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR BUFR MESSAGE FROM C INTERNAL MEMORY (ARRAY MSGS IN MODULE MSGMEM) INTO A MESSAGE C BUFFER (ARRAY MBAY IN MODULE BITBUF). IT IS IDENTICAL C TO BUFR ARCHIVE LIBRARY SUBROUTINE RDMEMM EXCEPT IT ADVANCES C THE VALUE OF IMSG BY ONE PRIOR TO RETURNING TO CALLING PROGRAM. C C PROGRAM HISTORY LOG: C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2009-03-23 J. ATOR -- REWROTE TO CALL RDMEMM C C USAGE: CALL READMM (IMSG, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C C OUTPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = IMSG is either zero or greater than the C number of messages in memory C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: RDMEMM C THIS ROUTINE IS CALLED BY: IREADMM C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) IMSG = IMSG+1 RETURN END ./readns.f0000644001370400056700000000674313440555365011420 0ustar jator2emc SUBROUTINE READNS(LUNIT,SUBSET,JDATE,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READNS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS THE NEXT C SUBSET FROM LOGICAL UNIT NUMBER LUNIT INTO INTERNAL SUBSET ARRAYS. C BUFR MESSAGES IN LUNIT MAY BE EITHER COMPRESSED OR UNCOMPRESSED. C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY C SUBROUTINES READMG AND READSB. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL READNS (LUNIT, SUBSET, JDATE, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE C CONTAINING SUBSET BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE CONTAINING SUBSET BEING READ, IN FORMAT OF C EITHER YYMMDDHH OR YYYYMMDDHH, DEPENDING ON DATELEN() C VALUE C IREADNS - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the BUFR file C C REMARKS: C THIS ROUTINE CALLS: BORT READMG READSB STATUS C THIS ROUTINE IS CALLED BY: IREADNS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C REFRESH THE SUBSET AND JDATE PARAMETERS C --------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 SUBSET = TAG(INODE(LUN)) JDATE = IDATE(LUN) C READ THE NEXT SUBSET IN THE BUFR FILE C ------------------------------------- 1 CALL READSB(LUNIT,IRET) IF(IRET.NE.0) THEN CALL READMG(LUNIT,SUBSET,JDATE,IRET) IF(IRET.EQ.0) GOTO 1 ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: READNS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') END ./reads3.f0000644001370400056700000001142313440555365011314 0ustar jator2emc SUBROUTINE READS3 ( LUN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READS3 C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE READS THE SECTION 3 DESCRIPTORS FROM THE C BUFR MESSAGE IN MBAY(1,LUN). IT THEN USES THE BUFR MASTER TABLES C TO GENERATE THE NECESSARY INFORMATION FOR THESE DESCRIPTORS WITHIN C THE INTERNAL BUFR TABLE ARRAYS. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2017-10-13 J. ATOR -- REMOVE FUNCTIONALITY TO CHECK WHETHER NEW C MASTER TABLES NEED TO BE READ (THIS C FUNCTIONALITY IS NOW PART OF FUNCTION C IREADMT) C C USAGE: CALL READS3 ( LUN ) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT DXINIT ERRWRT C IFXY IGETNTBI IGETTDI IREADMT C MAKESTAB STNTBIA STSEQ UPDS3 C THIS ROUTINE IS CALLED BY: READERME READMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_SC3BFR USE MODA_BITBUF INCLUDE 'bufrlib.prm' COMMON /QUIET/ IPRT COMMON /DSCACH/ NCNEM,CNEM(MXCNEM),NDC(MXCNEM), . IDCACH(MXCNEM,MAXNC) DIMENSION IDS3(MAXNC) CHARACTER*6 CDS3(MAXNC),NUMB,ADN30 CHARACTER*8 CNEM CHARACTER*55 CSEQ CHARACTER*128 ERRSTR LOGICAL INCACH SAVE IREPCT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C* Check whether the appropriate BUFR master table information has C* already been read into internal memory for this message. IF ( IREADMT ( LUN ) .EQ. 1 ) THEN C* NO (i.e. we just had to read in new master table information C* for this message), so reset some corresponding values in C* other parts of the library. CALL DXINIT ( LUN, 0 ) ITMP = IGETTDI ( 0 ) IREPCT = 0 NCNEM = 0 ENDIF C* Unpack the list of Section 3 descriptors from the message. CALL UPDS3 ( MBAY(1,LUN), MAXNC, CDS3, NCDS3 ) DO II = 1, NCDS3 IDS3(II) = IFXY( CDS3(II) ) ENDDO C* Is the list of Section 3 descriptors already in the cache? C* The cache is a performance-enhancing device which saves C* time when the same descriptor sequences are encountered C* over and over within the calling program. Time is saved C* because the below calls to subroutines STSEQ and MAKESTAB C* are bypassed whenever a list is already in the cache. INCACH = .FALSE. IF ( NCNEM .GT. 0 ) THEN II = 1 DO WHILE ( (.NOT.INCACH) .AND. (II.LE.NCNEM) ) IF ( NCDS3 .EQ. NDC(II) ) THEN JJ = 1 INCACH = .TRUE. DO WHILE ( (INCACH) .AND. (JJ.LE.NCDS3) ) IF ( IDS3(JJ) .EQ. IDCACH(II,JJ) ) THEN JJ = JJ + 1 ELSE INCACH = .FALSE. ENDIF ENDDO IF (INCACH) THEN C* The list is already in the cache, so store the C* corresponding Table A mnemonic into MODULE SC3BFR C* and return. IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') ERRSTR = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // CNEM(II) CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF TAMNEM(LUN) = CNEM(II) RETURN ENDIF ENDIF II = II + 1 ENDDO ENDIF C* Get the next available index within the internal Table A. N = IGETNTBI ( LUN, 'A' ) C* Generate a Table A mnemonic and sequence description. WRITE ( TAMNEM(LUN), '(A5,I3.3)') 'MSTTB', N CSEQ = 'TABLE A MNEMONIC ' // TAMNEM(LUN) C* Store the Table A mnemonic and sequence into the cache. NCNEM = NCNEM + 1 IF ( NCNEM .GT. MXCNEM ) GOTO 900 CNEM(NCNEM) = TAMNEM(LUN) NDC(NCNEM) = NCDS3 DO JJ = 1, NCDS3 IDCACH(NCNEM,JJ) = IDS3(JJ) ENDDO IF ( IPRT .GE. 2 ) THEN CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') ERRSTR = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' // . CNEM(NCNEM) CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C* Get an FXY value to use with this Table A mnemonic. IDN = IGETTDI ( LUN ) NUMB = ADN30 ( IDN, 6 ) C* Store all of the information for this mnemonic within the C* internal Table A. CALL STNTBIA ( N, LUN, NUMB, TAMNEM(LUN), CSEQ ) C* Store all of the information for this sequence within the C* internal Tables B and D. CALL STSEQ ( LUN, IREPCT, IDN, TAMNEM(LUN), CSEQ, IDS3, NCDS3 ) C* Update the jump/link table. CALL MAKESTAB RETURN 900 CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW') END ./readsb.f0000644001370400056700000001115013440555365011370 0ustar jator2emc SUBROUTINE READSB(LUNIT,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: READSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT READS A SUBSET FROM C A BUFR MESSAGE INTO INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE MUST C HAVE BEEN PREVIOUSLY READ FROM UNIT LUNIT USING BUFR ARCHIVE C LIBRARY SUBROUTINE READMG OR READERME AND MAY BE EITHER COMPRESSED C OR UNCOMPRESSED. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- ADDED CALL TO NEW ROUTINE RDCMPS ALLOWING C SUBSETS TO NOW BE DECODED FROM COMPRESSED C BUFR MESSAGES; MAXIMUM MESSAGE LENGTH C INCREASED FROM 10,000 TO 20,000 BYTES C 2002-05-14 J. WOOLLEN -- CORRECTED ERROR RELATING TO CERTAIN C FOREIGN FILE TYPES; REMOVED OLD CRAY C COMPILER DIRECTIVES 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 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL READSB (LUNIT, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the BUFR C message C C REMARKS: C THIS ROUTINE CALLS: BORT RDCMPS RDTREE STATUS C UPB C THIS ROUTINE IS CALLED BY: COPYSB IREADSB RDMEMS READNS C RDMSGB UFBINX UFBPOS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_UNPTYP USE MODA_BITBUF USE MODA_BITMAPS INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) THEN IRET = -1 GOTO 100 ENDIF C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- IF(NSUB(LUN).EQ.MSUB(LUN)) THEN IRET = -1 GOTO 100 ELSE NSUB(LUN) = NSUB(LUN) + 1 ENDIF C READ THE NEXT SUBSET AND RESET THE POINTERS C ------------------------------------------- NBTM = 0 LSTNOD = 0 LSTNODCT = 0 LINBTM = .FALSE. IF(MSGUNP(LUN).EQ.0) THEN IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) CALL RDTREE(LUN,IER) IF(IER.NE.0) THEN IRET = -1 GOTO 100 ENDIF MBYT(LUN) = MBYT(LUN) + NBYT ELSEIF(MSGUNP(LUN).EQ.1) THEN c .... message with "standard" Section 3 IBIT = MBYT(LUN) CALL RDTREE(LUN,IER) IF(IER.NE.0) THEN IRET = -1 GOTO 100 ENDIF MBYT(LUN) = IBIT ELSEIF(MSGUNP(LUN).EQ.2) THEN c .... compressed message CALL RDCMPS(LUN) ELSE GOTO 902 ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: READSB - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 WRITE(BORT_STR,'("BUFRLIB: READSB - MESSAGE UNPACK TYPE",I3,"IS'// . ' NOT RECOGNIZED")') MSGUNP CALL BORT(BORT_STR) END ./restd.c0000644001370400056700000001074013440555365011252 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RESTD C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A LOCAL C (I.E. NON-STANDARD) TABLE D DESCRIPTOR, THIS ROUTINE RETURNS C AN EQUIVALENT LIST OF STANDARDIZED CHILD DESCRIPTORS. ANY CHILD C DESCRIPTORS WHICH ARE THEMSELVES LOCAL TABLE D DESCRIPTORS ARE C AUTOMATICALLY RESOLVED VIA A RECURSIVE CALL TO THIS SAME ROUTINE. C THE RECURSIVE PROCESS CONTINUES UNTIL ALL CHILD DESCRIPTORS ARE C EITHER WMO-STANDARD DESCRIPTORS (I.E. FROM TABLE B, TABLE C, OR C TABLE D, OR REPLICATION DESCRIPTORS) OR ELSE ARE LOCAL TABLE B C DESCRIPTORS, IN WHICH CASE THEY ARE PRECEDED WITH AN APPROPRIATE C 206YYY TABLE C OPERATOR IN THE OUTPUT LIST. IN ANY EVENT, THE C FINAL OUTPUT LIST OF EQUIVALENT CHILD DESCRIPTORS IS USABLE BY C ANY STANDARD BUFR DECODER PROGRAM IN ORDER TO INTERPRET THE SAME C DATA VALUES AS WERE REPRESENTED BY THE INITIAL LOCAL TABLE D C DESCRIPTOR THAT WAS INPUT. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C 2012-04-30 J. ATOR -- USE LONG CAST FOR IBIT IN SPRINTF STMT C C USAGE: CALL RESTD( LUN, TDDESC, NCTDDESC, CTDDESC ) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C TDDESC - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR C LOCAL TABLE D DESCRIPTOR C C OUTPUT ARGUMENT LIST: C NCTDDESC - INTEGER: NUMBER OF STANDARDIZED CHILD DESCRIPTORS C RETURNED IN CTDDESC C CTDDESC - INTEGER: ARRAY OF STANDARDIZED CHILD DESCRIPTORS C C REMARKS: C THIS ROUTINE CALLS: RESTD NUMTBD NEMTBB IFXY C CADN30 ISTDESC WRDESC UPTDD C THIS ROUTINE IS CALLED BY: RESTD STNDRD C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" void restd( f77int *lun, f77int *tddesc, f77int *nctddesc, f77int ctddesc[] ) { f77int i0 = 0; f77int desc, ncdesc, cdesc[MAXNC]; f77int i, j, inum, itbd, ictbd; f77int iscl, iref, ibit; char tab, nemo[9], adn[7], cunit[25]; /* ** How many child descriptors does *tddesc have? */ numtbd( lun, tddesc, nemo, &tab, &itbd, 9, 1 ); uptdd( &itbd, lun, &i0, &inum ); *nctddesc = 0; /* ** Examine each child descriptor one at a time. */ for ( i = 1; i <= inum; i++ ) { uptdd( &itbd, lun, &i, &desc ); if (! istdesc( &desc ) ) { /* ** desc is a local descriptor. */ numtbd( lun, &desc, nemo, &tab, &ictbd, 9, 1 ); if ( tab == 'D' ) { /* ** desc is itself a local Table D descriptor, so resolve ** it now via a recursive call to this same routine. */ restd( lun, &desc, &ncdesc, cdesc ); if ( ( *nctddesc > 0 ) && ( ctddesc[(*nctddesc)-1] > ifxy( "101000", 6 ) ) && ( ctddesc[(*nctddesc)-1] <= ifxy( "101255", 6 ) ) ) { /* ** desc is replicated using fixed replication, so write ** the number of child descriptors into the X value of ** the replication descriptor ctddesc[(*nctddesc)-1] */ cadn30( &ctddesc[(*nctddesc)-1], adn, 7 ); sprintf( adn, "%c%02ld%c%c%c", adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); ctddesc[(*nctddesc)-1] = ifxy( adn, 7 ); } else if ( ( *nctddesc > 1 ) && ( ctddesc[(*nctddesc)-2] == ifxy( "101000", 6 ) ) ) { /* ** desc is replicated using delayed replication, so write ** the number of child descriptors into the X value of ** the replication descriptor ctddesc[(*nctddesc)-2] */ cadn30( &ctddesc[(*nctddesc)-2], adn, 7 ); sprintf( adn, "%c%02ld%c%c%c", adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); ctddesc[(*nctddesc)-2] = ifxy( adn, 7 ); } /* ** Add the child descriptors to the output list. */ for ( j = 0; j < ncdesc; j++ ) { wrdesc( cdesc[j], ctddesc, nctddesc ); } } else if ( tab == 'B' ) { /* ** desc is a local Table B descriptor, so precede it with ** a 206YYY operator in the output list. */ nemtbb( lun, &ictbd, cunit, &iscl, &iref, &ibit, 25 ); sprintf( adn, "%c%c%c%03ld", '2', '0', '6', (long) ibit ); wrdesc( ifxy( adn, 7 ), ctddesc, nctddesc ); wrdesc( desc, ctddesc, nctddesc ); } } else { /* ** desc is a standard Table B, Table D, operator or replicator ** descriptor, so append it "as is" to the output list. */ wrdesc( desc, ctddesc, nctddesc ); } } return; } ./rewnbf.f0000644001370400056700000001420213440555365011414 0ustar jator2emc SUBROUTINE REWNBF(LUNIT,ISR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: REWNBF C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL C EITHER: C 1) STORE THE CURRENT PARAMETERS ASSOCIATED WITH A BUFR FILE C CONNECTED TO LUNIT (READ/WRITE POINTERS, ETC.), SET THE FILE STATUS C TO READ, THEN REWIND THE BUFR FILE AND POSITION IT SUCH THAT THE C NEXT BUFR MESSAGE READ WILL BE THE FIRST MESSAGE IN THE FILE C CONTAINING ACTUAL SUBSETS WITH DATA; OR C 2) RESTORE THE BUFR FILE CONNECTED TO LUNIT TO THE PARAMETERS C IT HAD PRIOR TO 1) ABOVE USING THE INFORMATION SAVED IN 1) ABOVE. C C THIS ALLOWS INFORMATION TO BE EXTRACTED FROM A PARTICULAR SUBSET IN C A BUFR FILE WHICH IS IN THE MIDST OF BEING READ FROM OR WRITTEN TO C BY AN APPLICATION PROGRAM. NOTE THAT FOR A PARTICULAR BUFR FILE 1) C ABOVE MUST PRECEDE 2) ABOVE. AN APPLICATION PROGRAM MIGHT FIRST C CALL THIS SUBROUTINE WITH ISR = 0, THEN CALL EITHER BUFR ARCHIVE C LIBRARY SUBROUTINE RDMGSB OR UFBINX TO GET INFO FROM A SUBSET, THEN C CALL THIS ROUTINE AGAIN WITH ISR = 1 TO RESTORE THE POINTERS IN THE C BUFR FILE TO THEIR ORIGINAL LOCATION. ALSO, BUFR ARCHIVE LIBRARY C SUBROUTINE UFBTAB WILL CALL THIS ROUTINE IF THE BUFR FILE IT IS C ACTING UPON IS ALREADY OPEN FOR INPUT OR OUTPUT. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION C VERSION AT ONE TIME AND THEN REMOVED) C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE C (DICTIONARY) MESSAGES C 2011-09-26 J. WOOLLEN -- FIXED BUG TO PREVENT SKIP OF FIRST DATA C MESSAGE AFTER REWIND C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C REPLACE FORTRAN REWIND WITH C CEWIND C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL REWNBF (LUNIT, ISR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C ISR - INTEGER: SWITCH: C 0 = store current parameters associated with C BUFR file, set file status to read, rewind C file such that next message read is first C message containing subset data C 1 = restore BUFR file with parameters saved C from the previous call to this routine with C ISR=0 C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT I4DY READMG STATUS C WTSTAT CEWIND C THIS ROUTINE IS CALLED BY: UFBINX UFBTAB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF USE MODA_BUFRSR INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C TRY TO TRAP BAD CALL PROBLEMS C ----------------------------- IF(ISR.EQ.0) THEN CALL STATUS(LUNIT,LUN,IL,IM) IF(JSR(LUN).NE.0) GOTO 900 IF(IL.EQ.0) GOTO 901 ELSEIF(ISR.EQ.1) THEN LUN = JUNN IF(JSR(JUNN).NE.1) GOTO 902 ELSE GOTO 903 ENDIF C STORE FILE PARAMETERS AND SET FOR READING C ----------------------------------------- IF(ISR.EQ.0) THEN JUNN = LUN JILL = IL JIMM = IM JBIT = IBIT JBYT = MBYT(LUN) JMSG = NMSG(LUN) JSUB = NSUB(LUN) KSUB = MSUB(LUN) JNOD = INODE(LUN) JDAT = IDATE(LUN) DO I=1,JBYT JBAY(I) = MBAY(I,LUN) ENDDO CALL WTSTAT(LUNIT,LUN,-1,0) ENDIF C REWIND THE FILE C --------------- CALL CEWIND(LUN) C RESTORE FILE PARAMETERS AND POSITION IT TO WHERE IT WAS SAVED C ------------------------------------------------------------- IF(ISR.EQ.1) THEN LUN = JUNN IL = JILL IM = JIMM IBIT = JBIT MBYT(LUN) = JBYT NMSG(LUN) = JMSG NSUB(LUN) = JSUB MSUB(LUN) = KSUB INODE(LUN) = JNOD IDATE(LUN) = I4DY(JDAT) DO I=1,JBYT MBAY(I,LUN) = JBAY(I) ENDDO DO IMSG=1,JMSG CALL READMG(LUNIT,SUBSET,KDATE,IER) IF(IER.LT.0) GOTO 905 ENDDO CALL WTSTAT(LUNIT,LUN,IL,IM) ENDIF JSR(LUN) = MOD(JSR(LUN)+1,2) C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// . 'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED '// . '(AND NOT YET RESTORED) (UNIT",I3,")")') LUNIT CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// . 'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT'// . ' OR OUTPUT) (UNIT",I3,")")') LUNIT CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// . 'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') . LUNIT CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// . 'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') . ISR,LUNIT CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// . 'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE '// . 'NO.",I5)') LUNIT,JMSG CALL BORT(BORT_STR) END ./rjust.f0000644001370400056700000000273213440555365011305 0ustar jator2emc FUNCTION RJUST(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RJUST C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION RIGHT JUSTIFIES A CHARACTER STRING. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C USAGE: RJUST (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING TO BE RIGHT-JUSTIFED C C OUTPUT ARGUMENT LIST: C STR - CHARACTER*(*): RIGHT-JUSTIFIED STRING C RJUST - REAL: ALWAYS RETURNED AS 0 (DUMMY) C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: SNTBBE UFBDMP UFDUMP VALX C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR RJUST = 0. IF(STR.EQ.' ') GOTO 100 LSTR = LEN(STR) DO WHILE(STR(LSTR:LSTR).EQ.' ') DO I=LSTR,2,-1 STR(I:I) = STR(I-1:I-1) ENDDO STR(1:1) = ' ' ENDDO C EXIT C ---- 100 RETURN END ./rsvfvm.f0000644001370400056700000000357313440555365011465 0ustar jator2emc SUBROUTINE RSVFVM(NEM1,NEM2) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RSVFVM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE STEPS THROUGH THE "FOLLOWING VALUE" C MNEMONIC NEM1 AND, FOR EACH "." CHARACTER ENCOUNTERED (EXCEPT FOR C THE INITIAL ONE), OVERWRITES IT WITH THE NEXT CORRESPONDING C CHARACTER FROM NEM2 (SEE REMARKS). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C C USAGE: CALL RSVFVM (NEM1, NEM2) C INPUT ARGUMENT LIST: C NEM1 - CHARACTER*8: "FOLLOWING VALUE" MNEMONIC C NEM2 - CHARACTER*8: MNEMONIC IMMEDIATELY FOLLOWING NEM1 C WITHIN USER DICTIONARY TABLE C C OUTPUT ARGUMENT LIST: C NEM1 - CHARACTER*8: COPY OF INPUT NEM1 WITH ALL "." C CHARACTERS (EXCEPT INITIAL ONE) OVERWRITTEN WITH C CORRESPONDING CHARACTERS FROM NEM2 C C REMARKS: C FOR EXAMPLE: C if, on input: NEM1 = ".DTH...." C NEM2 = "MXTM " C then, on output: NEM1 = ".DTHMXTM" C C C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: NEMTBD SEQSDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*8 NEM1,NEM2 DO I=1,LEN(NEM1) IF(I.EQ.1) THEN C Skip initial "." and initialize J. J = 1 ELSE IF(NEM1(I:I).EQ.'.') THEN NEM1(I:I) = NEM2(J:J) J = J+1 ENDIF ENDIF ENDDO RETURN END ./rtrcptb.f0000644001370400056700000000417213440555365011616 0ustar jator2emc SUBROUTINE RTRCPTB(MBAY,IYR,IMO,IDY,IHR,IMI,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RTRCPTB C PRGMMR: ATOR ORG: NP12 DATE: 2013-10-07 C C ABSTRACT: THIS SUBROUTINE RETURNS THE TANK RECEIPT TIME STORED WITHIN C SECTION 1 OF THE BUFR MESSAGE IN ARRAY MBAY. C C PROGRAM HISTORY LOG: C 2013-10-07 J. ATOR -- ADAPTED FROM RTRCPT C C USAGE: CALL RTRCPT (MBAY,IYR,IMO,IDY,IHR,IMI,IRET) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR MESSAGE C C OUTPUT ARGUMENT LIST: C IYR - INTEGER: TANK RECEIPT YEAR C IMO - INTEGER: TANK RECEIPT MONTH C IDY - INTEGER: TANK RECEIPT DAY C IHR - INTEGER: TANK RECEIPT HOUR C IMI - INTEGER: TANK RECEIPT MINUTE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = no tank receipt time was present within MBAY C C REMARKS: C THIS ROUTINE CALLS: IUPB IUPBS01 C THIS ROUTINE IS CALLED BY: RTRCPT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' DIMENSION MBAY (*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = -1 C Check whether the message contains a tank receipt time. IF(IUPBS01(MBAY,'BEN').EQ.4) THEN IS1BYT = 23 ELSE IS1BYT = 19 ENDIF IF( (IS1BYT+5) .GT. IUPBS01(MBAY,'LEN1') ) RETURN C Unpack the tank receipt time. C Note that IS1BYT is a starting byte number relative to the C beginning of Section 1, so we still need to account for C Section 0 when specifying the actual byte numbers to unpack C within the overall message. IMGBYT = IS1BYT + IUPBS01(MBAY,'LEN0') IYR = IUPB(MBAY,IMGBYT,16) IMO = IUPB(MBAY,IMGBYT+2,8) IDY = IUPB(MBAY,IMGBYT+3,8) IHR = IUPB(MBAY,IMGBYT+4,8) IMI = IUPB(MBAY,IMGBYT+5,8) IRET = 0 RETURN END ./rtrcpt.f0000644001370400056700000000440313440555365011451 0ustar jator2emc SUBROUTINE RTRCPT(LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: RTRCPT C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE RETURNS THE TANK RECEIPT TIME STORED WITHIN C SECTION 1 OF THE BUFR MESSAGE OPEN FOR INPUT VIA A PREVIOUS CALL TO C BUFR ARCHIVE LIBRARY SUBROUTINE READMG, READMM OR EQUIVALENT. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2013-10-07 J. ATOR -- MODIFIED TO CALL RTRCPTB C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL RTRCPT (LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C IYR - INTEGER: TANK RECEIPT YEAR C IMO - INTEGER: TANK RECEIPT MONTH C IDY - INTEGER: TANK RECEIPT DAY C IHR - INTEGER: TANK RECEIPT HOUR C IMI - INTEGER: TANK RECEIPT MINUTE C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = no tank receipt time was present within the C BUFR message currently open for input C C REMARKS: C THIS ROUTINE CALLS: BORT RTRCPTB STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BITBUF INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Check the file status. CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C Unpack the tank receipt time. CALL RTRCPTB(MBAY(1,LUN),IYR,IMO,IDY,IHR,IMI,IRET) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT; IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE; NONE ARE') END ./seqsdx.f0000644001370400056700000002462413440555365011451 0ustar jator2emc SUBROUTINE SEQSDX(CARD,LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SEQSDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION C FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A C USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY BUFR C ARCHIVE LIBRARY SUBROUTINE RDUSDX. THESE ARE THEN ADDED TO THE C ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX) WITHIN C THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN MODULE TABABD. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C C USAGE: CALL SEQSDX (CARD, LUN) C INPUT ARGUMENT LIST: C CARD - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ C FROM A USER-SUPPLIED BUFR DICTIONARY TABLE C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT2 NEMOCK NEMTAB C NUMTAB PARSTR PKTDD RSVFVM C STRNUM C THIS ROUTINE IS CALLED BY: RDUSDX C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*80 CARD,SEQS CHARACTER*12 ATAG,TAGS(250) CHARACTER*8 NEMO,NEMA,NEMB CHARACTER*6 ADN30,CLEMON CHARACTER*3 TYPS CHARACTER*1 REPS,TAB DATA MAXTGS /250/ DATA MAXTAG /12/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING C -------------------------------------------------------------- NEMO = CARD( 3:10) SEQS = CARD(14:78) C Note that an entry for this mnemonic should already exist within C the internal BUFR Table D array TABD(*,LUN); this entry should C have been created by subroutine RDUSDX when the mnemonic and its C associated FXY value and description were initially defined C within a card read from the "Descriptor Definition" section at C the top of the user-supplied BUFR dictionary table in character C format. Now, we need to retrieve the positional index for that C entry within TABD(*,LUN) so that we can access the entry and then C add the decoded sequence information to it. CALL NEMTAB(LUN,NEMO,IDN,TAB,ISEQ) IF(TAB.NE.'D') GOTO 900 CALL PARSTR(SEQS,TAGS,MAXTGS,NTAG,' ',.TRUE.) IF(NTAG.EQ.0 ) GOTO 901 DO N=1,NTAG ATAG = TAGS(N) IREP = 0 C CHECK FOR REPLICATOR C -------------------- DO I=1,5 IF(ATAG(1:1).EQ.REPS(I,1)) THEN C Note that REPS(*,*), which contains all of the symbols used to C denote all of the various replication schemes that are C possible within a user-supplied BUFR dictionary table in C character format, was previously defined within subroutine C BFRINI. DO J=2,MAXTAG IF(ATAG(J:J).EQ.REPS(I,2)) THEN IF(J.EQ.MAXTAG) GOTO 902 C Note that subroutine STRNUM will return NUMR = 0 if the C string passed to it contains all blanks (as *should* be the C case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or C 5 '<' '>'). C However, when I = 1 '"' '"', then subroutine STRNUM will C return NUMR = (the number of replications for the mnemonic C using F=1 "regular" (i.e. non-delayed) replication). CALL STRNUM(ATAG(J+1:MAXTAG),NUMR) IF(I.EQ.1 .AND. NUMR.LE.0 ) GOTO 903 IF(I.EQ.1 .AND. NUMR.GT.255) GOTO 904 IF(I.NE.1 .AND. NUMR.NE.0 ) GOTO 905 ATAG = ATAG(2:J-1) IREP = I GOTO 1 ENDIF ENDDO GOTO 902 ENDIF ENDDO C CHECK FOR VALID TAG C ------------------- 1 IRET=NEMOCK(ATAG) IF(IRET.EQ.-1) GOTO 906 IF(IRET.EQ.-2) GOTO 907 CALL NEMTAB(LUN,ATAG,IDN,TAB,IRET) IF(IRET.GT.0) THEN C Note that the next code line checks that we are not trying to C replicate a Table B mnemonic (which is currently not allowed). C The logic works because, for replicated mnemonics, IREP = I = C (the index within REPS(*,*) of the symbol associated with the C type of replication in question (e.g. "{, "<", etc.)) IF(TAB.EQ.'B' .AND. IREP.NE.0) GOTO 908 IF(ATAG(1:1).EQ.'.') THEN C This mnemonic is a "following value" mnemonic C (i.e. it relates to the mnemonic that immediately C follows it within the user-supplied character-format BUFR C dictionary table sequence), so confirm that it contains, as C a substring, this mnemonic that immediately follows it. NEMB = TAGS(N+1) c .... get NEMA from IDN CALL NUMTAB(LUN,IDN,NEMA,TAB,ITAB) CALL NEMTAB(LUN,NEMB,JDN,TAB,IRET) CALL RSVFVM(NEMA,NEMB) IF(NEMA.NE.ATAG) GOTO 909 c .... DK: I don't think the next test can ever be satisfied c .... should probably be IF(N.EQ.NTAG ) GOTO 910 IF(N.GT.NTAG ) GOTO 910 IF(TAB.NE.'B') GOTO 911 ENDIF ELSE GOTO 912 ENDIF C WRITE THE DESCRIPTOR STRING INTO TABD ARRAY C ------------------------------------------- c .... first look for a replication descriptor IF(IREP.GT.0) CALL PKTDD(ISEQ,LUN,IDNR(IREP,1)+NUMR,IRET) IF(IRET.LT.0) GOTO 913 CALL PKTDD(ISEQ,LUN,IDN,IRET) IF(IRET.LT.0) GOTO 914 ENDDO C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '// . '(UNDEFINED, TAB=",A,")")') NEMO,TAB CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') NEMO CALL BORT2(BORT_STR1,BORT_STR2) 902 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) 903 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'// . ' 2ND QUOTE")') NEMO,TAGS(N),NUMR CALL BORT2(BORT_STR1,BORT_STR2) 904 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '// . '255")') NEMO,TAGS(N),NUMR CALL BORT2(BORT_STR1,BORT_STR2) 905 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'// . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'// . 'NO")') NEMO,TAGS(N),NUMR CALL BORT2(BORT_STR1,BORT_STR2) 906 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")') . NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) 907 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) 908 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")') . NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) 909 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '// . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")') . NEMO,TAGS(N),NEMA CALL BORT2(BORT_STR1,BORT_STR2) 910 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '// . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '// . 'STRING")') NEMO,NEMA CALL BORT2(BORT_STR1,BORT_STR2) 911 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'// . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '// . 'ENTRY")') NEMO,NEMB CALL BORT2(BORT_STR1,BORT_STR2) 912 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'// . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")') . NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) 913 CLEMON = ADN30(IDNR(IREP,1)+NUMR,6) WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '// . 'WARNING MSG")') NEMO,CLEMON CALL BORT2(BORT_STR1,BORT_STR2) 914 WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '// . 'WARNING MSG")') NEMO,TAGS(N) CALL BORT2(BORT_STR1,BORT_STR2) END ./setblock.f0000644001370400056700000000235013440555365011740 0ustar jator2emc SUBROUTINE SETBLOCK(IBLK) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SETBLOCK C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 C C ABSTRACT: SUBROUTINE SETBLOCK ALLOWS APPLICATIONS TO DEFINE WHAT C SORT OF OUTPUT FILE BLOCKING (IEEE RECORD CONTROL WORDS) C ARE APPLIED TO BUFR RECORDS WRITTEN FROM THE BUFRLIB C ROUTINES. THE DEFAULT IS NONE (PURE BUFR). OTHER OPTIONS C ARE BIG OR LITTLE ENDIAN. C C PROGRAM HISTORY LOG: C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR C C USAGE: CALL SETBLOCK(IBLK) C C INPUT ARGUMENTS: C IBLK - INTEGER BLOCK TYPE INDICATOR C -1 LITTLE ENDIAN RECORD CONTROL WORDS C 0 NO RECORD CONTROL WORDS (PURE BUFR) C 1 BIG ENDIAN RECORD CONTROL WORDS C C OUTPUT ARGUMENTS: C C REMARKS: C THIS ROUTINE CALLS: OPENBF C C THIS ROUTINE IS CALLED BY: USER C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /ENDORD/ IBLOCK,IORDBE(4),IORDLE(4) c----------------------------------------------------------------------- c----------------------------------------------------------------------- CALL OPENBF(0,'FIRST',0) IBLOCK=IBLK RETURN END ./setbmiss.f0000644001370400056700000000225513440555365011767 0ustar jator2emc SUBROUTINE SETBMISS(XMISS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SETBMISS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-09-15 C C ABSTRACT: SETBMISS WILL ALLOW AN APPLICATION TO DEFINE THE SPECIAL C VALUE "BMISS" WHICH DENOTES MISSING VALUES BOTH FOR READING C FROM BUFR FILES AND FOR WRITING TO BUFR FILES. THE DEFAULT C BUFRLIB MISSING VALUE IS SET TO 10E10 IN SUBROUTINE BFRINI. C C PROGRAM HISTORY LOG: C 2012-09-15 J. WOOLLEN -- ORIGINAL AUTHOR C C USAGE: CALL SETBMISS(XMISS) C C INPUT ARGUMENTS: C XMISS - REAL*8 MISSING VALUE TO BE USED C C OUTPUT ARGUMENTS: C C REMARKS: C THIS ROUTINE CALLS: OPENBF C C THIS ROUTINE IS CALLED BY: None C (Normally called only by application C programs) C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' REAL*8 XMISS c----------------------------------------------------------------------- c----------------------------------------------------------------------- CALL OPENBF(0,'FIRST',0) BMISS = XMISS RETURN END ./setvalnb.f0000644001370400056700000000704413440555365011755 0ustar jator2emc SUBROUTINE SETVALNB ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB, . R8VAL, IRET ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SETVALNB C PRGMMR: J. ATOR ORG: NCEP DATE: 2016-07-29 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN A BUFR FILE IS C OPENED FOR OUTPUT, AND A SUBSET DEFINITION MUST ALREADY BE IN SCOPE C VIA A PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENMB OR C EQUIVALENT. THE FUNCTION WILL FIRST SEARCH FOR THE (NTAGPV)th C OCCURRENCE OF MNEMONIC TAGPV WITHIN THE OVERALL SUBSET DEFINITION, C COUNTING FROM THE BEGINNING OF THE SUBSET. IF FOUND, IT WILL THEN C SEARCH FORWARD (IF NTAGNB IS POSITIVE) OR BACKWARD (IF NTAGNB IS C NEGATIVE) FROM THAT POINT WITHIN THE SUBSET FOR THE (NTAGNB)th C OCCURRENCE OF MNEMONIC TAGNB AND STORE R8VAL AS THE VALUE C CORRESPONDING TO THAT MNEMONIC. C C PROGRAM HISTORY LOG: C 2016-07-29 J. ATOR -- ORIGINAL AUTHOR; BASED ON GETVALNB C C USAGE: CALL SETVALNB (LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB, C R8VAL, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C TAGPV - CHARACTER*(*): PIVOT MNEMONIC; THE FUNCTION WILL C FIRST SEARCH FOR the (NTAGPV)th OCCURRENCE OF THIS C MNEMONIC, COUNTING FROM THE BEGINNING OF THE OVERALL C SUBSET DEFINITION C NTAGPV - INTEGER: ORDINAL OCCURRENCE OF TAGPV TO SEARCH FOR C TAGNB - CHARACTER*(*): NEARBY MNEMONIC; ASSUMING TAGPV IS C SUCCESSFULLY FOUND, THE FUNCTION WILL THEN SEARCH C NEARBY FOR THE (NTAGNB)th OCCURRENCE OF TAGNB AND C STORE R8VAL AS THE CORRESPONDING VALUE C NTAGNB - INTEGER: ORDINAL OCCURRENCE OF TAGNB TO SEARCH FOR, C COUNTING FROM THE LOCATION OF TAGPV WITHIN THE OVERALL C SUBSET DEFINITION. IF NTAGNB IS POSITIVE, THE FUNCTION C WILL SEARCH IN A FORWARD DIRECTION FROM THE LOCATION OF C TAGPV, OR IF NTAGNB IS NEGATIVE IT WILL INSTEAD SEARCH C IN A BACKWARDS DIRECTION. C R8VAL - REAL*8: VALUE TO BE STORED CORRESPONDING TO (NTAGNB)th C OCCURRENCE OF TAGNB. C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE C 0 = NORMAL RETURN C -1 = (NTAGNB)th OCCURENCE OF MNEMONIC TAGNB COULD C NOT BE FOUND, OR SOME OTHER ERROR OCCURRED C C REMARKS: C THIS ROUTINE CALLS: FSTAG STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*(*) TAGPV, TAGNB REAL*8 R8VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = -1 C Get LUN from LUNIT. CALL STATUS (LUNIT, LUN, IL, IM ) IF ( IL .LE. 0 ) RETURN IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN C Starting from the beginning of the subset, locate the (NTAGPV)th C occurrence of TAGPV. CALL FSTAG( LUN, TAGPV, NTAGPV, 1, NPV, IERFT ) IF ( IERFT .NE. 0 ) RETURN C Now, starting from the (NTAGPV)th occurrence of TAGPV, search C forward or backward for the (NTAGNB)th occurrence of TAGNB. CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IERFT ) IF ( IERFT .NE. 0 ) RETURN IRET = 0 VAL(NNB,LUN) = R8VAL RETURN END ./sntbbe.f0000644001370400056700000001166713440555365011422 0ustar jator2emc SUBROUTINE SNTBBE ( IFXYN, LINE, MXMTBB, . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, . CMUNIT, CMMNEM, CMDSC, CMELEM ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SNTBBE C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE PARSES AN ENTRY THAT WAS PREVIOUSLY READ C FROM AN ASCII MASTER TABLE B FILE AND THEN STORES THE OUTPUT INTO C THE MERGED ARRAYS. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL SNTBBE ( IFXYN, LINE, MXMTBB, C NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, C CMUNIT, CMMNEM, CMDSC, CMELEM ) C INPUT ARGUMENT LIST: C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR C TABLE ENTRY; THIS FXY NUMBER IS THE ELEMENT DESCRIPTOR C LINE - CHARACTER*(*): TABLE ENTRY C MXMTBB - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN C MERGED MASTER TABLE B ARRAYS; THIS SHOULD BE THE SAME C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS C C OUTPUT ARGUMENT LIST: C NMTBB - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE B C ARRAYS C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF FXY NUMBERS (I.E. ELEMENT C DESCRIPTORS) C CMSCL(*) - CHARACTER*4: MERGED ARRAY CONTAINING SCALE FACTORS C CMSREF(*)- CHARACTER*12: MERGED ARRAY CONTAINING REFERENCE VALUES C CMBW(*) - CHARACTER*4: MERGED ARRAY CONTAINING BIT WIDTHS C CMUNIT(*)- CHARACTER*14: MERGED ARRAY CONTAINING UNITS C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES C CMELEM(*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES C C REMARKS: C THIS ROUTINE CALLS: BORT BORT2 JSTCHR NEMOCK C PARSTR RJUST C THIS ROUTINE IS CALLED BY: RDMTBB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) LINE CHARACTER*200 TAGS(10), WKTAG CHARACTER*128 BORT_STR1, BORT_STR2 CHARACTER*120 CMELEM(*) CHARACTER*14 CMUNIT(*) CHARACTER*12 CMSREF(*) CHARACTER*8 CMMNEM(*) CHARACTER*4 CMSCL(*), CMBW(*), CMDSC(*) INTEGER IMFXYN(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( NMTBB .GE. MXMTBB ) GOTO 900 NMTBB = NMTBB + 1 C Store the FXY number. This is the element descriptor. IMFXYN ( NMTBB ) = IFXYN C Parse the table entry. CALL PARSTR ( LINE, TAGS, 10, NTAG, '|', .FALSE. ) IF ( NTAG .LT. 4 ) THEN BORT_STR2 = ' HAS TOO FEW FIELDS' GOTO 901 ENDIF C Scale factor. CALL JSTCHR ( TAGS(2), IRET ) IF ( IRET .NE. 0 ) THEN BORT_STR2 = ' HAS MISSING SCALE FACTOR' GOTO 901 ENDIF CMSCL ( NMTBB ) = TAGS(2)(1:4) RJ = RJUST ( CMSCL ( NMTBB ) ) C Reference value. CALL JSTCHR ( TAGS(3), IRET ) IF ( IRET .NE. 0 ) THEN BORT_STR2 = ' HAS MISSING REFERENCE VALUE' GOTO 901 ENDIF CMSREF ( NMTBB ) = TAGS(3)(1:12) RJ = RJUST ( CMSREF ( NMTBB ) ) C Bit width. CALL JSTCHR ( TAGS(4), IRET ) IF ( IRET .NE. 0 ) THEN BORT_STR2 = ' HAS MISSING BIT WIDTH' GOTO 901 ENDIF CMBW ( NMTBB ) = TAGS(4)(1:4) RJ = RJUST ( CMBW ( NMTBB ) ) C Units. Note that this field is allowed to be blank. IF ( NTAG .GT. 4 ) THEN CALL JSTCHR ( TAGS(5), IRET ) CMUNIT ( NMTBB ) = TAGS(5)(1:14) ELSE CMUNIT ( NMTBB ) = ' ' ENDIF C Comment (additional) fields. Any of these fields may be blank. CMMNEM ( NMTBB ) = ' ' CMDSC ( NMTBB ) = ' ' CMELEM ( NMTBB ) = ' ' IF ( NTAG .GT. 5 ) THEN WKTAG = TAGS(6) CALL PARSTR ( WKTAG, TAGS, 10, NTAG, ';', .FALSE. ) IF ( NTAG .GT. 0 ) THEN C The first additional field contains the mnemonic. CALL JSTCHR ( TAGS(1), IRET ) C If there is a mnemonic, then make sure it's legal. IF ( ( IRET .EQ. 0 ) .AND. . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN BORT_STR2 = ' HAS ILLEGAL MNEMONIC' GOTO 901 ENDIF CMMNEM ( NMTBB ) = TAGS(1)(1:8) ENDIF IF ( NTAG .GT. 1 ) THEN C The second additional field contains descriptor codes. CALL JSTCHR ( TAGS(2), IRET ) CMDSC ( NMTBB ) = TAGS(2)(1:4) ENDIF IF ( NTAG .GT. 2 ) THEN C The third additional field contains the element name. CALL JSTCHR ( TAGS(3), IRET ) CMELEM ( NMTBB ) = TAGS(3)(1:120) ENDIF ENDIF RETURN 900 CALL BORT('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') 901 BORT_STR1 = 'BUFRLIB: SNTBBE - CARD BEGINNING WITH: ' // . LINE(1:20) CALL BORT2(BORT_STR1,BORT_STR2) END ./sntbde.f0000644001370400056700000001443013440555365011413 0ustar jator2emc SUBROUTINE SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, . NMELEM, IEFXYN, CEELEM ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SNTBDE C PRGMMR: ATOR ORG: NP12 DATE: 2007-01-19 C C ABSTRACT: THIS SUBROUTINE PARSES THE FIRST LINE OF AN ENTRY THAT WAS C PREVIOUSLY READ FROM AN ASCII MASTER TABLE D FILE AND STORES THE C OUTPUT INTO THE MERGED ARRAYS. IT THEN READS AND PARSES ALL C REMAINING LINES FOR THAT SAME ENTRY AND THEN LIKEWISE STORES THAT C OUTPUT INTO THE MERGED ARRAYS. THE RESULT IS THAT, UPON OUTPUT, C THE MERGED ARRAYS NOW CONTAIN ALL OF THE INFORMATION FOR THE C CURRENT TABLE ENTRY. C C PROGRAM HISTORY LOG: C 2007-01-19 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, C NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, C NMELEM, IEFXYN, CEELEM ) C INPUT ARGUMENT LIST: C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING MASTER TABLE D INFORMATION C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR C TABLE ENTRY; THIS FXY NUMBER IS THE SEQUENCE DESCRIPTOR C LINE - CHARACTER*(*): FIRST LINE OF TABLE ENTRY C MXMTBD - INTEGER: MAXIMUM NUMBER OF ENTRIES TO BE STORED IN C MERGED MASTER TABLE D ARRAYS; THIS SHOULD BE THE SAME C NUMBER AS WAS USED TO DIMENSION THE OUTPUT ARRAYS IN C THE CALLING PROGRAM, AND IT IS USED BY THIS SUBROUTINE C TO ENSURE THAT IT DOESN'T OVERFLOW THESE ARRAYS C MXELEM - INTEGER: MAXIMUM NUMBER OF ELEMENTS TO BE STORED PER C ENTRY WITHIN THE MERGED MASTER TABLE D ARRAYS; THIS C SHOULD BE THE SAME NUMBER AS WAS USED TO DIMENSION THE C OUTPUT ARRAYS IN THE CALLING PROGRAM, AND IT IS USED C BY THIS SUBROUTINE TO ENSURE THAT IT DOESN'T OVERFLOW C THESE ARRAYS C C OUTPUT ARGUMENT LIST: C NMTBD - INTEGER: NUMBER OF ENTRIES IN MERGED MASTER TABLE D C ARRAYS C IMFXYN(*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF FXY NUMBERS (I.E. SEQUENCE C DESCRIPTORS) C CMMNEM(*)- CHARACTER*8: MERGED ARRAY CONTAINING MNEMONICS C CMDSC(*) - CHARACTER*4: MERGED ARRAY CONTAINING DESCRIPTOR CODES C CMSEQ(*) - CHARACTER*120: MERGED ARRAY CONTAINING SEQUENCE NAMES C NMELEM(*)- INTEGER: MERGED ARRAY CONTAINING NUMBER OF ELEMENTS C STORED FOR EACH ENTRY C IEFXYN(*,*)- INTEGER: MERGED ARRAY CONTAINING BIT-WISE C REPRESENTATIONS OF ELEMENT FXY NUMBERS C CEELEM(*,*)- CHARACTER*120: MERGED ARRAY CONTAINING ELEMENT NAMES C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT BORT2 IFXY C IGETFXY IGETNTBL JSTCHR NEMOCK C PARSTR C THIS ROUTINE IS CALLED BY: RDMTBD C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) LINE CHARACTER*200 TAGS(10), CLINE CHARACTER*128 BORT_STR1, BORT_STR2 CHARACTER*120 CMSEQ(*), CEELEM(MXMTBD,MXELEM) CHARACTER*8 CMMNEM(*) CHARACTER*6 ADN30, ADSC, CLEMON CHARACTER*4 CMDSC(*) INTEGER IMFXYN(*), NMELEM(*), . IEFXYN(MXMTBD,MXELEM) LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF ( NMTBD .GE. MXMTBD ) GOTO 900 NMTBD = NMTBD + 1 C Store the FXY number. This is the sequence descriptor. IMFXYN ( NMTBD ) = IFXYN C Is there any other information within the first line of the C table entry? If so, it follows a "|" separator. CMMNEM ( NMTBD ) = ' ' CMDSC ( NMTBD ) = ' ' CMSEQ ( NMTBD ) = ' ' IPT = INDEX ( LINE, '|' ) IF ( IPT .NE. 0 ) THEN C Parse the rest of the line. Any of the fields may be blank. CALL PARSTR ( LINE(IPT+1:), TAGS, 10, NTAG, ';', .FALSE. ) IF ( NTAG .GT. 0 ) THEN C The first additional field contains the mnemonic. CALL JSTCHR ( TAGS(1), IRET ) C If there is a mnemonic, then make sure it's legal. IF ( ( IRET .EQ. 0 ) .AND. . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN BORT_STR2 = ' HAS ILLEGAL MNEMONIC' GOTO 901 ENDIF CMMNEM ( NMTBD ) = TAGS(1)(1:8) ENDIF IF ( NTAG .GT. 1 ) THEN C The second additional field contains descriptor codes. CALL JSTCHR ( TAGS(2), IRET ) CMDSC ( NMTBD ) = TAGS(2)(1:4) ENDIF IF ( NTAG .GT. 2 ) THEN C The third additional field contains the sequence name. CALL JSTCHR ( TAGS(3), IRET ) CMSEQ ( NMTBD ) = TAGS(3)(1:120) ENDIF ENDIF C Now, read and parse all remaining lines from this table entry. C Each line should contain an element descriptor for the sequence C represented by the current sequence descriptor. NELEM = 0 DONE = .FALSE. DO WHILE ( .NOT. DONE ) IF ( IGETNTBL ( LUNT, CLINE ) .NE. 0 ) THEN BORT_STR2 = ' IS INCOMPLETE' GOTO 901 ENDIF CALL PARSTR ( CLINE, TAGS, 10, NTAG, '|', .FALSE. ) IF ( NTAG .LT. 2 ) THEN BORT_STR2 = ' HAS BAD ELEMENT CARD' GOTO 901 ENDIF C The second field contains the FXY number for this element. IF ( IGETFXY ( TAGS(2), ADSC ) .NE. 0 ) THEN BORT_STR2 = ' HAS BAD OR MISSING' // . ' ELEMENT FXY NUMBER' GOTO 901 ENDIF IF ( NELEM .GE. MXELEM ) GOTO 900 NELEM = NELEM + 1 IEFXYN ( NMTBD, NELEM ) = IFXY ( ADSC ) C The third field (if it exists) contains the element name. IF ( NTAG .GT. 2 ) THEN CALL JSTCHR ( TAGS(3), IRET ) CEELEM ( NMTBD, NELEM ) = TAGS(3)(1:120) ELSE CEELEM ( NMTBD, NELEM ) = ' ' ENDIF C Is this the last line for this table entry? IF ( INDEX ( TAGS(2), ' >' ) .EQ. 0 ) DONE = .TRUE. ENDDO NMELEM ( NMTBD ) = NELEM RETURN 900 CALL BORT('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') 901 CLEMON = ADN30 ( IFXYN, 6 ) WRITE(BORT_STR1,'("BUFRLIB: SNTBDE - TABLE D ENTRY FOR' // . ' SEQUENCE DESCRIPTOR: ",5A)') . CLEMON(1:1), '-', CLEMON(2:3), '-', CLEMON(4:6) CALL BORT2(BORT_STR1,BORT_STR2) END ./sntbfe.f0000644001370400056700000001045413440555365011417 0ustar jator2emc SUBROUTINE SNTBFE ( LUNT, IFXYN, LINE ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SNTBFE C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-02 C C ABSTRACT: THIS SUBROUTINE READS A COMPLETE ENTRY (CORRESPONDING C TO THE INPUT FXY NUMBER) FROM AN ASCII MASTER CODE/FLAG TABLE AND C STORES THE OUTPUT INTO AN INTERNAL MEMORY STRUCTURE. C C PROGRAM HISTORY LOG: C 2017-11-02 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL SNTBFE ( LUNT, IFXYN, LINE ) C INPUT ARGUMENT LIST: C LUNT - INTEGER: FORTRAN LOGICAL UNIT NUMBER OF ASCII FILE C CONTAINING MASTER CODE/FLAG TABLE INFORMATION C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER C LINE - CHARACTER*(*): FIRST LINE OF TABLE ENTRY C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT2 IFXY IGETFXY C IGETNTBL JSTCHR PARSTR STRNUM C STRTBFE C THIS ROUTINE IS CALLED BY: RDMTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) LINE CHARACTER*160 CLINE, TAGS(4), CDSTR(2), ADSC(10), CVAL(25) CHARACTER*128 BORT_STR1, BORT_STR2 CHARACTER*6 ADN30, CLEMON, CDSC DIMENSION IDFXY(10), IDVAL(25) LOGICAL DONE, LSTNBLK C----------------------------------------------------------------------- C----------------------------------------------------------------------- C We already have the FXY number. Now we need to read and parse C all of the remaining lines from the table entry for this FXY C number. The information for each individual code figure or bit C number will then be stored as a separate entry within the C internal memory structure. DONE = .FALSE. NIDFXY = 0 NIDVAL = 0 DO WHILE ( .NOT. DONE ) IF ( IGETNTBL ( LUNT, CLINE ) .NE. 0 ) THEN BORT_STR2 = ' IS INCOMPLETE' GOTO 900 ENDIF CALL PARSTR ( CLINE, TAGS, 4, NTAG, '|', .FALSE. ) IF ( ( NTAG .LT. 2 ) .OR. ( NTAG .GT. 3 ) ) THEN BORT_STR2 = ' HAS BAD CARD' GOTO 900 ENDIF IF ( NTAG .EQ. 2 ) THEN C This line contains a list of dependencies. CALL PARSTR ( TAGS(2), CDSTR, 2, NTAG, '=', .FALSE. ) IF ( NTAG .NE. 2 ) THEN BORT_STR2 = ' HAS BAD DEPENDENCY CARD' GOTO 900 ENDIF C Parse the list of FXY numbers. CALL PARSTR ( CDSTR(1), ADSC, 10, NIDFXY, ',', .FALSE. ) IF ( NIDFXY .EQ. 0 ) THEN BORT_STR2 = ' HAS BAD DEPENDENCY LIST (FXY)' GOTO 900 ENDIF DO II = 1, NIDFXY IF ( IGETFXY ( ADSC(II), CDSC ) .NE. 0 ) THEN BORT_STR2 = ' HAS BAD DEPENDENCY (FXY)' GOTO 900 ENDIF IDFXY(II) = IFXY( CDSC ) ENDDO C Parse the list of values. CALL PARSTR ( CDSTR(2), CVAL, 25, NIDVAL, ',', .FALSE. ) IF ( NIDVAL .EQ. 0 ) THEN BORT_STR2 = ' HAS BAD DEPENDENCY LIST (VAL)' GOTO 900 ENDIF DO II = 1, NIDVAL CALL JSTCHR ( CVAL(II), IER ) CALL STRNUM ( CVAL(II), IVAL ) IDVAL(II) = IVAL ENDDO ELSE C This line contains a value (code figure or bit number) C and corresponding meaning. IPT = INDEX ( TAGS(2), ' >' ) IF ( IPT .EQ. 0 ) THEN C This is the last line for this table entry. DONE = .TRUE. ELSE TAGS(2)(IPT+1:IPT+1) = ' ' ENDIF CALL JSTCHR ( TAGS(2), IER ) CALL STRNUM ( TAGS(2), IVAL ) C Find the last non-blank character in the meaning string. CALL JSTCHR ( TAGS(3), IER ) LT3 = LEN(TAGS(3)) LSTNBLK = .FALSE. DO WHILE ( ( LT3 .GT. 0 ) .AND. ( .NOT. LSTNBLK ) ) IF ( TAGS(3)(LT3:LT3) .NE. ' ' ) THEN LSTNBLK = .TRUE. ELSE LT3 = LT3 - 1 ENDIF ENDDO C Store the information for this value within the internal C memory structure. IF ( ( NIDFXY .EQ. 0 ) .AND. ( NIDVAL .EQ. 0 ) ) THEN CALL STRTBFE ( IFXYN, IVAL, TAGS(3), LT3, -1, -1 ) ELSE DO II = 1, NIDFXY DO JJ = 1, NIDVAL CALL STRTBFE ( IFXYN, IVAL, TAGS(3), LT3, + IDFXY(II), IDVAL(JJ) ) ENDDO ENDDO ENDIF ENDIF ENDDO RETURN 900 CLEMON = ADN30 ( IFXYN, 6 ) WRITE(BORT_STR1,'("BUFRLIB: SNTBFE - TABLE F ENTRY FOR' // . ' ELEMENT DESCRIPTOR: ",5A)') . CLEMON(1:1), '-', CLEMON(2:3), '-', CLEMON(4:6) CALL BORT2(BORT_STR1,BORT_STR2) END ./sorttbf.c0000644001370400056700000000161513440555365011615 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SORTTBF C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-16 C C ABSTRACT: THIS ROUTINE SORTS THE CONTENTS OF THE INTERNAL MEMORY C STRUCTURE FOR STORING CODE/FLAG TABLE INFORMATION, IN PREPARATION C FOR LATER SEARCHES USING THE BSEARCH (BINARY SEARCH) FUNCTION. C C PROGRAM HISTORY LOG: C 2017-11-16 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL SORTTBF C C REMARKS: C THIS ROUTINE CALLS: CMPSTIA1 C THIS ROUTINE IS CALLED BY: RDMTBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" void sorttbf( void ) { qsort( &cfe[0], ( size_t ) nmtf, sizeof( struct code_flag_entry ), ( int (*) ( const void *, const void * ) ) cmpstia1 ); } ./srchtbf.c0000644001370400056700000001566113440555365011573 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: SRCHTBF C PRGMMR: ATOR ORG: NCEP DATE: 2018-01-11 C C ABSTRACT: THIS ROUTINE SEARCHES FOR A SPECIFIED DESCRIPTOR AND C ASSOCIATED VALUE (CODE FIGURE OR BIT NUMBER) WITHIN THE INTERNAL C MEMORY STRUCTURE FOR STORING CODE/FLAG TABLE INFORMATION. THE C SEARCH MAY ALSO OPTIONALLY INCLUDE A SPECIFIED SECOND DESCRIPTOR C AND ASSOCIATED VALUE UPON WHICH THE FIRST DESCRIPTOR AND ITS C ASSOCIATED VALUE DEPEND, FOR CASES SUCH AS, E.G. WHEN THE MEANING C OF AN ORIGINATING SUBCENTER VALUE DEPENDS ON THE IDENTITY OF THE C ORIGINATING CENTER. C C IF THE REQUESTED ENTRY IN THE TABLE IS FOUND, THE ROUTINE RETURNS C THE ASSOCIATED MEANING AS A CHARACTER STRING. OTHERWISE, AND IF C THERE WAS NO OPTIONAL SECOND DESCRIPTOR AND ASSOCIATED VALUE C SPECIFIED ON INPUT, THE ROUTINE WILL RE-SEARCH THE TABLE TO CHECK C WHETHER THE MEANING OF THE FIRST DESCRIPTOR AND ASSOCIATED VALUE C MAY INDEED DEPEND ON THE VALUE OF ONE OR MORE OTHER POSSIBLE C SECOND DESCRIPTORS. IF SO, THOSE POSSIBLE DESCRIPTORS ARE RETURNED C ALONG WITH A SPECIAL RETURN CODE SO THAT THE CALLING ROUTINE MAY C EXAMINE THEM AND POSSIBLY ISSUE ANOTHER SUBSEQUENT CALL TO THIS C SAME ROUTINE WITH SPECIFIED VALUES FOR THE SECOND DESCRIPTOR AND C ASSOCIATED VALUE. C C PROGRAM HISTORY LOG: C 2018-01-11 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL SRCHTBF ( IFXYI, IVALI, IFXYD, MXFXYD, IVALD, C MEANING, MXMNG, LNMNG, IRET ) C C INPUT ARGUMENT LIST: C IFXYI - INTEGER: BIT-WISE REPRESENTATION OF FXY DESCRIPTOR C IVALI - INTEGER: VALUE (CODE FIGURE OR BIT NUMBER) ASSOCIATED C WITH IFXYI C IFXYD - INTEGER: ARRAY WITH THE FIRST ELEMENT SET TO THE C BIT-WISE REPRESENTATION OF THE FXY DESCRIPTOR, IF ANY, C UPON WHICH THE VALUES IFXYI AND IVALI DEPEND. THIS IS C OPTIONAL, AND THE FIRST ELEMENT OF THE ARRAY CAN BE SET C TO (-1) IF THE MEANINGS OF IFXYI AND IVALI DO NOT C DEPEND ON THE VALUE OF ANY OTHER DESCRIPTOR. C -1 = NO DEPENDENCY SPECIFIED C IVALD - INTEGER: VALUE (CODE FIGURE OR BIT NUMBER) ASSOCIATED C WITH IFXYD. THIS VALUE SHOULD BE SET TO (-1) C WHENEVER THE FIRST ELEMENT OF THE IFXYD ARRAY IS C LIKEWISE SET TO (-1) C -1 = NO DEPENDENCY SPECIFIED C MXFXYD - INTEGER: DIMENSIONED SIZE OF IFXYD; USED BY THE ROUTINE C TO ENSURE THAT IT DOES NOT OVERFLOW THE IFXYD ARRAY C UPON OUTPUT C MXMNG - INTEGER: DIMENSIONED SIZE OF MEANING STRING; USED BY C THE ROUTINE TO ENSURE THAT IT DOES NOT OVERFLOW THIS C STRING UPON OUTPUT C C OUTPUT ARGUMENT LIST: C MEANING - CHARACTER*(LNMNG): MEANING CORRESPONDING TO IFXYI AND C IVALI (AND TO IFXYD AND IVALD, IF SPECIFIED) C LNMNG - INTEGER: LENGTH OF STRING RETURNED IN MEANING C IFXYD - INTEGER: IF THE INITIAL SEARCH OF THE TABLE WAS C UNSUCCESSFUL, *AND* IF NO OPTIONAL SECOND DESCRIPTOR C AND ASSOCIATED VALUE WERE SPECIFIED ON INPUT, *AND* IF C THE SECOND SEARCH OF THE TABLE DETERMINED THAT THE C MEANING OF THE FIRST DESCRIPTOR AND ASSOCIATED VALUE C INDEED DEPENDS ON ONE OR MORE OTHER POSSIBLE SECOND C DESCRIPTORS, THEN THOSE POSSIBLE SECOND DESCRIPTORS C ARE RETURNED WITHIN THE FIRST IRET ELEMENTS OF IFXYD C IRET - RETURN CODE: C 0 = MEANING FOUND AND STORED IN MEANING STRING C -1 = MEANING NOT FOUND C >0 = MEANING NOT FOUND, *AND* IFXYD AND IVALD WERE C BOTH SET TO (-1) ON INPUT, *AND* THE MEANING OF C IFXYI AND IVALI DEPENDS ON THE VALUE OF ONE OF C THE IRET DESCRIPTORS RETURNED IN IFXYD C C REMARKS: C THIS ROUTINE CALLS: CMPSTIA1 CMPSTIA2 C THIS ROUTINE IS CALLED BY: GETCFMNG UFDUMP C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" void srchtbf( f77int *ifxyi, f77int *ivali, f77int *ifxyd, f77int *mxfxyd, f77int *ivald, char *meaning, f77int *mxmng, f77int *lnmng, f77int *iret ) { struct code_flag_entry key, *pkey, *pcfe, *pbs; int ipt, ii, slmng; *iret = -1; /* ** Initialize some values for searching the internal table. */ key.iffxyn = *ifxyi; key.ifval = *ivali; key.iffxynd = ifxyd[0]; key.ifvald = *ivald; pkey = &key; pcfe = &cfe[0]; /* ** Search for a matching entry. */ pbs = ( struct code_flag_entry * ) bsearch( pkey, pcfe, ( size_t ) nmtf, sizeof( struct code_flag_entry ), ( int (*) ( const void *, const void * ) ) cmpstia1 ); if ( pbs != NULL ) { /* ** A matching entry was found, so set the appropriate output ** values and return. */ ipt = pbs - pcfe; slmng = strlen( cfe[ipt].ifmeaning ); *lnmng = ( *mxmng > slmng ? slmng : *mxmng ); strncpy( meaning, &cfe[ipt].ifmeaning[0], *lnmng ); *iret = 0; return; } /* ** Was a particular dependency specified in the input? */ if ( key.iffxynd != -1 ) { /* ** YES, so there's nothing else to do. */ return; } /* ** NO, so check whether the given Table B descriptor and value have any ** dependencies, and if so then return a list of those dependencies. */ pbs = ( struct code_flag_entry * ) bsearch( pkey, pcfe, ( size_t ) nmtf, sizeof( struct code_flag_entry ), ( int (*) ( const void *, const void * ) ) cmpstia2 ); if ( pbs == NULL ) { /* ** There are no dependencies. */ return; } /* ** Store the dependency that was returned by the secondary search. ** However, there may be others within the internal table, so we'll ** also need to check for those. */ ipt = pbs - pcfe; *iret = 0; ifxyd[(*iret)++] = cfe[ipt].iffxynd; /* ** Since the internal table is sorted, check immediately before and ** after the returned dependency for any additional table entries which ** correspond to the same Table B descriptor and value, but for which the ** dependency is different. If any such additional dependencies are ** found, return those as well. */ ii = ipt - 1; while ( ( ii >= 0 ) && ( *iret < *mxfxyd ) && ( cfe[ii].iffxyn == key.iffxyn ) && ( cfe[ii].ifval == key.ifval ) ) { if ( cfe[ii].iffxynd < ifxyd[(*iret)-1] ) ifxyd[(*iret)++] = cfe[ii].iffxynd; ii--; } ii = ipt + 1; while ( ( ii < nmtf ) && ( *iret < *mxfxyd ) && ( cfe[ii].iffxyn == key.iffxyn ) && ( cfe[ii].ifval == key.ifval ) ) { if ( ( cfe[ii].iffxynd > ifxyd[(*iret)-1] ) && ( cfe[ii].iffxynd > cfe[ipt].iffxynd ) ) ifxyd[(*iret)++] = cfe[ii].iffxynd; ii++; } return; } ./status.f0000644001370400056700000001463513440555365011466 0ustar jator2emc SUBROUTINE STATUS(LUNIT,LUN,IL,IM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STATUS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS WHETHER LOGICAL UNIT NUMBER LUNIT C (AND ITS ASSOCIATED BUFR FILE) IS CURRENTLY CONNECTED TO THE C BUFR ARCHIVE LIBRARY SOFTWARE. IF SO, IT RETURNS THE I/O STREAM C INDEX (LUN) ASSOCIATED WITH THE LOGICAL UNIT NUMBER, THE LOGICAL C UNIT STATUS INDICATOR (IL), AND THE BUFR MESSAGE STATUS INDICATOR C (IM) FOR THAT I/O STREAM INDEX. OTHERWISE, IT CHECKS WHETHER THERE C IS SPACE FOR A NEW I/O STREAM INDEX AND, IF SO, RETURNS THE NEXT C AVAILABLE I/O STREAM INDEX IN LUN IN ORDER TO DEFINE LUNIT (IL AND C IM ARE RETURNED AS ZERO, THEY ARE LATER DEFINED VIA CALLS TO BUFR C ARCHIVE LIBRARY SUBROUTINE WTSTAT IN THIS CASE). IF THERE IS NO C SPACE FOR A NEW I/O STREAM INDEX, LUN IS RETURNED AS ZERO (AS WELL C AS IL AND IM) MEANING LUNIT COULD NOT BE CONNECTED TO THE BUFR C ARCHIVE LIBRARY SOFTWARE. LUN IS USED TO IDENTIFY UP TO "NFILES" C UNIQUE BUFR FILES IN THE VARIOUS INTERNAL ARRAYS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-12-11 J. WOOLLEN -- FIXED A LONG STANDING BUG WHICH OCCURS IN C UNUSUAL SITUATIONS, VERY LOW IMPACT C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL STATUS ( LUNIT, LUN, IL, IM ) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT C LUNIT C 0 = LUNIT is not currently connected to the C BUFR Archive Library software and there is C no space for a new I/O stream index C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: C 0 = LUNIT is not currently connected to the C BUFR Archive Library software or it was C just connected in this call to STATUS C 1 = LUNIT is connected to the BUFR Archive C Library software as an output file C -1 = LUNIT is connected to the BUFR Archive C Library software as an input file C IM - INTEGER: INDICATOR AS TO WHETHER THERE IS A BUFR C MESSAGE CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT: C 0 = no or LUNIT was just connected to the C BUFR Archive Library software in this call C to STATUS C 1 = yes C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG COPYBF COPYMG C COPYSB CPYMEM DATEBF DRFINI C DUMPBF DXDUMP GETABDB GETTAGPR C GETTAGRE GETVALNB IFBGET IGETSC C INVMRG IUPVS01 LCMGDF MESGBC C MINIMG MSGWRT NEMDEFS NEMSPECS C NMSUB OPENBF OPENMB OPENMG C POSAPX RDMEMM RDMEMS RDMGSB C READDX READERME READLC READMG C READNS READSB REWNBF RTRCPT C SETVALNB STNDRD UFBCNT UFBCPY C UFBCUP UFBDMP UFBEVN UFBGET C UFBIN3 UFBINT UFBINX UFBMMS C UFBOVR UFBPOS UFBQCD UFBQCP C UFBREP UFBRMS UFBSEQ UFBSTP C UFBTAB UFBTAM UFDUMP UPFTBV C WRCMPS WRDXTB WRITLC WRITSA C WRITSB GETCFMNG C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_STBFR INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(LUNIT.LE.0 .OR. LUNIT.GT.99) GOTO 900 C CLEAR THE STATUS INDICATORS C --------------------------- LUN = 0 IL = 0 IM = 0 C SEE IF UNIT IS ALREADY CONNECTED TO BUFR ARCHIVE LIBRARY SOFTWARE C ----------------------------------------------------------------- DO I=1,NFILES IF(ABS(IOLUN(I)).EQ.LUNIT) LUN = I ENDDO C IF NOT, TRY TO DEFINE IT SO AS TO CONNECT IT TO BUFR ARCHIVE LIBRARY C SOFTWARE C -------------------------------------------------------------------- IF(LUN.EQ.0) THEN DO I=1,NFILES IF(IOLUN(I).EQ.0) THEN C File space is available, return with LUN > 0, IL and IM remain 0 C ---------------------------------------------------------------- LUN = I GOTO 100 ENDIF ENDDO C File space is NOT available, return with LUN, IL and IM all 0 C ------------------------------------------------------------- GOTO 100 ENDIF C IF THE UNIT WAS ALREADY CONNECTED TO THE BUFR ARCHIVE LIBRARY C SOFTWARE PRIOR TO THIS CALL, RETURN STATUSES C ------------------------------------------------------------- IL = SIGN(1,IOLUN(LUN)) IM = IOMSG(LUN) C EXITS C ---- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") '// . 'OUTSIDE LEGAL RANGE OF 1-99")') LUNIT CALL BORT(BORT_STR) END ./stbfdx.f0000644001370400056700000001201513440555365011423 0ustar jator2emc SUBROUTINE STBFDX(LUN,MESG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STBFDX C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE C FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN C MODULE TABABD. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC COPIED C FROM PREVIOUS VERSION OF RDBFDX C 2014-11-14 J. ATOR -- REPLACE CHRTRNA CALLS WITH UPC CALLS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL STBFDX (LUN,MESG) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING C BUFR TABLE (DICTIONARY) MESSAGE C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT GETLENS IGETNTBI C IDN30 IFXY IUPB IUPBS01 C NENUBD PKTDD STNTBIA UPC C THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM READERME C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODV_MAXCD USE MODA_TABABD INCLUDE 'bufrlib.prm' COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*128 BORT_STR CHARACTER*128 TABB1,TABB2 CHARACTER*56 DXSTR CHARACTER*55 CSEQ CHARACTER*50 DXCMP CHARACTER*24 UNIT CHARACTER*8 NEMO CHARACTER*6 NUMB,CIDN DIMENSION LDXBD(10),LDXBE(10) DIMENSION MESG(*) 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 GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE C ------------------------------------------------- IDXS = IUPBS01(MESG,'MSBT')+1 IF(IDXS.GT.IDXV+1) IDXS = IUPBS01(MESG,'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(MESG,3,LEN0,LEN1,LEN2,LEN3,L4,L5) I3 = LEN0+LEN1+LEN2 DXCMP = ' ' JBIT = 8*(I3+7) CALL UPC(DXCMP,NXSTR(IDXS),MESG,JBIT,.FALSE.) 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 = IUPB(MESG,IA,8) IB = JA(LA+1) LB = IUPB(MESG,IB,8) ID = JB(LB+1) LD = IUPB(MESG,ID,8) C TABLE A C ------- DO I=1,LA N = IGETNTBI(LUN,'A') JBIT = 8*(JA(I)-1) CALL UPC(TABA(N,LUN),LDA,MESG,JBIT,.TRUE.) NUMB = ' '//TABA(N,LUN)(1:3) NEMO = TABA(N,LUN)(4:11) CSEQ = TABA(N,LUN)(13:67) CALL STNTBIA(N,LUN,NUMB,NEMO,CSEQ) ENDDO C TABLE B C ------- DO I=1,LB N = IGETNTBI(LUN,'B') JBIT = 8*(JB(I)-1) CALL UPC(TABB1,LDBD,MESG,JBIT,.TRUE.) JBIT = 8*(JB(I)+LDBD-1) CALL UPC(TABB2,LDBE,MESG,JBIT,.TRUE.) 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) CALL NENUBD(NEMO,NUMB,LUN) IDNB(N,LUN) = IFXY(NUMB) UNIT = TABB(N,LUN)(71:94) CALL CAPIT(UNIT) TABB(N,LUN)(71:94) = UNIT NTBB(LUN) = N ENDDO C TABLE D C ------- DO I=1,LD N = IGETNTBI(LUN,'D') JBIT = 8*ID CALL UPC(TABD(N,LUN),LDD,MESG,JBIT,.TRUE.) NUMB = TABD(N,LUN)(1:6) NEMO = TABD(N,LUN)(7:14) CALL NENUBD(NEMO,NUMB,LUN) IDND(N,LUN) = IFXY(NUMB) ND = IUPB(MESG,ID+LDD+1,8) IF(ND.GT.MAXCD) GOTO 903 DO J=1,ND NDD = ID+LDD+2 + (J-1)*L30 JBIT = 8*(NDD-1) CALL UPC(CIDN,L30,MESG,JBIT,.TRUE.) IDN = IDN30(CIDN,L30) CALL PKTDD(N,LUN,IDN,IRET) IF(IRET.LT.0) GOTO 904 ENDDO ID = ID+LDD+1 + ND*L30 IF(IUPB(MESG,ID+1,8).EQ.0) ID = ID+1 NTBD(LUN) = N ENDDO C EXITS C ----- RETURN 901 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '// . 'KNOWN)') 902 CALL BORT('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '// . 'CONTENTS') 903 WRITE(BORT_STR,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '// . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '// . ' (",I4,")")') NEMO,ND,MAXCD CALL BORT(BORT_STR) 904 CALL BORT('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '// . 'PKTDD, SEE PREVIOUS WARNING MESSAGE') END ./stdmsg.f0000644001370400056700000000364013440555365011436 0ustar jator2emc SUBROUTINE STDMSG(CF) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STDMSG C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: THIS SUBROUTINE IS USED TO SPECIFY WHETHER OR NOT BUFR C MESSAGES THAT WILL BE OUTPUT BY FUTURE CALLS TO ANY OF THE BUFR C ARCHIVE LIBRARY SUBROUTINES WHICH CREATE SUCH MESSAGES (E.G. WRITCP, C WRITSB, COPYMG, WRITSA, ETC.) ARE TO BE "STANDARDIZED". SEE THE C DOCUMENTATION BLOCK WITHIN BUFR ARCHIVE LIBRARY SUBROUTINE STNDRD C FOR AN EXPLANATION OF WHAT "STANDARDIZATION" MEANS. THIS SUBROUTINE C CAN BE CALLED AT ANY TIME AFTER THE FIRST CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF, AND THE POSSIBLE VALUES FOR CF ARE 'N' C (= 'NO', WHICH IS THE DEFAULT) AND 'Y' (= 'YES'). C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL STDMSG (CF) C INPUT ARGUMENT LIST: C CF - CHARACTER*1: FLAG INDICATING WHETHER BUFR MESSAGES C OUTPUT BY FUTURE CALLS TO WRITCP, WRITSB, COPYMG, ETC. C SHOULD BE "STANDARDIZED": C 'N' = 'NO' (THE DEFAULT) C 'Y' = 'YES' C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /MSGSTD/ CSMF CHARACTER*128 BORT_STR CHARACTER*1 CSMF, CF C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 CSMF = CF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,'// . '", IT MUST BE EITHER Y OR N")') CF CALL BORT(BORT_STR) END ./stndrd.f0000644001370400056700000002423413440555365011435 0ustar jator2emc SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STNDRD C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: THIS SUBROUTINE READS AN INPUT NCEP BUFR MESSAGE CONTAINED C WITHIN ARRAY MSGIN AND, USING THE BUFR TABLES INFORMATION ASSOCIATED C WITH LOGICAL UNIT LUNIT, OUTPUTS A "STANDARDIZED" VERSION OF THIS C SAME MESSAGE WITHIN ARRAY MSGOT. THIS "STANDARDIZATION" INVOLVES C REMOVING ALL OCCURRENCES OF NCEP BUFRLIB-SPECIFIC BYTE COUNTERS AND C BIT PADS IN SECTION 4 AS WELL AS REPLACING THE TOP-LEVEL TABLE A FXY C NUMBER IN SECTION 3 WITH AN EQUIVALENT SEQUENCE OF LOWER-LEVEL C TABLE B, TABLE C, TABLE D AND/OR REPLICATION FXY NUMBERS WHICH C DIRECTLY CONSTITUTE THAT TABLE A FXY NUMBER AND WHICH THEMSELVES ARE C ALL WMO-STANDARD. THE RESULT IS THAT THE OUTPUT MESSAGE IN MSGOT IS C NOW ENTIRELY COMPLIANT WITH WMO FM-94 BUFR REGULATIONS (I.E. IT IS C NOW "STANDARD"). IT IS IMPORTANT TO NOTE THAT THE SEQUENCE EXPANSION C WITHIN SECTION 3 MAY CAUSE THE FINAL "STANDARDIZED" BUFR MESSAGE TO C BE LONGER THAN THE ORIGINAL INPUT NCEP BUFR MESSAGE BY AS MANY AS C (MAXNC*2) BYTES (SEE 'bufrlib.prm' FOR AN EXPLANATION OF MAXNC), SO C THE USER MUST ALLOW FOR ENOUGH SPACE TO ACCOMODATE SUCH AN EXPANSION C WITHIN THE MSGOT ARRAY. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C THIS SUBROUTINE IS MODELED AFTER SUBROUTINE C STANDARD; HOWEVER, IT USES SUBROUTINE RESTD C TO EXPAND SECTION 3 AS MANY LEVELS AS C NECESSARY IN ORDER TO ATTAIN TRUE WMO C STANDARDIZATION (WHEREAS STANDARD ONLY C EXPANDED THE TOP-LEVEL TABLE A FXY NUMBER C ONE LEVEL DEEP), AND IT ALSO CONTAINS AN C EXTRA INPUT ARGUMENT LMSGOT WHICH PREVENTS C OVERFLOW OF THE MSGOT ARRAY C 2005-11-29 J. ATOR -- USE GETLENS AND IUPBS01; ENSURE THAT BYTE 4 C OF SECTION 4 IS ZEROED OUT IN MSGOT; CHECK C EDITION NUMBER OF BUFR MESSAGE BEFORE C PADDING TO AN EVEN BYTE COUNT C 2009-03-23 J. ATOR -- USE IUPBS3 AND NEMTBAX; DON'T ASSUME THAT C COMPRESSED MESSAGES ARE ALREADY FULLY C STANDARDIZED WITHIN SECTION 3 C 2014-02-04 J. ATOR -- ACCOUNT FOR SUBSETS WITH BYTE COUNT > 65530 C C USAGE: CALL STNDRD (LUNIT, MSGIN, LMSGOT, MSGOT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C MSGIN - INTEGER: *-WORD ARRAY CONTAINING BUFR MESSAGE IN NCEP C BUFR C LMSGOT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGOT; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE MSGOT ARRAY C C OUTPUT ARGUMENT LIST: C MSGOT - INTEGER: *-WORD ARRAY CONTAINING INPUT BUFR MESSAGE C NOW IN STANDARDIZED BUFR C C REMARKS: C MSGIN AND MSGOT MUST BE SEPARATE ARRAYS. C C THIS ROUTINE CALLS: BORT GETLENS ISTDESC IUPB C IUPBS01 IUPBS3 MVB NEMTBAX C NUMTAB PKB PKC RESTD C STATUS UPB UPC C THIS ROUTINE IS CALLED BY: MSGWRT C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' DIMENSION ICD(MAXNC) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION MSGIN(*),MSGOT(*) CHARACTER*128 BORT_STR CHARACTER*8 SUBSET CHARACTER*4 SEVN CHARACTER*1 TAB LOGICAL FOUND C----------------------------------------------------------------------- C----------------------------------------------------------------------- C LUNIT MUST POINT TO AN OPEN BUFR FILE C ------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 C IDENTIFY THE SECTION LENGTHS AND ADDRESSES IN MSGIN C --------------------------------------------------- CALL GETLENS(MSGIN,5,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) IAD3 = LEN0+LEN1+LEN2 IAD4 = IAD3+LEN3 LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 LENM = IUPBS01(MSGIN,'LENM') IF(LENN.NE.LENM) GOTO 901 MBIT = (LENN-4)*8 CALL UPC(SEVN,4,MSGIN,MBIT,.TRUE.) IF(SEVN.NE.'7777') GOTO 902 C COPY SECTIONS 0 THROUGH PART OF SECTION 3 INTO MSGOT C ---------------------------------------------------- MXBYTO = (LMSGOT*NBYTW) - 8 LBYTO = IAD3+7 IF(LBYTO.GT.MXBYTO) GOTO 905 CALL MVB(MSGIN,1,MSGOT,1,LBYTO) C REWRITE NEW SECTION 3 IN A "STANDARD" FORM C ------------------------------------------ C LOCATE THE TOP-LEVEL TABLE A DESCRIPTOR FOUND = .FALSE. II = 10 DO WHILE ((.NOT.FOUND).AND.(II.GE.8)) ISUB = IUPB(MSGIN,IAD3+II,16) CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) IF((ITAB.NE.0).AND.(TAB.EQ.'D')) THEN CALL NEMTBAX(LUN,SUBSET,MTYP,MSBT,INOD) IF(INOD.NE.0) FOUND = .TRUE. ENDIF II = II - 2 ENDDO IF(.NOT.FOUND) GOTO 903 IF (ISTDESC(ISUB).EQ.0) THEN C ISUB IS A NON-STANDARD TABLE A DESCRIPTOR AND NEEDS C TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE CALL RESTD(LUN,ISUB,NCD,ICD) ELSE C ISUB IS ALREADY A STANDARD DESCRIPTOR, SO JUST COPY C IT "AS IS" INTO THE NEW SECTION 3 (I.E. NO EXPANSION C IS NECESSARY!) NCD = 1 ICD(NCD) = ISUB ENDIF C USE THE EDITION NUMBER TO DETERMINE THE LENGTH OF THE C NEW SECTION 3 LEN3 = 7+(NCD*2) IBEN = IUPBS01(MSGIN,'BEN') IF(IBEN.LT.4) THEN LEN3 = LEN3+1 ENDIF LBYTO = LBYTO + LEN3 - 7 IF(LBYTO.GT.MXBYTO) GOTO 905 C STORE THE DESCRIPTORS INTO THE NEW SECTION 3 IBIT = (IAD3+7)*8 DO N=1,NCD CALL PKB(ICD(N),16,MSGOT,IBIT) ENDDO C DEPENDING ON THE EDITION NUMBER, PAD OUT THE NEW SECTION 3 WITH AN C ADDITIONAL ZEROED-OUT BYTE IN ORDER TO ENSURE AN EVEN BYTE COUNT IF(IBEN.LT.4) THEN CALL PKB(0,8,MSGOT,IBIT) ENDIF C STORE THE LENGTH OF THE NEW SECTION 3 IBIT = IAD3*8 CALL PKB(LEN3,24,MSGOT,IBIT) C NOW THE TRICKY PART - NEW SECTION 4 C ----------------------------------- IF(IUPBS3(MSGIN,'ICMP').EQ.1) THEN C THE DATA IN SECTION 4 IS COMPRESSED AND IS THEREFORE ALREADY C STANDARDIZED, SO COPY IT "AS IS" INTO THE NEW SECTION 4 IF((LBYTO+LEN4+4).GT.MXBYTO) GOTO 905 CALL MVB(MSGIN,IAD4+1,MSGOT,LBYTO+1,LEN4) JBIT = (LBYTO+LEN4)*8 ELSE NAD4 = IAD3+LEN3 IBIT = (IAD4+4)*8 JBIT = (NAD4+4)*8 LBYTO = LBYTO + 4 C COPY THE SUBSETS, MINUS THE BYTE COUNTERS AND BIT PADS, INTO C THE NEW SECTION 4 NSUB = IUPBS3(MSGIN,'NSUB') DO 10 I=1,NSUB CALL UPB(LSUB,16,MSGIN,IBIT) IF(NSUB.GT.1) THEN C USE THE BYTE COUNTER TO COPY THIS SUBSET ISLEN = LSUB-2 ELSE C THIS IS THE ONLY SUBSET IN THE MESSAGE, AND IT COULD C POSSIBLY BE AN OVERLARGE (> 65530 BYTES) SUBSET, IN C WHICH CASE WE CAN'T RELY ON THE VALUE STORED IN THE C BYTE COUNTER. EITHER WAY, WE DON'T REALLY NEED IT. ISLEN = IAD4+LEN4-(IBIT/8) ENDIF DO L=1,ISLEN CALL UPB(NVAL,8,MSGIN,IBIT) LBYTO = LBYTO + 1 IF(LBYTO.GT.MXBYTO) GOTO 905 CALL PKB(NVAL,8,MSGOT,JBIT) ENDDO DO K=1,8 KBIT = IBIT-K-8 CALL UPB(KVAL,8,MSGIN,KBIT) IF(KVAL.EQ.K) THEN JBIT = JBIT-K-8 GOTO 10 ENDIF ENDDO GOTO 904 10 ENDDO C FROM THIS POINT ON, WE WILL NEED (AT MOST) 6 MORE BYTES OF C SPACE WITHIN MSGOT IN ORDER TO BE ABLE TO STORE THE ENTIRE C STANDARDIZED MESSAGE (I.E. WE WILL NEED (AT MOST) 2 MORE C ZEROED-OUT BYTES IN SECTION 4 PLUS THE 4 BYTES '7777' IN C SECTION 5), SO DO A FINAL MSGOT OVERFLOW CHECK NOW. IF(LBYTO+6.GT.MXBYTO) GOTO 905 C PAD THE NEW SECTION 4 WITH ZEROES UP TO THE NEXT WHOLE BYTE C BOUNDARY. DO WHILE(.NOT.(MOD(JBIT,8).EQ.0)) CALL PKB(0,1,MSGOT,JBIT) ENDDO C DEPENDING ON THE EDITION NUMBER, WE MAY NEED TO FURTHER PAD C THE NEW SECTION 4 WITH AN ADDITIONAL ZEROED-OUT BYTE IN ORDER C TO ENSURE THAT THE PADDING IS UP TO AN EVEN BYTE BOUNDARY. IF( (IBEN.LT.4) .AND. (MOD(JBIT/8,2).NE.0) ) THEN CALL PKB(0,8,MSGOT,JBIT) ENDIF IBIT = NAD4*8 LEN4 = JBIT/8 - NAD4 CALL PKB(LEN4,24,MSGOT,IBIT) CALL PKB(0,8,MSGOT,IBIT) ENDIF C FINISH THE NEW MESSAGE WITH AN UPDATED SECTION 0 BYTE COUNT C ----------------------------------------------------------- IBIT = 32 LENN = LEN0+LEN1+LEN2+LEN3+LEN4+LEN5 CALL PKB(LENN,24,MSGOT,IBIT) CALL PKC('7777',4,MSGOT,JBIT) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM'// . ' SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL SECTION'// . ' LENGTHS (",I6,")")') LENM,LENN CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT '// . 'END WITH ""7777"" (ENDS WITH ",A)') SEVN CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR '// . 'NOT FOUND') 904 CALL BORT('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 '// . 'FROM INPUT TO OUTPUT (STANDARD) MESSAGE') 905 CALL BORT('BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) '// . 'MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./stntbia.f0000644001370400056700000000516313440555365011603 0ustar jator2emc SUBROUTINE STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STNTBIA C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR C TABLE A. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) C INPUT ARGUMENT LIST: C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE A C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE A C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE A ENTRY (IN C FORMAT FXXYYY) C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB C CELSQ - CHARACTER*55: SEQUENCE DESCRIPTION CORRESPONDING C TO NUMB C C REMARKS: C THIS ROUTINE CALLS: BORT DIGIT C THIS ROUTINE IS CALLED BY: RDUSDX READS3 STBFDX C Not normally called by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*(*) NUMB, NEMO, CELSQ LOGICAL DIGIT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Confirm that neither NEMO nor NUMB has already been defined C within the internal BUFR Table A (in COMMON /TABABD/) for C the given LUN. DO N=1,NTBA(LUN) IF(NUMB(4:6).EQ.TABA(N,LUN)(1: 3)) GOTO 900 IF(NEMO(1:8).EQ.TABA(N,LUN)(4:11)) GOTO 901 ENDDO C Store the values within the internal BUFR Table A. TABA(N,LUN)( 1: 3) = NUMB(4:6) TABA(N,LUN)( 4:11) = NEMO(1:8) TABA(N,LUN)(13:67) = CELSQ(1:55) C Decode and store the message type and subtype. IF ( DIGIT ( NEMO(3:8) ) ) THEN c .... Message type & subtype obtained directly from Table A mnemonic 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 seq. descriptor READ ( NUMB(4:6),'(I3)') IDNA(N,LUN,1) c .... Message subtype hardwired to ZERO IDNA(N,LUN,2) = 0 ENDIF C Update the count of internal Table A entries. NTBA(LUN) = N RETURN 900 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A FXY VALUE (",A,") ' . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NUMB CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A MNEMONIC (",A,") ' . //'HAS ALREADY BEEN DEFINED (DUPLICATE)")') NEMO CALL BORT(BORT_STR) END ./stntbi.f0000644001370400056700000000365013440555365011441 0ustar jator2emc SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STNTBI C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR C TABLE B OR D, DEPENDING ON THE VALUE OF NUMB. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) C INPUT ARGUMENT LIST: C N - INTEGER: STORAGE INDEX INTO INTERNAL TABLE B OR D C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL TABLE B OR D C NUMB - CHARACTER*6: FXY NUMBER FOR NEW TABLE B OR D ENTRY C (IN FORMAT FXXYYY) C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO NUMB C CELSQ - CHARACTER*55: ELEMENT OR SEQUENCE DESCRIPTION C CORRESPONDING TO NUMB C C REMARKS: C THIS ROUTINE CALLS: IFXY NENUBD C THIS ROUTINE IS CALLED BY: RDUSDX STSEQ C Not normally called by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' CHARACTER*(*) NUMB, NEMO, CELSQ C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL NENUBD ( NEMO, NUMB, LUN ) IF ( NUMB(1:1) .EQ. '0') THEN IDNB(N,LUN) = IFXY(NUMB) TABB(N,LUN)( 1: 6) = NUMB(1:6) TABB(N,LUN)( 7:14) = NEMO(1:8) TABB(N,LUN)(16:70) = CELSQ(1:55) NTBB(LUN) = N ELSE IF ( NUMB(1:1) .EQ. '3') THEN IDND(N,LUN) = IFXY(NUMB) TABD(N,LUN)( 1: 6) = NUMB(1:6) TABD(N,LUN)( 7:14) = NEMO(1:8) TABD(N,LUN)(16:70) = CELSQ(1:55) NTBD(LUN) = N ENDIF RETURN END ./strbtm.f0000644001370400056700000001157713471267220011452 0ustar jator2emc SUBROUTINE STRBTM ( N, LUN ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRBTM C PRGMMR: J. ATOR ORG: NCEP DATE: 2016-05-27 C C ABSTRACT: THIS SUBROUTINE STORES INTERNAL INFORMATION IN C MODULE BITMAPS IF THE INPUT ELEMENT IS PART OF A BITMAP. C C PROGRAM HISTORY LOG: C 2016-05-27 J. ATOR -- ORIGINAL AUTHOR C 2019-05-22 J. ATOR -- ADD CONFIRMATION CHECK C C USAGE: CALL STRBTM ( N, LUN ) C INPUT ARGUMENT LIST: C N - INTEGER: SUBSET ELEMENT C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C ----------------------------------------------------------------- C C THE FOLLOWING VALUES ARE STORED WITHIN MODULE BITMAPS BY THIS C SUBROUTINE AND BY SUBPROGRAMS IGETRFEL, MAKESTAB AND TABSUB: C C NBTM = number of stored bitmaps for the current subset (up to C a maximum of MXBTM) C C NBTMSE(I=1,NBTM) = number of "set" entries (i.e. set to a value C of 0) in the bitmap C C LINBTM = logical variable set to .TRUE. if a bitmap is currently C being read for the current subset C C ISTBTM(I=1,NBTM) = ordinal position in subset corresponding to C first entry of bitmap C C ISZBTM(I=1,NBTM) = size of bitmap (i.e. total number of entries, C whether "set" or not) C C IBTMSE(I=1,NBTM, J=1,NBTMSE(I)) = C ordinal positions in bitmap of bits that were "set"; C these ordinal positions can range in value from 1 to C ISZBTM(I) C C LSTNOD = last jump/link table entry that was processed by C function IGETRFEL and whose corresponding value C type was either numeric or CCITT IA5 C C LSTNODCT = current count of consecutive occurrences of LSTNOD C C NTAMC = number of Table A mnemonics in jump/link table (up to a C maximum of MXTAMC) which contain at least one Table C C operator with an X value of 21 or greater in their C definition; only Table C operators with an X value of 21 C or greater are tracked in this module, since all others C (e.g. 2-01, 2-02, 2-07) are automatically processed C within subroutines TABSUB and TABENT C C INODTAMC(I=1,NTAMC) = location of Table A mnemonic within C jump/link table C C NTCO(I=1,NTAMC) = number of Table C operators (with an X value C of 21 or greater) within the definition of the C given Table A mnemonic C C CTCO(I=1,NTAMC, J=1,NTCO(I)) = Table C operator C C INODTCO(I=1,NTAMC, J=1,NTCO(I)) = C location of Table C operator within jump/link table C C ----------------------------------------------------------------- C C THIS ROUTINE CALLS: BORT IBFMS LSTJPB C THIS ROUTINE IS CALLED BY: RCSTPL RDCMPS C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_USRINT USE MODA_TABLES USE MODA_BITMAPS INCLUDE 'bufrlib.prm' LOGICAL ISBTME C----------------------------------------------------------------------- C----------------------------------------------------------------------- NODE = INV( N, LUN ) IF ( TAG(NODE)(1:5) .EQ. 'DPRI ' ) THEN C Confirm that this is really an entry within a bitmap. C Although it is rare, it is possible for a DPRI element C to appear in a subset definition outside of a bitmap. ISBTME = .FALSE. IF ( NTAMC .GT. 0 ) THEN NODTAM = LSTJPB( NODE, LUN, 'SUB' ) DO II = 1, NTAMC IF ( NODTAM .EQ. INODTAMC(II) ) THEN DO JJ = 1, NTCO(II) IF ( ( INODTCO(II,JJ) .GE. INODE(LUN) ) .AND. . ( INODTCO(II,JJ) .LE. ISC(INODE(LUN)) ) .AND. . ( INODTCO(II,JJ) .LT. NODE ) ) THEN IF ( CTCO(II,JJ) .EQ. '236000' ) THEN ISBTME = .TRUE. ELSE IF ( ( CTCO(II,JJ) .EQ. '235000' ) .OR. . ( CTCO(II,JJ) .EQ. '237255' ) ) THEN ISBTME = .FALSE. END IF END IF END DO END IF END DO END IF IF ( .NOT. ISBTME ) THEN LINBTM = .FALSE. RETURN ELSE IF ( .NOT. LINBTM ) THEN C This is the start of a new bitmap. IF ( NBTM .GE. MXBTM ) GOTO 900 NBTM = NBTM + 1 ISTBTM(NBTM) = N ISZBTM(NBTM) = 0 NBTMSE(NBTM) = 0 LINBTM = .TRUE. END IF ISZBTM(NBTM) = ISZBTM(NBTM) + 1 IF ( IBFMS(VAL(N,LUN)) .EQ. 0 ) THEN C This is a "set" (value=0) entry in the bitmap. IF ( NBTMSE(NBTM) .GE. MXBTMSE ) GOTO 901 NBTMSE(NBTM) = NBTMSE(NBTM) + 1 IBTMSE(NBTM,NBTMSE(NBTM)) = ISZBTM(NBTM) END IF ELSE IF ( ITP(NODE) .GT. 1 ) THEN LINBTM = .FALSE. END IF RETURN 900 CALL BORT('BUFRLIB: STRBTM - MXBTM OVERFLOW') 901 CALL BORT('BUFRLIB: STRBTM - MXBTMSE OVERFLOW') END ./strcln.f0000644001370400056700000000265713440555365011451 0ustar jator2emc SUBROUTINE STRCLN C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRCLN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RESETS THE MNEMONIC STRING CACHE IN THE C BUFR INTERFACE (ARRAYS IN COMMON BLOCK /STCACH/). THE MNEMONIC C STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES TIME C WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A PROGRAM, OVER C AND OVER AGAIN (THE TYPICAL SCENARIO). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 C ELEMENTS TO 1000, MAXIMUM C 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS 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) C C USAGE: CALL STRCLN C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: MAKESTAB 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 /STCACH/ MSTR,NSTR,LSTR,LUNS(MXS,2),USRS(MXS),ICON(52,MXS) CHARACTER*80 USRS MSTR = MXS NSTR = 0 LSTR = 0 RETURN END ./strcpt.f0000644001370400056700000000513013440555365011450 0ustar jator2emc SUBROUTINE STRCPT(CF,IYR,IMO,IDY,IHR,IMI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRCPT C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE CAN BE CALLED AT ANY TIME AFTER THE FIRST C CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. WHEN CF IS SET TO C 'Y' (= 'YES'), THIS SUBROUTINE IS USED TO SPECIFY A TANK RECEIPT C TIME THAT WILL BE APPENDED TO SECTION 1 OF ALL FUTURE BUFR MESSAGES C OUTPUT BY ANY OF THE BUFR ARCHIVE LIBRARY SUBROUTINES WHICH WRITE C SUCH MESSAGES (E.G. WRITSB, COPYMG, WRITSA, ETC.). WHEN CF IS SET C TO 'N' (= 'NO', WHICH IS THE DEFAULT), THIS CAPABILITY IS TURNED OFF C (IF IT WAS PREVIOUSLY TURNED ON) AND THE VALUES IN ALL OF THE OTHER C INPUT ARGUMENTS ARE IGNORED. THE TANK RECEIPT TIME IS A LOCAL C EXTENSION TO SECTION 1; HOWEVER, ITS INCLUSION IN A MESSAGE IS C STILL FULLY COMPLIANT WITH THE WMO FM-94 BUFR REGULATIONS. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL STRCPT (CF,IYR,IMO,IDY,IHR,IMI) C INPUT ARGUMENT LIST: C CF - CHARACTER*1: FLAG INDICATING WHETHER FUTURE CALLS TO C BUFRLIB MESSAGE WRITING ROUTINES (E.G. WRITSB, COPYMG, C WRITSA, ETC.) SHOULD APPEND THE GIVEN TANK RECEIPT C TIME TO SECTION 1 OF SUCH MESSAGES: C 'N' = 'NO' (THE DEFAULT) C 'Y' = 'YES' C IYR - INTEGER: TANK RECEIPT YEAR TO BE STORED C IMO - INTEGER: TANK RECEIPT MONTH TO BE STORED C IDY - INTEGER: TANK RECEIPT DAY TO BE STORED C IHR - INTEGER: TANK RECEIPT HOUR TO BE STORED C IMI - INTEGER: TANK RECEIPT MINUTE TO BE STORED C C REMARKS: C THIS ROUTINE CALLS: BORT CAPIT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT CHARACTER*128 BORT_STR CHARACTER*1 CTRT, CF C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 CTRT = CF IF(CTRT.EQ.'Y') THEN ITRYR = IYR ITRMO = IMO ITRDY = IDY ITRHR = IHR ITRMI = IMI ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,'// . '", IT MUST BE EITHER Y OR N")') CF CALL BORT(BORT_STR) END ./string.f0000644001370400056700000001233013440555365011437 0ustar jator2emc SUBROUTINE STRING(STR,LUN,I1,IO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRING C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER C STRING IS IN THE STRING CACHE (ARRAYS IN COMMON BLOCKS /STCACH/ AND C /STORDS/). IF IT IS NOT IN THE CACHE, IT MUST CALL THE BUFR C ARCHIVE LIBRARY PARSING SUBROUTINE PARUSR TO PERFORM THE TASK OF C SEPARATING AND CHECKING THE INDIVIDUAL "PIECES" (I.E., MNEMONICS) C SO THAT IT CAN THEN BE ADDED TO THE CACHE. IF IT IS ALREADY IN THE C CACHE, THEN THIS EXTRA WORK DOES NOT NEED TO BE PERFORMED. THE C MNEMONIC STRING CACHE IS A PERFORMANCE ENHANCING DEVICE WHICH SAVES C TIME WHEN THE SAME MNEMONIC STRINGS ARE ENCOUNTERED IN A USER C PROGRAM, OVER AND OVER AGAIN (THE TYPICAL SCENARIO). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-04-02 J. WOOLLEN -- MODIFIED TO ENLARGE THE CACHE FROM 50 C ELEMENTS TO 1000, MAXIMUM; OPTIMIZATION OF C THE CACHE SEARCH ALGORITHM IN SUPPORT OF A C BIGGER CACHE 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 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; CHANGED CALL FROM C BORT TO BORT2 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL STRING (STR, LUN, I1, IO) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED MNEMONICS C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C OUTPUT ARGUMENT LIST: C I1 - INTEGER: A NUMBER GREATER THAN OR EQUAL TO THE NUMBER C OF BLANK-SEPARATED MNEMONICS IN STR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C REMARKS: C THIS ROUTINE CALLS: BORT2 PARUSR C THIS ROUTINE IS CALLED BY: UFBEVN UFBGET UFBIN3 UFBINT C UFBOVR UFBREP UFBSTP UFBTAB C UFBTAM C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' PARAMETER (JCONS=52) COMMON /STCACH/ MSTR,NSTR,LSTR,LUX(MXS,2),USR(MXS),ICON(JCONS,MXS) COMMON /USRSTR/ JCON(JCONS) COMMON /STORDS/ IORD(MXS),IORX(MXS) CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*80 USR,UST C---------------------------------------------------------------------- C---------------------------------------------------------------------- NXT = 0 UST = STR IND = INODE(LUN) IF(LEN(STR).GT.80) GOTO 900 C Note that LSTR, MSTR and NSTR were initialized via a prior call to C subroutine STRCLN, which itself was called by subroutine MAKESTAB. C SEE IF STRING IS IN THE CACHE C ----------------------------- DO N=1,NSTR IF(LUX(IORD(N),2).EQ.IND) THEN IORX(NXT+1) = IORD(N) NXT = NXT+1 ENDIF ENDDO DO N=1,NXT IF(UST.EQ.USR(IORX(N)))GOTO1 ENDDO GOTO2 C IF IT IS IN THE CACHE, COPY PARAMETERS FROM THE CACHE C ----------------------------------------------------- 1 DO J=1,JCONS JCON(J) = ICON(J,IORX(N)) ENDDO GOTO 100 C IF IT IS NOT IN THE CACHE, PARSE IT AND PUT IT THERE C ---------------------------------------------------- 2 CALL PARUSR(STR,LUN,I1,IO) LSTR = MAX(MOD(LSTR+1,MSTR+1),1) NSTR = MIN(NSTR+1,MSTR) c .... File LUX(LSTR,1) = LUN c .... Table A entry LUX(LSTR,2) = IND USR(LSTR) = STR DO J=1,JCONS ICON(J,LSTR) = JCON(J) ENDDO C REARRANGE THE CACHE ORDER AFTER AN UPDATE C ----------------------------------------- DO N=NSTR,2,-1 IORD(N) = IORD(N-1) ENDDO IORD(1) = LSTR 100 IF(JCON(1).GT.I1) GOTO 901 C EXITS C ----- RETURN 900 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,") HAS")') . STR WRITE(BORT_STR2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') . LEN(STR) CALL BORT2(BORT_STR1,BORT_STR2) 901 WRITE(BORT_STR1,'("BUFRLIB: STRING - INPUT STRING (",A,")")') STR WRITE(BORT_STR2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE '// . 'LIMIT (THIRD INPUT ARGUMENT) IS",I5)') JCON(1),I1 CALL BORT2(BORT_STR1,BORT_STR2) END ./strnum.f0000644001370400056700000000542013440555365011463 0ustar jator2emc SUBROUTINE STRNUM(STR,NUM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRNUM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE DECODES AN INTEGER FROM A CHARACTER STRING. C THE INPUT STRING SHOULD CONTAIN ONLY DIGITS AND (OPTIONAL) TRAILING C BLANKS AND SHOULD NOT CONTAIN ANY SIGN CHARACTERS (E.G. '+', '-') C NOR LEADING BLANKS NOR EMBEDDED BLANKS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL STRNUM (STR, NUM) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING CONTAINING ENCODED INTEGER VALUE C C OUTPUT ARGUMENT LIST: C NUM - INTEGER: DECODED VALUE C -1 = decode was unsuccessful C C REMARKS: C THIS ROUTINE CALLS: ERRWRT STRSUC C THIS ROUTINE IS CALLED BY: JSTNUM PARUTG SEQSDX SNTBFE C STSEQ C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR CHARACTER*20 STR2 COMMON /QUIET / IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- NUM = 0 K = 0 C Note that, in the following call to subroutine STRSUC, the output C string STR2 is not used anywhere else in this routine. In fact, C the only reason that subroutine STRSUC is being called here is to C determine NUM, which, owing to the fact that the input string STR C cannot contain any leading blanks, is equal to the number of C digits to be decoded from the beginning of STR. CALL STRSUC(STR,STR2,NUM) IF(NUM.EQ.-1) GOTO 100 DO I=1,NUM READ(STR(I:I),'(I1)',ERR=99) J IF(J.EQ.0 .AND. STR(I:I).NE.'0') GOTO 99 K = K*10+J ENDDO NUM = K GOTO 100 C Note that NUM = -1 unambiguously indicates a bad decode since C the input string cannot contain sign characters; thus, NUM is C always positive if the decode is successful. 99 NUM = -1 IF(IPRT.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: STRNUM - BAD DECODE; RETURN WITH NUM = -1') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXIT C ---- 100 RETURN END ./strsuc.f0000644001370400056700000000555113440555365011463 0ustar jator2emc SUBROUTINE STRSUC(STR1,STR2,LENS) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRSUC C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE REMOVES LEADING AND TRAILING BLANKS FROM A C STRING. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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; ADDED MORE COMPLETE C DIAGNOSTIC INFO WHEN UNUSUAL THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: CALL STRSUC (STR1, STR2, LENS) C INPUT ARGUMENT LIST: C STR1 - CHARACTER*(*): STRING C C OUTPUT ARGUMENT LIST: C STR2 - CHARACTER*(*): COPY OF STR1 WITH LEADING AND TRAILING C BLANKS REMOVED C LENS - INTEGER: LENGTH OF STR2: C -1 = STR1 contained embedded blanks C C REMARKS: C THIS ROUTINE CALLS: ERRWRT C THIS ROUTINE IS CALLED BY: DXDUMP GETTAGRE HOLD4WLC MTFNAM C MTINFO NEMSPECS STRNUM UFDUMP C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) STR1,STR2 COMMON /QUIET / IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- LENS = 0 LSTR = LEN(STR1) C FIND THE FIRST NON-BLANK IN THE INPUT STRING C -------------------------------------------- DO I=1,LSTR IF(STR1(I:I).NE.' ') GOTO 2 ENDDO GOTO 100 C Now, starting with the first non-blank in the input string, C copy characters from the input string into the output string C until reaching the next blank in the input string. 2 DO J=I,LSTR IF(STR1(J:J).EQ.' ') GOTO 3 LENS = LENS+1 STR2(LENS:LENS) = STR1(J:J) ENDDO GOTO 100 C Now, continuing on within the input string, make sure that C there are no more non-blank characters. If there are, then C the blank at which we stopped copying from the input string C into the output string was an embedded blank. 3 DO I=J,LSTR IF(STR1(I:I).NE.' ') LENS = -1 ENDDO IF(LENS.EQ.-1 .AND. IPRT.GE.0) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT('BUFRLIB: STRSUC - INPUT STRING:') CALL ERRWRT(STR1) CALL ERRWRT('CONTAINS ONE OR MORE EMBEDDED BLANKS') CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXIT C ---- 100 RETURN END ./strtbfe.c0000644001370400056700000000407113440555365011602 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STRTBFE C PRGMMR: ATOR ORG: NCEP DATE: 2017-11-13 C C ABSTRACT: THIS ROUTINE STORES A NEW ENTRY INTO THE INTERNAL MEMORY C STRUCTURE FOR CODE/FLAG TABLE INFORMATION. C C PROGRAM HISTORY LOG: C 2017-11-13 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL STRTBFE ( IFXYN, IVAL, MEANING, LMEANING, C IDFXY, IDVAL ) C C INPUT ARGUMENT LIST: C IFXYN - INTEGER: BIT-WISE REPRESENTATION OF FXY NUMBER FOR C WHICH IVAL IS A DEFINED CODE OR FLAG TABLE ENTRY C IVAL - INTEGER: CODE FIGURE OR BIT NUMBER C MEANING - CHARACTER*(*): MEANING ASSOCIATED WITH IVAL C LMEANING - INTEGER: LENGTH (IN BYTES) OF MEANING C IDFXY - INTEGER: BIT-WISE REPRESENTATION OF OTHER FXY NUMBER C UPON WHICH IVAL IS DEPENDENT, IF ANY C -1 = NO DEPENDENCY C IDVAL - INTEGER: CODE FIGURE OR BIT NUMBER ASSOCIATED WITH C IDFXY AND UPON WHICH IVAL IS DEPENDENT, IF ANY C -1 = NO DEPENDENCY C C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: SNTBFE C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "cfe.h" void strtbfe( f77int *ifxyn, f77int *ival, char *meaning, f77int *lmeaning, f77int *idfxy, f77int *idval ) { unsigned int mnlen; static char brtstr[50] = "BUFRLIB: STRTBFE - MXMTBF OVERFLOW"; /* ** Confirm that there's room for another entry in the structure. */ if ( nmtf >= mxmtbf ) bort( brtstr, ( f77int ) strlen( brtstr ) ); /* ** Store the new entry. */ cfe[nmtf].iffxyn = *ifxyn; cfe[nmtf].ifval = *ival; mnlen = ( *lmeaning > MAX_MEANING_LEN ? MAX_MEANING_LEN : *lmeaning ); strncpy( &cfe[nmtf].ifmeaning[0], meaning, mnlen ); cfe[nmtf].ifmeaning[mnlen] = '\0'; cfe[nmtf].iffxynd = *idfxy; cfe[nmtf].ifvald = *idval; nmtf++; } ./stseq.c0000644001370400056700000003432313440555365011273 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: STSEQ C PRGMMR: ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: USING THE BUFR MASTER TABLES, THIS ROUTINE STORES ALL C OF THE INFORMATION FOR SEQUENCE IDN WITHIN THE INTERNAL BUFR C TABLES B AND D. ANY DESCRIPTORS IN IDN WHICH ARE THEMSELVES C SEQUENCES ARE IMMEDIATELY RESOLVED VIA A RECURSIVE CALL TO THIS C SAME ROUTINE. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR C 2010-03-19 J. ATOR -- ADDED PROCESSING FOR 2-04 ASSOCIATED FIELDS C 2010-04-05 J. ATOR -- ADDED PROCESSING FOR 2-2X, 2-3X AND 2-4X C NON-MARKER OPERATORS C 2015-03-04 J. ATOR -- HANDLE SPECIAL CASE WHEN ASSOCIATED FIELDS C ARE IN EFFECT FOR A TABLE D DESCRIPTOR C C USAGE: CALL STSEQ( LUN, IREPCT, IDN, NEMO, CSEQ, CDESC, NCDESC ) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D C IDN - INTEGER: BIT-WISE REPRESENTATION OF FXY VALUE FOR C SEQUENCE TO BE STORED C NEMO - CHARACTER*8: MNEMONIC CORRESPONDING TO IDN C CSEQ - CHARACTER*55: DESCRIPTION CORRESPONDING TO IDN C CDESC - INTEGER: ARRAY OF BIT-WISE REPRESENTATIONS OF FXY C VALUES CORRESPONDING TO DESCRIPTORS WHICH CONSTITUTE C THE IDN SEQUENCE C NCDESC - INTEGER: NUMBER OF VALUES IN CDESC C C OUTPUT ARGUMENT LIST: C IREPCT - INTEGER: REPLICATION SEQUENCE COUNTER FOR THE CURRENT C MASTER TABLE; USED INTERNALLY TO KEEP TRACK OF WHICH C SEQUENCE NAMES HAVE ALREADY BEEN DEFINED AND THEREBY C AVOID CONTENTION WITHIN THE INTERNAL BUFR TABLE D C C REMARKS: C THIS ROUTINE CALLS: BORT CADN30 ELEMDX ICVIDX C IFXY IGETNTBI IGETPRM IGETTDI C IMRKOPR NEMTAB NUMMTB NUMTBD C PKTDD STNTBI STRNUM STSEQ C THIS ROUTINE IS CALLED BY: READS3 STSEQ C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" #include "mstabs.h" void stseq( f77int *lun, f77int *irepct, f77int *idn, char nemo[8], char cseq[55], f77int cdesc[], f77int *ncdesc ) { f77int i, j, nb, nd, ipt, ix, iy, iret, nbits; f77int i0 = 0, imxcd, rpidn, pkint, ilen; char tab, adn[7], adn2[7], nemo2[9], units[10], errstr[129]; char rpseq[56], card[80], cblk = ' '; /* ** The following variable is declared as automatic so that a local ** private copy is created (and, if necessary, dynamically allocated) ** during each recursive call to this subroutine. */ #ifdef DYNAMIC_ALLOCATION f77int *rpdesc; #else f77int rpdesc[MAXCD]; #endif /* ** The following variables are declared as static so that they ** automatically initialize to zero and remain unchanged between ** recursive calls to this subroutine. */ static f77int naf, iafpk[MXNAF]; /* ** Is *idn already listed as an entry in the internal Table D? ** If so, then there's no need to proceed any further. */ numtbd( lun, idn, nemo2, &tab, &iret, sizeof( nemo2 ), sizeof( tab ) ); if ( ( iret > 0 ) && ( tab == 'D' ) ) return; /* ** Start a new Table D entry for *idn. */ tab = 'D'; nd = igetntbi( lun, &tab, sizeof ( tab ) ); cadn30( idn, adn, sizeof( adn ) ); stntbi( &nd, lun, adn, nemo, cseq, sizeof( adn ), 8, 55 ); /* ** Now, go through the list of child descriptors corresponding to *idn. */ imxcd = igetprm( "MAXCD", 5 ); for ( i = 0; i < *ncdesc; i++ ) { cadn30( &cdesc[i], adn, sizeof( adn ) ); if ( adn[0] == '3' ) { /* ** cdesc[i] is itself a Table D descriptor, so locate it within the ** master table D and then store the contents within the internal ** Table D via a recursive call to this same routine. */ nummtb( &cdesc[i], &tab, &ipt ); if ( naf > 0 ) { /* ** There are associated fields in effect which will modify this ** descriptor when storing it within the internal Table D. So ** create a new sequence to store the contents of this descriptor ** along with its associated fields. */ rpidn = igettdi( lun ); sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", ( unsigned long ) ++(*irepct) ); memset( &rpseq[24], (int) cblk, 31 ); sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); stseq( lun, irepct, &rpidn, nemo2, rpseq, &MSTABS_BASE(idefxy)[icvidx(&ipt,&i0,&imxcd)], &MSTABS_BASE(ndelem)[ipt] ); pkint = rpidn; } else { /* ** Store cdesc[i] as is directly within the internal Table D. */ stseq( lun, irepct, &cdesc[i], &MSTABS_BASE(cdmnem)[ipt][0], &MSTABS_BASE(cdseq)[ipt][0], &MSTABS_BASE(idefxy)[icvidx(&ipt,&i0,&imxcd)], &MSTABS_BASE(ndelem)[ipt] ); pkint = cdesc[i]; } } else if ( adn[0] == '2' ) { /* ** cdesc[i] is an operator descriptor. */ strnum( &adn[1], &ix, 2 ); strnum( &adn[3], &iy, 3 ); if ( ( ( ix >= 4 ) && ( ix <= 6 ) ) || ( imrkopr( adn, 6 ) ) ) { /* ** This is a 204YYY, 205YYY, 206YYY operator, or else a 223255, ** 224255, 225255 or 232255 marker operator. In any case, ** generate a Table B mnemonic to hold the corresponding data. */ strncpy( nemo2, adn, 6 ); memset( &nemo2[6], (int) cblk, 2 ); if ( ( ix == 4 ) && ( iy == 0 ) ) { /* ** Cancel the most-recently added associated field. */ if ( naf-- <= 0 ) { sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" " FIELD CANCELLATION OPERATORS" ); bort( errstr, ( f77int ) strlen( errstr ) ); } } else { /* ** Is nemo2 already listed as an entry within the internal ** Table B? */ nemtab( lun, nemo2, &pkint, &tab, &iret, 8, sizeof( tab ) ); if ( ( iret == 0 ) || ( tab != 'B' ) ) { /* ** No, so create and store a new Table B entry for nemo2. */ tab = 'B'; nb = igetntbi( lun, &tab, sizeof( tab ) ); if ( ix == 4 ) { sprintf( rpseq, "Associated field of %3lu bits", ( unsigned long ) iy ); nbits = iy; strcpy( units, "NUMERIC" ); } else if ( ix == 5 ) { sprintf( rpseq, "Text string of %3lu bytes", ( unsigned long ) iy ); nbits = iy*8; strcpy( units, "CCITT IA5" ); } else if ( ix == 6 ) { sprintf( rpseq, "Local descriptor of %3lu bits", ( unsigned long ) iy ); nbits = iy; if ( nbits > 32 ) { strcpy( units, "CCITT IA5" ); } else { strcpy( units, "NUMERIC" ); } } else { // 2-XX-255 marker operator adn[6] = '\0'; if ( ix == 23 ) { sprintf( rpseq, "Substituted value" ); } else if ( ix == 24 ) { sprintf( rpseq, "First-order statistical value" ); } else if ( ix == 25 ) { sprintf( rpseq, "Difference statistical value" ); } else if ( ix == 32 ) { sprintf( rpseq, "Replaced/retained value" ); } /* For now, set a default bit width and units. */ nbits = 8; strcpy( units, "NUMERIC" ); } ilen = ( f77int ) strlen( rpseq ); memset( &rpseq[ilen], (int) cblk, 55 - ilen ); /* ** Note that 49152 = 3*(2**14), so subtracting 49152 in the ** following statement changes a Table D bitwise FXY value into ** a Table B bitwise FXY value. */ pkint = ( igettdi( lun ) - 49152 ); cadn30( &pkint, adn2, sizeof( adn2 ) ); stntbi( &nb, lun, adn2, nemo2, rpseq, sizeof( adn2 ), 8, 55 ); /* Initialize card to all blanks. */ memset( card, (int) cblk, sizeof( card ) ); strncpy( &card[2], nemo2, 8 ); strncpy( &card[16], "0", 1 ); strncpy( &card[30], "0", 1 ); sprintf( &card[33], "%4lu", ( unsigned long ) nbits ); strncpy( &card[40], units, strlen( units ) ); elemdx( card, lun, sizeof( card ) ); } if ( ix == 4 ) { /* ** Add an associated field. */ if ( naf >= MXNAF ) { sprintf( errstr, "BUFRLIB: STSEQ - TOO MANY ASSOCIATED" " FIELDS ARE IN EFFECT AT THE SAME TIME" ); bort( errstr, ( f77int ) strlen( errstr ) ); } iafpk[naf++] = pkint; } } if ( ix == 6 ) { /* ** Skip over the local descriptor placeholder. */ if ( ++i >= *ncdesc ) { sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND LOCAL" " DESCRIPTOR PLACEHOLDER FOR %s", adn ); bort( errstr, ( f77int ) strlen( errstr ) ); } } } else { pkint = cdesc[i]; } } else if ( adn[0] == '1' ) { /* ** cdesc[i] is a replication descriptor, so create a sequence ** consisting of the set of replicated descriptors and then immediately ** store that sequence within the internal Table D via a recursive call ** to this same routine. */ adn[6] = '\0'; strnum( &adn[3], &iy, 3 ); /* ** See subroutine BFRINI and COMMON /REPTAB/ for the source of the FXY ** values referenced in the following block. Note we are guaranteed ** that 0 <= iy <= 255 since adn was generated using subroutine CADN30. */ if ( iy == 0 ) { /* delayed replication */ if ( ( i+1 ) >= *ncdesc ) { sprintf( errstr, "BUFRLIB: STSEQ - COULD NOT FIND DELAYED " "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); bort( errstr, ( f77int ) strlen( errstr ) ); } else if ( cdesc[i+1] == ifxy( "031002", 6 ) ) { pkint = ifxy( "360001", 6 ); } else if ( cdesc[i+1] == ifxy( "031001", 6 ) ) { pkint = ifxy( "360002", 6 ); } else if ( cdesc[i+1] == ifxy( "031000", 6 ) ) { pkint = ifxy( "360004", 6 ); } else { sprintf( errstr, "BUFRLIB: STSEQ - UNKNOWN DELAYED " "DESCRIPTOR REPLICATION FACTOR FOR %s", adn ); bort( errstr, ( f77int ) strlen( errstr ) ); } i += 2; } else { /* regular replication */ pkint = ifxy( "101000", 6 ) + iy; i++; } /* ** Store this replication descriptor within the table D entry for ** this parent. */ pktdd( &nd, lun, &pkint, &iret ); if ( iret < 0 ) { strncpy( nemo2, nemo, 8 ); nemo2[8] = '\0'; sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " "STORING REPLICATOR FOR PARENT MNEMONIC %s", nemo2 ); bort( errstr, ( f77int ) strlen( errstr ) ); } strnum( &adn[1], &ix, 2 ); /* ** Note we are guaranteed that 0 < ix <= 63 since adn was generated ** using subroutine CADN30. */ if ( ix > ( *ncdesc - i ) ) { sprintf( errstr, "BUFRLIB: STSEQ - NOT ENOUGH REMAINING CHILD " "DESCRIPTORS TO COMPLETE REPLICATION FOR %s", adn ); bort( errstr, ( f77int ) strlen( errstr ) ); } else if ( ( ix == 1 ) && ( cdesc[i] >= ifxy ( "300000", 6 ) ) ) { /* ** The only thing being replicated is a single Table D descriptor, ** so there's no need to invent a new sequence for this replication ** (this is a special case!) */ nummtb( &cdesc[i], &tab, &ipt ); stseq( lun, irepct, &cdesc[i], &MSTABS_BASE(cdmnem)[ipt][0], &MSTABS_BASE(cdseq)[ipt][0], &MSTABS_BASE(idefxy)[icvidx(&ipt,&i0,&imxcd)], &MSTABS_BASE(ndelem)[ipt] ); pkint = cdesc[i]; } else { /* ** Store the ix descriptors to be replicated in a local list, then ** get an FXY value to use with this list and generate a unique ** mnemonic and description as well. */ #ifdef DYNAMIC_ALLOCATION if ( ( rpdesc = malloc( imxcd * sizeof(f77int) ) ) == NULL ) { sprintf( errstr, "BUFRLIB: STSEQ - UNABLE TO ALLOCATE SPACE" " FOR RPDESC" ); bort( errstr, ( f77int ) strlen( errstr ) ); } #endif for ( j = 0; j < ix; j++ ) { rpdesc[j] = cdesc[i+j]; } rpidn = igettdi( lun ); sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", ( unsigned long ) ++(*irepct) ); memset( &rpseq[24], (int) cblk, 31 ); sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); stseq( lun, irepct, &rpidn, nemo2, rpseq, rpdesc, &ix ); #ifdef DYNAMIC_ALLOCATION free( rpdesc ); #endif pkint = rpidn; i += ix - 1; } } else { /* ** cdesc[i] is a Table B descriptor. ** ** Is cdesc[i] already listed as an entry in the internal Table B? */ numtbd( lun, &cdesc[i], nemo2, &tab, &iret, sizeof( nemo2 ), sizeof( tab ) ); if ( ( iret == 0 ) || ( tab != 'B' ) ) { /* ** No, so search for it within the master table B. */ nummtb( &cdesc[i], &tab, &ipt ); /* ** Start a new Table B entry for cdesc[i]. */ nb = igetntbi( lun, &tab, sizeof( tab ) ); cadn30( &cdesc[i], adn2, sizeof( adn2 ) ); stntbi( &nb, lun, adn2, &MSTABS_BASE(cbmnem)[ipt][0], &MSTABS_BASE(cbelem)[ipt][0], sizeof( adn2 ), 8, 55 ); /* Initialize card to all blanks. */ memset( card, (int) cblk, sizeof( card ) ); strncpy( &card[2], &MSTABS_BASE(cbmnem)[ipt][0], 8 ); strncpy( &card[13], &MSTABS_BASE(cbscl)[ipt][0], 4 ); strncpy( &card[19], &MSTABS_BASE(cbsref)[ipt][0], 12 ); strncpy( &card[33], &MSTABS_BASE(cbbw)[ipt][0], 4 ); strncpy( &card[40], &MSTABS_BASE(cbunit)[ipt][0], 14 ); elemdx( card, lun, sizeof( card ) ); } pkint = cdesc[i]; } if ( strncmp( adn, "204", 3 ) != 0 ) { /* ** Store this child descriptor within the table D entry for this ** parent, preceding it with any associated fields that are currently ** in effect. ** ** Note that associated fields are only applied to Table B descriptors, ** except for those in Class 31. */ if ( ( naf > 0 ) && ( pkint < ifxy( "100000", 6 ) ) && ( ( pkint < ifxy( "031000", 6 ) ) || ( pkint > ifxy( "031255", 6 ) ) ) ) { for ( j = 0; j < naf; j++ ) { pktdd( &nd, lun, &iafpk[j], &iret ); if ( iret < 0 ) { sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD " "WHEN STORING ASSOCIATED FIELDS" ); bort( errstr, ( f77int ) strlen( errstr ) ); } } } /* ** Store the child descriptor. */ pktdd( &nd, lun, &pkint, &iret ); if ( iret < 0 ) { strncpy( nemo2, nemo, 8 ); nemo2[8] = '\0'; sprintf( errstr, "BUFRLIB: STSEQ - BAD RETURN FROM PKTDD WHEN " "STORING CHILD FOR PARENT MNEMONIC %s", nemo2 ); bort( errstr, ( f77int ) strlen( errstr ) ); } } } } ./tabent.f0000644001370400056700000001362013440555365011411 0ustar jator2emc SUBROUTINE TABENT(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: TABENT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR C TABLE D MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS C 2010-03-19 J. ATOR -- ADDED SUPPORT FOR 204 OPERATOR C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL TABENT (LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C NEMO - CHARACTER*8: TABLE B OR D MNEMONIC TO STORE IN JUMP/ C LINK TABLE C TAB - CHARACTER*1: INTERNAL BUFR TABLE ARRAY ('B' OR 'D') IN C WHICH NEMO IS DEFINED C ITAB - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB C IREP - INTEGER: POSITIONAL INDEX WITHIN COMMON /REPTAB/ C ARRAYS, FOR USE WHEN NEMO IS REPLICATED: C 0 = NEMO is not replicated C IKNT - INTEGER: NUMBER OF REPLICATIONS, FOR USE WHEN NEMO IS C REPLICATED USING F=1 REGULAR (I.E., NON-DELAYED) C REPLICATION: C 0 = NEMO is not replicated using F=1 regular C (i.e., non-delayed) replication C JUM0 - INTEGER: INDEX VALUE TO BE STORED FOR NEMO WITHIN C INTERNAL JUMP/LINK TABLE ARRAY JMPB(*) C C REMARKS: C THIS ROUTINE CALLS: BORT INCTAB NEMTBB C THIS ROUTINE IS CALLED BY: TABSUB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES USE MODA_NRV203 INCLUDE 'bufrlib.prm' C Note that the values within the COMMON /REPTAB/ arrays were C initialized within subroutine BFRINI. COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW CHARACTER*128 BORT_STR CHARACTER*24 UNIT CHARACTER*10 RTAG CHARACTER*8 NEMO CHARACTER*3 TYPS,TYPT CHARACTER*1 REPS,TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR C --------------------------------------------- IF(IREP.NE.0) THEN RTAG = REPS(IREP,1)//NEMO DO I=1,10 IF(RTAG(I:I).EQ.' ') THEN RTAG(I:I) = REPS(IREP,2) CALL INCTAB(RTAG,TYPS(IREP,1),NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = LENS(IREP) IRF (NODE) = 0 ISC (NODE) = 0 IF(IREP.EQ.1) IRF(NODE) = IKNT JUM0 = NODE GOTO 1 ENDIF ENDDO GOTO 900 ENDIF C MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE C ---------------------------------------------------- 1 IF(TAB.EQ.'B') THEN CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) IF(UNIT(1:5).EQ.'CCITT') THEN TYPT = 'CHR' ELSE TYPT = 'NUM' ENDIF CALL INCTAB(NEMO,TYPT,NODE) JUMP(NODE) = 0 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = IBIT IRF (NODE) = IREF ISC (NODE) = ISCL IF(UNIT(1:4).EQ.'CODE') THEN TYPT = 'COD' ELSEIF(UNIT(1:4).EQ.'FLAG') THEN TYPT = 'FLG' ENDIF IF( (TYPT.EQ.'NUM') .AND. (IBTNRV.NE.0) ) THEN C This node contains a new (redefined) reference value. IF(NNRV+1.GT.MXNRV) GOTO 902 NNRV = NNRV+1 TAGNRV(NNRV) = NEMO INODNRV(NNRV) = NODE ISNRV(NNRV) = NODE+1 IBT(NODE) = IBTNRV IF(IPFNRV.EQ.0) IPFNRV = NNRV ELSEIF( (TYPT.EQ.'NUM') .AND. (NEMO(1:3).NE.'204') ) THEN IBT(NODE) = IBT(NODE) + ICDW ISC(NODE) = ISC(NODE) + ICSC IRF(NODE) = IRF(NODE) * ICRV ELSEIF( (TYPT.EQ.'CHR') .AND. (INCW.GT.0) ) THEN IBT(NODE) = INCW * 8 ENDIF ELSEIF(TAB.EQ.'D') THEN IF(IREP.EQ.0) THEN TYPT = 'SEQ' ELSE TYPT = TYPS(IREP,2) ENDIF CALL INCTAB(NEMO,TYPT,NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = 0 IRF (NODE) = 0 ISC (NODE) = 0 ELSE GOTO 901 ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: TABENT - REPLICATOR ERROR FOR INPUT '// . 'MNEMONIC ",A,", RTAG IS ",A)') NEMO,RTAG CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: TABENT - UNDEFINED TAG (",A,") FOR '// . 'INPUT MNEMONIC ",A)') TAB,NEMO CALL BORT(BORT_STR) 902 CALL BORT('BUFRLIB: TABENT - MXNRV OVERFLOW') END ./tabsub.f0000644001370400056700000004307413440555365011422 0ustar jator2emc SUBROUTINE TABSUB(LUN,NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: TABSUB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E., C INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE C A MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 2000-09-19 J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA C USING THE OPERATOR DESCRIPTORS (BUFR TABLE C C) FOR CHANGING WIDTH AND CHANGING SCALE 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2005-11-29 J. ATOR -- ADDED SUPPORT FOR 207 AND 208 OPERATORS C 2012-03-02 J. ATOR -- ADDED SUPPORT FOR 203 OPERATOR C 2012-04-19 J. ATOR -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR C IMMEDIATELY FOLLOWS A TABLE D SEQUENCE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2016-05-24 J. ATOR -- STORE TABLE C OPERATORS IN MODULE BITMAPS C 2017-04-03 J. ATOR -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT C EACH SUBSET DEFINITION IN THE JUMP/LINK C TABLE HAS ITS OWN SET OF TABLE C OPERATORS C C USAGE: CALL TABSUB (LUN, NEMO) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C NEMO - CHARACTER*8: TABLE A MNEMONIC C C REMARKS: C ----------------------------------------------------------------- C EXAMPLE SHOWING CONTENTS OF INTERNAL JUMP/LINK TABLE (WITHIN C MODULE TABLES): C C INTEGER MAXTAB = maximum number of jump/link table entries C C INTEGER NTAB = actual number of jump/link table entries C currently in use C C For I = 1, NTAB: C C CHARACTER*10 TAG(I) = mnemonic C C CHARACTER*3 TYP(I) = mnemonic type indicator: C "SUB" if TAG(I) is a Table A mnemonic C "SEQ" if TAG(I) is a Table D mnemonic using either short C (i.e. 1-bit) delayed replication, F=1 regular (i.e. C non-delayed) replication, or no replication at all C "RPC" if TAG(I) is a Table D mnemonic using either medium C (i.e. 8-bit) delayed replication or long (i.e. 16-bit) C delayed replication C "RPS" if TAG(I) is a Table D mnemonic using medium C (i.e. 8-bit) delayed replication in a stack context C "DRB" if TAG(I) denotes the short (i.e. 1-bit) delayed C replication of a Table D mnemonic (which would then C itself have its own separate entry in the jump/link C table with a corresponding TAG value of "SEQ") C "DRP" if TAG(I) denotes either the medium (i.e. 8-bit) or C long (i.e. 16-bit) delayed replication of a Table D C mnemonic (which would then itself have its own separate C entry in the jump/link table with a corresponding TAG C value of "RPC") C "DRS" if TAG(I) denotes the medium (i.e. 8-bit) delayed C replication, in a stack context, of a Table D mnemonic C (which would then itself have its own separate entry C in the jump/link table with a corresponding TAG value C of "RPS") C "REP" if TAG(I) denotes the F=1 regular (i.e. non-delayed) C replication of a Table D mnemonic (which would then C itself have its own separate entry in the jump/link C table with a corresponding TAG value of "SEQ") C "CHR" if TAG(I) is a Table B mnemonic with units "CCITT IA5" C "NUM" if TAG(I) is a Table B mnemonic with any units other C than "CCITT IA5" C C INTEGER JMPB(I): C C IF ( TYP(I) = "SUB" ) THEN C JMPB(I) = 0 C ELSE IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. C 1-bit) delayed replication or F=1 regular (i.e. C non-delayed) replication ) C OR C ( TYP(I) = "RPC" ) ) THEN C JMPB(I) = the index of the jump/link table entry denoting C the replication of TAG(I) C ELSE C JMPB(I) = the index of the jump/link table entry for the C Table A or Table D mnemonic of which TAG(I) is a C child C END IF C C INTEGER JUMP(I): C C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN C JUMP(I) = 0 C ELSE IF ( ( TYP(I) = "DRB" ) OR C ( TYP(I) = "DRP" ) OR C ( TYP(I) = "REP" ) ) THEN C JUMP(I) = the index of the jump/link table entry for the C Table D mnemonic whose replication is denoted by C TAG(I) C ELSE C JUMP(I) = the index of the jump/link table entry for the C Table B or Table D mnemonic which, sequentially, C is the first child of TAG(I) C END IF C C INTEGER LINK(I): C C IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. C 1-bit) delayed replication or F=1 regular (i.e. non- C delayed) replication ) C OR C ( TYP(I) = "SUB" ) C OR C ( TYP(I) = "RPC" ) ) THEN C LINK(I) = 0 C ELSE IF ( TAG(I) is, sequentially, the last child Table B or C Table D mnemonic of the parent Table A or Table D C mnemonic indexed by JMPB(I) ) THEN C LINK(I) = 0 C ELSE C LINK(I) = the index of the jump/link table entry for the C Table B or Table D mnemonic which, sequentially, C is the next (i.e. following TAG(I)) child mnemonic C of the parent Table A or Table D mnemonic indexed C by JMPB(I) C END IF C C INTEGER IBT(I): C C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN C IBT(I) = bit width of Table B mnemonic TAG(I) C ELSE IF ( ( TYP(I) = "DRB" ) OR ( TYP(I) = "DRP" ) ) THEN C IBT(I) = bit width of delayed descriptor replication factor C (i.e. 1, 8, or 16, depending on the replication C scheme denoted by TAG(I)) C ELSE C IBT(I) = 0 C END IF C C INTEGER IRF(I): C C IF ( TYP(I) = "NUM" ) THEN C IRF(I) = reference value of Table B mnemonic TAG(I) C ELSE IF ( TYP(I) = "REP" ) THEN C IRF(I) = number of F=1 regular (i.e. non-delayed) C replications of Table D mnemonic TAG(JUMP(I)) C ELSE C IRF(I) = 0 C END IF C C INTEGER ISC(I): C C IF ( TYP(I) = "NUM" ) THEN C ISC(I) = scale factor of Table B mnemonic TAG(I) C ELSE IF ( TYP(I) = "SUB" ) THEN C ISC(I) = the index of the jump/link table entry which, C sequentially, constitutes the last element of the C jump/link tree for Table A mnemonic TAG(I) C ELSE C ISC(I) = 0 C END IF C C ----------------------------------------------------------------- C C THE FOLLOWING VALUES ARE STORED WITHIN MODULE NRV203 BY THIS C SUBROUTINE, FOR USE WITH ANY 2-03-YYY (CHANGE REFERENCE VALUE) C OPERATORS PRESENT WITHIN THE ENTIRE JUMP/LINK TABLE: C C NNRV = number of nodes in the jump/link table which contain new C reference values (as defined using the 2-03 operator) C C INODNRV(I=1,NNRV) = nodes within jump/link table which contain C new reference values C C NRV(I=1,NNRV) = new reference value corresponding to INODNRV(I) C C TAGNRV(I=1,NNRV) = Table B mnemonic to which the new reference C value in NRV(I) applies C C ISNRV(I=1,NNRV) = start of node range in jump/link table, C within which the new reference value defined C by NRV(I) will be applied to all occurrences C of TAGNRV(I) C C IENRV(I=1,NNRV) = end of node range in jump/link table, C within which the new reference value defined C by NRV(I) will be applied to all occurrences C of TAGNRV(I) C C IBTNRV = number of bits in Section 4 occupied by each new C reference value for the current 2-03 operator C (if IBTNRV = 0, then no 2-03 operator is currently C in scope) C C IPFNRV = a number between 1 and NNRV, denoting the first entry C within the above arrays which applies to the current C Table A mnemonic NEMO (if IPFNRV = 0, then no 2-03 C operators have been applied to NEMO) C C ----------------------------------------------------------------- C C THIS ROUTINE CALLS: BORT INCTAB IOKOPER NEMTAB C NEMTBD TABENT C THIS ROUTINE IS CALLED BY: MAKESTAB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES USE MODA_NMIKRP USE MODA_NRV203 USE MODA_BITMAPS INCLUDE 'bufrlib.prm' COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW CHARACTER*128 BORT_STR CHARACTER*8 NEMO,NEMS CHARACTER*1 TAB DIMENSION DROP(10),JMP0(10),NODL(10),NTAG(10,2) LOGICAL DROP,LTAMC DATA MAXLIM /10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE MNEMONIC C ------------------ C Note that Table A mnemonics, in addition to being stored within C internal BUFR Table A array TABA(*,LUN), are also stored as C Table D mnemonics within internal BUFR Table D array TABD(*,LUN). C Thus, the following test is valid. CALL NEMTAB(LUN,NEMO,IDN,TAB,ITAB) IF(TAB.NE.'D') GOTO 900 C STORE A SUBSET NODE AND JUMP/LINK THE TREE C ------------------------------------------ CALL INCTAB(NEMO,'SUB',NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = 0 LINK(NODE) = 0 IBT (NODE) = 0 IRF (NODE) = 0 ISC (NODE) = 0 CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) NTAG(1,1) = 1 NTAG(1,2) = NSEQ JMP0(1) = NODE NODL(1) = NODE LIMB = 1 ICDW = 0 ICSC = 0 ICRV = 1 INCW = 0 IBTNRV = 0 IPFNRV = 0 IF(NTAMC+1.GT.MXTAMC) GOTO 913 INODTAMC(NTAMC+1) = NODE NTCO(NTAMC+1) = 0 LTAMC = .FALSE. C THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION C -------------------------------------------------------------- 1 DO N=NTAG(LIMB,1),NTAG(LIMB,2) NTAG(LIMB,1) = N+1 DROP(LIMB) = N.EQ.NTAG(LIMB,2) CALL NEMTAB(LUN,NEM(N,LIMB),IDN,TAB,ITAB) NEMS = NEM(N,LIMB) C SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C) C ---------------------------------------------------------- IF(TAB.EQ.'C') THEN READ(NEMS,'(3X,I3)') IYYY IF(ITAB.EQ.1) THEN IF(IYYY.NE.0) THEN IF(ICDW.NE.0) GOTO 907 ICDW = IYYY-128 ELSE ICDW = 0 ENDIF ELSEIF(ITAB.EQ.2) THEN IF(IYYY.NE.0) THEN IF(ICSC.NE.0) GOTO 908 ICSC = IYYY-128 ELSE ICSC = 0 ENDIF ELSEIF(ITAB.EQ.3) THEN IF(IYYY.EQ.0) THEN C Stop applying new reference values to subset nodes. C Instead, revert to the use of standard Table B values. IF(IPFNRV.EQ.0) GOTO 911 DO JJ=IPFNRV,NNRV IENRV(JJ) = NTAB ENDDO IPFNRV = 0 ELSEIF(IYYY.EQ.255) THEN C End the definition of new reference values. IBTNRV = 0 ELSE C Begin the definition of new reference values. IF(IBTNRV.NE.0) GOTO 909 IBTNRV = IYYY ENDIF ELSEIF(ITAB.EQ.7) THEN IF(IYYY.GT.0) THEN IF(ICDW.NE.0) GOTO 907 IF(ICSC.NE.0) GOTO 908 ICDW = ((10*IYYY)+2)/3 ICSC = IYYY ICRV = 10**IYYY ELSE ICSC = 0 ICDW = 0 ICRV = 1 ENDIF ELSEIF(ITAB.EQ.8) THEN INCW = IYYY ELSEIF((ITAB.GE.21).AND.(IOKOPER(NEMS).EQ.1)) THEN C Save the location of this operator within the C jump/link table, for possible later use. IF(.NOT.LTAMC) THEN LTAMC = .TRUE. NTAMC = NTAMC+1 END IF IF(NTCO(NTAMC)+1.GT.MXTCO) GOTO 912 NTCO(NTAMC) = NTCO(NTAMC)+1 CTCO(NTAMC,NTCO(NTAMC)) = NEMS(1:6) INODTCO(NTAMC,NTCO(NTAMC)) = NTAB ENDIF ELSE NODL(LIMB) = NTAB+1 IREP = IRP(N,LIMB) IKNT = KRP(N,LIMB) JUM0 = JMP0(LIMB) CALL TABENT(LUN,NEMS,TAB,ITAB,IREP,IKNT,JUM0) ENDIF IF(TAB.EQ.'D') THEN C Note here how a new tree "LIMB" is created (and is then C immediately recursively resolved) whenever a Table D mnemonic C contains another Table D mnemonic as one of its children. LIMB = LIMB+1 IF(LIMB.GT.MAXLIM) GOTO 901 CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,LIMB),IRP(1,LIMB),KRP(1,LIMB)) NTAG(LIMB,1) = 1 NTAG(LIMB,2) = NSEQ JMP0(LIMB) = NTAB GOTO 1 ELSEIF(DROP(LIMB)) THEN 2 LINK(NODL(LIMB)) = 0 LIMB = LIMB-1 IF(LIMB.EQ.0 ) THEN IF(ICRV.NE.1) GOTO 904 IF(ICDW.NE.0) GOTO 902 IF(ICSC.NE.0) GOTO 903 IF(INCW.NE.0) GOTO 905 IF(IBTNRV.NE.0) GOTO 910 IF(IPFNRV.NE.0) THEN C One or more new reference values were defined for this C subset, but there was no subsequent 2-03-000 operator, C so set all IENRV(*) values for this subset to point to C the last element of the subset within the jump/link table. C Note that, if there had been a subsequent 2-03-000 C operator, then these IENRV(*) values would have already C been properly set above. DO JJ=IPFNRV,NNRV IENRV(JJ) = NTAB ENDDO ENDIF GOTO 100 ENDIF IF(DROP(LIMB)) GOTO 2 LINK(NODL(LIMB)) = NTAB+1 GOTO 1 ELSEIF(TAB.NE.'C') THEN LINK(NODL(LIMB)) = NTAB+1 ENDIF ENDDO GOTO 906 C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '// . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') TAB,NEMO CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '// . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '// . 'LIMIT IS",I4)') NEMO,MAXLIM CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '// . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '// . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '// . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '// . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '// . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '// . 'DEFINED BY TBL A MNEM. ",A)') NEMO CALL BORT(BORT_STR) 907 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' // . 'MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 908 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' // . 'MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 909 WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' // . 'MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 910 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '// . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '// . 'INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 911 WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '// . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '// . 'INPUT MNEMONIC ",A)') NEMO CALL BORT(BORT_STR) 912 CALL BORT('BUFRLIB: TABSUB - MXTCO OVERFLOW') 913 CALL BORT('BUFRLIB: TABSUB - MXTAMC OVERFLOW') END ./trybump.f0000644001370400056700000001121513440555365011634 0ustar jator2emc SUBROUTINE TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: TRYBUMP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CHECKS THE FIRST NODE ASSOCIATED WITH A C CHARACTER STRING (PARSED INTO ARRAYS IN COMMON BLOCK /USRSTR/) IN C ORDER TO DETERMINE IF IT REPRESENTS A DELAYED REPLICATION SEQUENCE. C IF SO, THEN THE DELAYED REPLICATION SEQUENCE IS INITIALIZED AND C EXPANDED (I.E. "BUMPED") TO THE VALUE OF INPUT ARGUMENT I2. C A CALL IS THEN MADE TO SUBROUTINE UFBRW IN ORDER TO WRITE USER DATA C INTO THE NEWLY EXPANDED REPLICATION SEQUENCE. C C TRYBUMP IS USUALLY CALLED FROM UFBINT AFTER UFBINT RECEIVES A C NON-ZERO RETURN CODE FROM UFBRW. THE CAUSE OF A BAD RETURN FROM C UFBRW IS USUALLY A DELAYED REPLICATION SEQUENCE WHICH ISN'T C EXPANDED ENOUGH TO HOLD THE ARRAY OF DATA THE USER IS TRYING TO C WRITE. SO TRYBUMP IS ONE LAST CHANCE TO RESOLVE THAT SITUATION. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2009-03-31 J. WOOLLEN -- ADDED DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL TRYBUMP (LUNIT, LUN, USR, I1, I2, IO, IRET) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C (SEE REMARKS) C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES TO BE C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE C WRITTEN TO DATA SUBSET C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUNIT (SEE REMARKS): C 0 = INPUT FILE (POSSIBLE FUTURE USE) C 1 = OUTPUT FILE C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN CODE FROM CALL TO SUBROUTINE UFBRW C C REMARKS: C ARGUMENT LUNIT IS NOT REFERENCED IN THIS SUBROUTINE. IT WAS C INCLUDED ONLY FOR POTENTIAL FUTURE EXPANSION OF THE SUBROUTINE. C C ARGUMENT IO IS ALWAYS PASSED IN WITH A VALUE OF 1 AT THE PRESENT C TIME. IN THE FUTURE THE SUBROUTINE MAY BE EXPANDED TO ALLOW IT C TO OPERATE ON INPUT FILES. C C THIS ROUTINE CALLS: BORT INVWIN LSTJPB UFBRW C USRTPL C THIS ROUTINE IS CALLED BY: UFBINT UFBOVR C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 USR(I1,I2) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C SEE IF THERE IS A DELAYED REPLICATION GROUP INVOLVED C ---------------------------------------------------- NDRP = LSTJPB(NODS(1),LUN,'DRP') IF(NDRP.LE.0) GOTO 100 C IF SO, CLEAN IT OUT AND BUMP IT TO I2 C ------------------------------------- INVN = INVWIN(NDRP,LUN,1,NVAL(LUN)) VAL(INVN,LUN) = 0 JNVN = INVN+1 DO WHILE(NINT(VAL(JNVN,LUN)).GT.0) JNVN = JNVN+NINT(VAL(JNVN,LUN)) ENDDO DO KNVN=1,NVAL(LUN)-JNVN+1 INV(INVN+KNVN,LUN) = INV(JNVN+KNVN-1,LUN) VAL(INVN+KNVN,LUN) = VAL(JNVN+KNVN-1,LUN) ENDDO NVAL(LUN) = NVAL(LUN)-(JNVN-INVN-1) CALL USRTPL(LUN,INVN,I2) C FINALLY, CALL THE MNEMONIC WRITER C ---------------------------------------- CALL UFBRW(LUN,USR,I1,I2,IO,IRET) C EXIT C ---- 100 RETURN END ./ufbcnt.f0000644001370400056700000000663113440555365011421 0ustar jator2emc SUBROUTINE UFBCNT(LUNIT,KMSG,KSUB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBCNT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RETURNS A COUNT OF THE CURRENT MESSAGE C NUMBER AND SUBSET NUMBER, WHERE THE MESSAGE NUMBER IS RELATIVE TO C ALL MESSAGES IN THE BUFR FILE AND THE SUBSET NUMBER IS RELATIVE TO C ALL SUBSETS IN THE MESSAGE. IF THE MESSAGE/SUBSET ARE BEING READ, C THE MESSAGE COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY C SUBROUTINE READMG (OR EQUIVALENT) IS CALLED AND THE SUBSET COUNT C ADVANCES EACH TIME BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR C EQUIVALENT) IS CALLED FOR A PARTICULAR MESSAGE. IF THE MESSAGE/ C SUBSET ARE BEING WRITTEN, THE MESSAGE COUNT ADVANCES EACH TIME C BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG (OR EQUIVALENT) IS CALLED C AND THE SUBSET COUNT ADVANCES EACH TIME BUFR ARCHIVE LIBRARY C SUBROUTINE WRITSB (OR EQUIVALENT) IS CALLED. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 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 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBCNT (LUNIT, KMSG, KSUB) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C OUTPUT ARGUMENT LIST: C KMSG - INTEGER: POINTER TO MESSAGE COUNT IN BUFR FILE C (INCLUDING MESSAGE CURRENTLY OPEN FOR READING/WRITING) C KSUB - INTEGER: POINTER TO SUBSET COUNT IN BUFR MESSAGE C (INCLUDING SUBSET CURRENTLY OPEN FOR READING/WRITING) C C REMARKS: C IF AN APPLICATION PROGRAM DESIRES TO KNOW THE NUMBER OF SUBSETS IN C A BUFR MESSAGES JUST OPENED, IT MUST USE THE FUNCTION NMSUB RATHER C THAN THIS SUBROUTINE BECAUSE KSUB ONLY INCREMENTS BY ONE FOR EACH C CALL TO READSB (I.E., KSUB = 0 IMMEDIATELY AFTER READMG IS C CALLED). C C THIS ROUTINE CALLS: BORT STATUS C THIS ROUTINE IS CALLED BY: UFBPOS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD INCLUDE 'bufrlib.prm' C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS - RETURN THE MESSAGE AND SUBSET COUNTERS C -------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 KMSG = NMSG(LUN) KSUB = NSUB(LUN) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: STATUS - BUFR FILE IS CLOSED, IT MUST BE '// . 'OPEN FOR EITHER INPUT OR OUTPUT') END ./ufbcpy.f0000644001370400056700000001076513440555365011433 0ustar jator2emc SUBROUTINE UFBCPY(LUBIN,LUBOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBCPY C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE COPIES A COMPLETE SUBSET BUFFER, UNPACKED C INTO INTERNAL MEMORY FROM LOGICAL UNIT LUBIN BY A PREVIOUS CALL C TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB OR READNS, TO C LOGICAL UNIT LUBOT. BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR C OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A C BUFR MESSAGE WITHIN MEMORY FOR LOGICAL UNIT LUBOT. BOTH FILES MUST C HAVE BEEN OPENED TO THE INTERFACE (VIA A CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF) WITH IDENTICAL BUFR TABLES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2009-06-26 J. ATOR -- USE IOK2CPY C 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO REMEMBER WHICH UNIT C IS COPIED TO WHAT SUBSET BUFFER IN ORDER TO C TRANSFER LONG STRINGS VIA UFBCPY AND WRTREE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBCPY (LUBIN, LUBOT) C INPUT ARGUMENT LIST: C LUBIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C REMARKS: C THIS ROUTINE CALLS: BORT IOK2CPY STATUS C THIS ROUTINE IS CALLED BY: COPYSB C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_UFBCPL USE MODA_TABLES INCLUDE 'bufrlib.prm' C---------------------------------------------------------------------- C---------------------------------------------------------------------- C CHECK THE FILE STATUSES AND I-NODE C ---------------------------------- CALL STATUS(LUBIN,LUI,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 CALL STATUS(LUBOT,LUO,IL,IM) IF(IL.EQ.0) GOTO 904 IF(IL.LT.0) GOTO 905 IF(IM.EQ.0) GOTO 906 IF(INODE(LUI).NE.INODE(LUO)) THEN IF( (TAG(INODE(LUI)).NE.TAG(INODE(LUO))) .OR. . (IOK2CPY(LUI,LUO).NE.1) ) GOTO 907 ENDIF C EVERYTHING OKAY COPY USER ARRAY FROM LUI TO LUO C ----------------------------------------------- NVAL(LUO) = NVAL(LUI) DO N=1,NVAL(LUI) INV(N,LUO) = INV(N,LUI) NRFELM(N,LUO) = NRFELM(N,LUI) VAL(N,LUO) = VAL(N,LUI) ENDDO LUNCPY(LUO)=LUBIN C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') 904 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 905 CALL BORT('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 906 CALL BORT('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 907 CALL BORT('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST '// . 'HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') END ./ufbcup.f0000644001370400056700000001031713440555365011420 0ustar jator2emc SUBROUTINE UFBCUP(LUBIN,LUBOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBCUP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE MAKES ONE COPY OF EACH UNIQUE ELEMENT IN AN C INPUT SUBSET BUFFER INTO THE IDENTICAL MNEMONIC SLOT IN THE OUTPUT C SUBSET BUFFER. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBCUP (LUBIN, LUBOT) C INPUT ARGUMENT LIST: C LUBIN - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR INPUT BUFR C FILE C LUBOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR OUTPUT BUFR C FILE C C REMARKS: C THIS ROUTINE CALLS: BORT STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES USE MODA_IVTTMP INCLUDE 'bufrlib.prm' CHARACTER*10 TAGO C---------------------------------------------------------------------- C---------------------------------------------------------------------- C CHECK THE FILE STATUSES AND I-NODE C ---------------------------------- CALL STATUS(LUBIN,LUI,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUI).NE.INV(1,LUI)) GOTO 903 CALL STATUS(LUBOT,LUO,IL,IM) IF(IL.EQ.0) GOTO 904 IF(IL.LT.0) GOTO 905 IF(IM.EQ.0) GOTO 906 C MAKE A LIST OF UNIQUE TAGS IN INPUT BUFFER C ------------------------------------------ NTAG = 0 DO 5 NI=1,NVAL(LUI) NIN = INV(NI,LUI) IF(ITP(NIN).GE.2) THEN DO NV=1,NTAG IF(TTMP(NV).EQ.TAG(NIN)) GOTO 5 ENDDO NTAG = NTAG+1 ITMP(NTAG) = NI TTMP(NTAG) = TAG(NIN) ENDIF 5 ENDDO IF(NTAG.EQ.0) GOTO 907 C GIVEN A LIST MAKE ONE COPY OF COMMON ELEMENTS TO OUTPUT BUFFER C -------------------------------------------------------------- DO 10 NV=1,NTAG NI = ITMP(NV) DO NO=1,NVAL(LUO) TAGO = TAG(INV(NO,LUO)) IF(TTMP(NV).EQ.TAGO) THEN VAL(NO,LUO) = VAL(NI,LUI) GOTO 10 ENDIF ENDDO 10 ENDDO C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') 904 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 905 CALL BORT('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 906 CALL BORT('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 907 CALL BORT('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN '// . 'INPUT SUBSET BUFFER') END ./ufbdmp.f0000644001370400056700000002610413440555365011412 0ustar jator2emc SUBROUTINE UFBDMP(LUNIN,LUPRT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBDMP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT C ABS(LUNIN). ABS(LUNIN) MUST HAVE BEEN OPENED FOR INPUT VIA A C PREVIOUS CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA C SUBSET MUST HAVE BEEN SUBSEQUENTLY READ INTO THE INTERNAL BUFR C ARCHIVE LIBRARY ARRAYS VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C READMG OR READERME, FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE READNS!). FOR A PARTICULAR SUBSET, THE PRINT LISTING C CONTAINS EACH MNEMONIC ACCOMPANIED BY ITS CORRESPONDING DATA VALUE C (INCLUDING THE ACTUAL BITS THAT WERE SET FOR FLAG TABLE VALUES!) C ALONG WITH OTHER POTENTIALLY USEFUL INFORMATION SUCH AS WHICH OTHER C MNEMONIC(S) THAT MNEMONIC WAS A CONSTITUENT OF WITHIN THE OVERALL C DATA SUBSET. HOWEVER, THE LISTING ALSO CONTAINS OTHER MORE ESOTERIC C INFORMATION SUCH AS BUFR STORAGE CHARACTERISTICS AND A COPY OF THE C JUMP/LINK TABLE USED INTERNALLY WITHIN THE BUFR ARCHIVE LIBRARY C SOFTWARE. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE UFDUMP, EXCEPT THAT UFDUMP DOES NOT PRINT POINTERS, C COUNTERS AND THE OTHER MORE ESOTERIC INFORMATION DESCRIBING THE C INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C FOR INFORMATIONAL PURPOSES; TEST FOR A C MISSING VALUE NOW ALLOWS SOME FUZZINESS C ABOUT 10E10 (RATHER THAN TRUE EQUALITY AS C BEFORE) BECAUSE SOME MISSING VALUES (E.G., C CHARACTER STRINGS < 8 CHARACTERS) WERE NOT C GETTING STAMPED OUT AS "MISSING"; ADDED C OPTION TO PRINT VALUES USING FORMAT EDIT C DESCRIPTOR "F15.6" IF LUNIN IS < ZERO, C IF LUNIN IS > ZERO EDIT DESCRIPTOR EXPANDED C FROM "G10.3" TO "G15.6" {REGARDLESS OF C LUNIN, ADDITIONAL VALUES C "IB,IS,IR,ND,JP,LK,JB" NOW PRINTED (THEY C WERE COMMENTED OUT)} C 2004-08-18 J. ATOR -- MODIFIED FUZZINESS TEST;ADDED READLC OPTION; C RESTRUCTURED SOME LOGIC FOR CLARITY C 2006-04-14 D. KEYSER -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET C ACTUAL BITS THAT WERE SET TO GENERATE VALUE C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBDMP (LUNIN, LUPRT) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C - IF LUNIN IS GREATER THAN ZERO, DATA VALUES ARE C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR C "G15.6" (all values are printed since output C format adapts to the magnitude of the data, but C they are not lined up in columns according to C decimal point) C - IF LUNIN IS LESS THAN ZERO, DATA VALUES ARE C PRINTED OUT USING FORMAT DATA EDIT DESCRIPTOR C "F15.6" {values are lined up in columns according C to decimal point, but data of large magnitude, C (i.e., exceeding the format width of 15) get the C overflow ("***************") print} C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT C FILE C 0 = LUPRT is set to 06 (standard output) and C the subroutine will scroll the output, C twenty elements at a time (see REMARKS) C C INPUT FILES: C UNIT 05 - STANDARD INPUT (SEE REMARKS) C C OUTPUT FILES: C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT (SEE REMARKS) C C C REMARKS: C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). C C THIS ROUTINE CALLS: BORT IBFMS ISIZE READLC C RJUST STATUS UPFTBV C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABABD USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*20 LCHR CHARACTER*14 BITS CHARACTER*10 TG,TG_RJ CHARACTER*8 VC CHARACTER*7 FMTF CHARACTER*3 TP CHARACTER*1 TAB,YOU EQUIVALENCE (VL,VC) REAL*8 VL PARAMETER (MXFV=31) INTEGER IFV(MXFV) DATA YOU /'Y'/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(LUPRT.EQ.0) THEN LUOUT = 6 ELSE LUOUT = LUPRT ENDIF C CHECK THE FILE STATUS AND I-NODE C -------------------------------- LUNIT = ABS(LUNIN) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT ABS(LUNIN) C ------------------------------------------------------ DO NV=1,NVAL(LUN) IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN C When LUPRT=0, the output will be scrolled, 20 elements at a time C ---------------------------------------------------------------- PRINT*,'( for MORE, q to QUIT)' READ(5,'(A1)') YOU C If the terminal enters "q" followed by "" after the prompt C "( for MORE, q to QUIT)", scrolling will end and the C subroutine will return to the calling program C ------------------------------------------------------------------- IF(YOU.EQ.'q') THEN PRINT* PRINT*,'==> You have chosen to stop the dumping of this subset' PRINT* GOTO 100 ENDIF ENDIF ND = INV (NV,LUN) VL = VAL (NV,LUN) TG = TAG (ND) TP = TYP (ND) IT = ITP (ND) IB = IBT (ND) IS = ISC (ND) IR = IRF (ND) JP = JUMP(ND) LK = LINK(ND) JB = JMPB(ND) TG_RJ = TG RJ = RJUST(TG_RJ) IF(TP.NE.'CHR') THEN BITS = ' ' IF(IT.EQ.2) THEN CALL NEMTAB(LUN,TG,IDN,TAB,N) IF(TABB(N,LUN)(71:75).EQ.'FLAG') THEN C Print a listing of the bits corresponding to C this value. CALL UPFTBV(LUNIT,TG,VL,MXFV,IFV,NIFV) IF(NIFV.GT.0) THEN BITS(1:1) = '(' IPT = 2 DO II=1,NIFV ISZ = ISIZE(IFV(II)) WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' IF((IPT+ISZ).LE.14) THEN WRITE(BITS(IPT:IPT+ISZ),FMTF) IFV(II), ',' IPT = IPT + ISZ + 1 ELSE BITS(2:13) = 'MANY BITS ON' IPT = 15 ENDIF ENDDO BITS(IPT-1:IPT-1) = ')' ENDIF ENDIF ENDIF IF(IBFMS(VL).NE.0) THEN LCHR = 'MISSING' RJ = RJUST(LCHR) WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB ELSE IF(LUNIT.EQ.LUNIN) THEN WRITE(LUOUT,1) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, . JB ELSE WRITE(LUOUT,10) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK, . JB ENDIF ENDIF ELSE IF(IB.GT.64) THEN CALL READLC(LUNIT,LCHR,TG_RJ) ELSE LCHR = VC ENDIF IF(IBFMS(VL).NE.0) LCHR = 'MISSING' RJ = RJUST(LCHR) WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB ENDIF ENDDO WRITE(LUOUT,3) 1 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5)) 10 FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5)) 2 FORMAT(I5,1X,A3,'-',I1,1X,A10, A20, 15X, 7(1X,I5)) 3 FORMAT(/' >>> END OF SUBSET <<< '/) C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') END ./ufbevn.f0000644001370400056700000002704013440555365011422 0ustar jator2emc SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBEVN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE READNS). OTHER THAN THE ADDITION OF A THIRD C DIMENSION AND THE READ ONLY RESTRICTION, THE CONTEXT AND USAGE OF C UFBEVN IS EXACTLY THE SAME AS FOR BUFR ARCHIVE LIBRARY SUBROUTINES C UFBINT, UFBREP AND UFBSEQ. THIS SUBROUTINE IS DESIGNED TO READ C EVENT INFORMATION FROM "PREPBUFR" TYPE BUFR FILES. PREPBUFR FILES C HAVE THE FOLLOWING BUFR TABLE EVENT STRUCTURE (NOTE SIXTEEN C CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN TO ALLOW THE C TABLE TO FIT IN THIS DOCBLOCK): C C | ADPUPA | HEADR {PLEVL} | C | HEADR | SID XOB YOB DHR ELV TYP T29 TSB ITP SQN | C | PLEVL | CAT | C | PINFO | [PEVN] | C | QINFO | [QEVN] TDO | C | TINFO | [TEVN] TVO | C | ZINFO | [ZEVN] | C | WINFO | [WEVN] | C | PEVN | POB PQM PPC PRC | C | QEVN | QOB QQM QPC QRC | C | TEVN | TOB TQM TPC TRC | C | ZEVN | ZOB ZQM ZPC ZRC | C | WEVN | UOB WQM WPC WRC VOB | C | PBACKG | POE PFC | C | QBACKG | QOE QFC | C | TBACKG | TOE TFC | C | ZBACKG | ZOE ZFC | C | WBACKG | WOE UFC VFC | C | PPOSTP | PAN | C | QPOSTP | QAN | C | TPOSTP | TAN | C | ZPOSTP | ZAN | C | WPOSTP | UAN VAN | C C NOTE THAT THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES "[xxxx]" C ARE NESTED INSIDE ONE-BIT DELAYED REPLICATED SEQUENCES "". C THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBIN3 DOES NOT WORK C PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS ONLY ON THE C EVENT STRUCTURE FOUND IN "PREPFITS" TYPE BUFR FILES (SEE UFBIN3 FOR C MORE DETAILS). IN TURN, UFBEVN DOES NOT WORK PROPERLY ON THE EVENT C STRUCTURE FOUND IN PREPFITS FILES (ALWAYS USE UFBIN3 IN THIS CASE). C ONE OTHER DIFFERENCE BETWEEN UFBEVN AND UFBIN3 IS THAT UFBEVN C STORES THE MAXIMUM NUMBER OF EVENTS FOUND FOR ALL DATA VALUES C SPECIFIED AMONGST ALL LEVELS RETURNED INTERNALLY IN COMMON BLOCK C /UFBN3C/. UFBIN3 RETURNS THIS VALUE AS AN ADDITIONAL OUTPUT C ARGUMENT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; IMPROVED MACHINE C PORTABILITY 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. WOOLLEN -- SAVES THE MAXIMUM NUMBER OF EVENTS FOUND C FOR ALL DATA VALUES SPECIFIED AMONGST ALL C LEVELS RETURNED AS VARIABLE MAXEVN IN NEW C COMMON BLOCK /UFBN3C/ C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); ADDED CALL TO BORT C IF BUFR FILE IS OPEN FOR OUTPUT; UNIFIED/ C PORTABLE FOR WRF; ADDED DOCUMENTATION C (INCLUDING HISTORY); OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY OR UNUSUAL THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBEVN (LUNIT, USR, I1, I2, I3, IRET, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM C VALUE IS 255) C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED C TO TABLE B, THESE RETURN THE FOLLOWING C INFORMATION IN CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM C DATA SUBSET (MUST BE NO LARGER THAN I2) C C REMARKS: C APPLICATION PROGRAMS READING PREPFITS FILES SHOULD NOT CALL THIS C ROUTINE. C C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN C NVNWIN NXTWIN STATUS STRING C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /UFBN3C/ MAXEVN COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 ERRSTR DIMENSION INVN(255) REAL*8 USR(I1,I2,I3) C---------------------------------------------------------------------- C---------------------------------------------------------------------- MAXEVN = 0 IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I3.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF C PARSE OR RECALL THE INPUT STRING C -------------------------------- CALL STRING(STR,LUN,I1,0) C INITIALIZE USR ARRAY C -------------------- DO K=1,I3 DO J=1,I2 DO I=1,I1 USR(I,J,K) = BMISS ENDDO ENDDO ENDDO C LOOP OVER COND WINDOWS C ---------------------- INC1 = 1 INC2 = 1 1 CALL CONWIN(LUN,INC1,INC2) IF(NNOD.EQ.0) THEN IRET = I2 GOTO 100 ELSEIF(INC1.EQ.0) THEN GOTO 100 ELSE DO I=1,NNOD IF(NODS(I).GT.0) THEN INS2 = INC1 CALL GETWIN(NODS(I),LUN,INS1,INS2) IF(INS1.EQ.0) GOTO 100 GOTO 2 ENDIF ENDDO INS1 = INC1 INS2 = INC2 ENDIF C READ PUSH DOWN STACK DATA INTO 3D ARRAYS C ---------------------------------------- 2 IRET = IRET+1 IF(IRET.LE.I2) THEN DO I=1,NNOD IF(NODS(I).GT.0) THEN NNVN = NVNWIN(NODS(I),LUN,INS1,INS2,INVN,I3) MAXEVN = MAX(NNVN,MAXEVN) DO N=1,NNVN USR(I,IRET,N) = VAL(INVN(N),LUN) ENDDO ENDIF ENDDO ENDIF C DECIDE WHAT TO DO NEXT C ---------------------- CALL NXTWIN(LUN,INS1,INS2) IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 IF(NCON.GT.0) GOTO 1 IF(IRET.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') END ./ufbget.f0000644001370400056700000001421713440555365011413 0ustar jator2emc SUBROUTINE UFBGET(LUNIT,TAB,I1,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBGET C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE VALUES FOR ONE- C DIMENSIONAL DESCRIPTORS IN THE INPUT STRING WITHOUT ADVANCING THE C SUBSET POINTER. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; IMPROVED MACHINE C PORTABILITY C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBGET (LUNIT, TAB, I1, IRET, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C I1 - INTEGER: LENGTH OF TAB C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH THE WORDS C IN THE ARRAY TAB C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED C TO TABLE B, THESE RETURN THE FOLLOWING C INFORMATION IN CORRESPONDING TAB LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C TAB - REAL*8: (I1) STARTING ADDRESS OF DATA VALUES READ FROM C DATA SUBSET C IRET - INTEGER: RETURN CODE: C 0 = normal return C -1 = there are no more subsets in the BUFR C message C C REMARKS: C THIS ROUTINE CALLS: BORT INVWIN STATUS STRING C UPBB UPC UPS USRTPL C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_USRBIT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) CHARACTER*(*) STR CHARACTER*8 CVAL EQUIVALENCE (CVAL,RVAL) REAL*8 RVAL,TAB(I1),UPS C----------------------------------------------------------------------- MPS(NODE) = 2**(IBT(NODE))-1 C----------------------------------------------------------------------- IRET = 0 DO I=1,I1 TAB(I) = BMISS ENDDO C MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT C ------------------------------------------ CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- IF(NSUB(LUN).EQ.MSUB(LUN)) THEN IRET = -1 GOTO 100 ENDIF C PARSE THE STRING C ---------------- CALL STRING(STR,LUN,I1,0) C EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE C --------------------------------------------------------- N = 1 NBIT(N) = 0 MBIT(N) = MBYT(LUN)*8 + 16 CALL USRTPL(LUN,N,N) 10 DO N=N+1,NVAL(LUN) NODE = INV(N,LUN) NBIT(N) = IBT(NODE) MBIT(N) = MBIT(N-1)+NBIT(N-1) IF(NODE.EQ.NODS(NNOD)) THEN NVAL(LUN) = N GOTO 20 ELSEIF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT(N),MBIT(N),MBAY(1,LUN)) CALL USRTPL(LUN,N,IVAL) GOTO 10 ENDIF ENDDO 20 CONTINUE C UNPACK ONLY THE NODES FOUND IN THE STRING C ----------------------------------------- DO I=1,NNOD NODE = NODS(I) INVN = INVWIN(NODE,LUN,1,NVAL(LUN)) IF(INVN.GT.0) THEN CALL UPBB(IVAL,NBIT(INVN),MBIT(INVN),MBAY(1,LUN)) IF(ITP(NODE).EQ.1) THEN TAB(I) = IVAL ELSEIF(ITP(NODE).EQ.2) THEN IF(IVAL.LT.MPS(NODE)) TAB(I) = UPS(IVAL,NODE) ELSEIF(ITP(NODE).EQ.3) THEN CVAL = ' ' KBIT = MBIT(INVN) CALL UPC(CVAL,NBIT(INVN)/8,MBAY(1,LUN),KBIT,.TRUE.) TAB(I) = RVAL ENDIF ELSE TAB(I) = BMISS ENDIF ENDDO C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') END ./ufbin3.f0000644001370400056700000002402313440555365011321 0ustar jator2emc SUBROUTINE UFBIN3(LUNIT,USR,I1,I2,I3,IRET,JRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBIN3 C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT C BUFR DATA SUBSET WITHIN INTERNAL ARRAYS. THE DATA VALUES C CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION C SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE. THE INNER C SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER C SEQUENCE WITH DATA "EVENTS". THE BUFR FILE IN LOGICAL UNIT LUNIT C MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF. IN ADDITION, THE DATA SUBSET MUST HAVE C SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY C ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR C READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY C SUBROUTINE READNS). THIS SUBROUTINE IS DESIGNED TO READ EVENT C INFORMATION FROM "PREPFITS" TYPE BUFR FILES (BUT NOT FROM C "PREPBUFR" TYPE FILES!!). PREPFITS FILES HAVE THE FOLLOWING BUFR C TABLE EVENT STRUCTURE (NOTE SIXTEEN CHARACTERS HAVE BEEN REMOVED C FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): C C | ADPUPA | HEADR {PLEVL} | C | HEADR | SID XOB YOB DHR ELV TYP T29 ITP | C | PLEVL | CAT PRC PQM QQM TQM ZQM WQM CDTP_QM [OBLVL] | C | OBLVL | SRC FHR | C | OBLVL | | C | PEVN | POB PMO | C | QEVN | QOB | C | TEVN | TOB | C | ZEVN | ZOB | C | WEVN | UOB VOB | C | CEVN | CAPE CINH LI | C | CTPEVN | CDTP GCDTT TOCC | C C NOTE THAT THE ONE-BIT DELAYED REPLICATED SEQUENCES "" ARE C NESTED INSIDE THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES C "[yyyy]". THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBEVN C DOES NOT WORK PROPERLY ON THIS TYPE OF EVENT STRUCTURE. IT WORKS C ONLY ON THE EVENT STRUCTURE FOUND IN "PREPBUFR" TYPE BUFR FILES C (SEE UFBEVN FOR MORE DETAILS). IN TURN, UFBIN3 DOES NOT WORK C PROPERLY ON THE EVENT STRUCTURE FOUND IN PREPBUFR FILES (ALWAYS USE C UFBEVN IN THIS CASE). ONE OTHER DIFFERENCE BETWEEN UFBIN3 AND C UFBEVN IS THAT UFBIN3 RETURNS THE MAXIMUM NUMBER OF EVENTS FOUND C FOR ALL DATA VALUES SPECIFIED AS AN OUTPUT ARGUMENT (JRET). UFBEVN C DOES NOT DO THIS, BUT RATHER IT STORES THIS VALUE INTERNALLY IN C COMMON BLOCK /UFBN3C/. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION C VERSION) C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY OR UNUSUAL THINGS HAPPEN C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBIN3 (LUNIT, USR, I1, I2, I3, IRET, JRET, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C I3 - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM C VALUE IS 255) C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED C TO TABLE B, THESE RETURN THE FOLLOWING C INFORMATION IN CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM C DATA SUBSET (MUST BE NO LARGER THAN I2) C JRET - INTEGER: MAXIMUM NUMBER OF "EVENTS" FOUND FOR ALL DATA C VALUES SPECIFIED AMONGST ALL LEVELS READ FROM DATA C SUBSET (MUST BE NO LARGER THAN I3) C C REMARKS: C IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY THE VERIFICATION C APPLICATION PROGRAM "GRIDTOBS", WHERE IT WAS PREVIOUSLY C AN IN-LINE SUBROUTINE. IN GENERAL, UFBIN3 DOES NOT C WORK PROPERLY IN OTHER APPLICATION PROGRAMS (I.E, THOSE C THAT ARE READING PREPBUFR FILES) AT THIS TIME. ALWAYS C USE UFBEVN INSTEAD!! C C THIS ROUTINE CALLS: BORT CONWIN ERRWRT GETWIN C NEVN NXTWIN STATUS STRING C THIS ROUTINE IS CALLED BY: None C SHOULD NOT BE CALLED BY ANY APPLICATION C PROGRAMS EXCEPT GRIDTOBS!! C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 ERRSTR REAL*8 USR(I1,I2,I3) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 JRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // . '8th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // . '8th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I3.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' // . '8th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF C PARSE OR RECALL THE INPUT STRING C -------------------------------- CALL STRING(STR,LUN,I1,0) C INITIALIZE USR ARRAY C -------------------- DO K=1,I3 DO J=1,I2 DO I=1,I1 USR(I,J,K) = BMISS ENDDO ENDDO ENDDO C LOOP OVER COND WINDOWS C ---------------------- INC1 = 1 INC2 = 1 1 CALL CONWIN(LUN,INC1,INC2) IF(NNOD.EQ.0) THEN IRET = I2 GOTO 100 ELSEIF(INC1.EQ.0) THEN GOTO 100 ELSE DO I=1,NNOD IF(NODS(I).GT.0) THEN INS2 = INC1 CALL GETWIN(NODS(I),LUN,INS1,INS2) IF(INS1.EQ.0) GOTO 100 GOTO 2 ENDIF ENDDO INS1 = INC1 INS2 = INC2 ENDIF C READ PUSH DOWN STACK DATA INTO 3D ARRAYS C ---------------------------------------- 2 IRET = IRET+1 IF(IRET.LE.I2) THEN DO I=1,NNOD NNVN = NEVN(NODS(I),LUN,INS1,INS2,I1,I2,I3,USR(I,IRET,1)) JRET = MAX(JRET,NNVN) ENDDO ENDIF C DECIDE WHAT TO DO NEXT C ---------------------- CALL NXTWIN(LUN,INS1,INS2) IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 IF(NCON.GT.0) GOTO 1 IF(IRET.EQ.0 .OR. JRET.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; ' // . '8th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') END ./ufbint.f0000644001370400056700000004626313440555365011434 0ustar jator2emc SUBROUTINE UFBINT(LUNIN,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBINT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF C ABS(LUNIN) (I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION C AT ALL. IF UFBINT IS READING VALUES, THEN EITHER BUFR ARCHIVE C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO C INTERNAL MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE C LIBRARY SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY C CALLED TO OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS C ABS(LUNIN). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-11-25 J. WOOLLEN -- MODIFIED TO ADD A RETURN CODE WHEN C MNEMONICS ARE NOT FOUND WHEN READING C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO C WRITE NON-EXISTING MNEMONICS C 1996-12-17 J. WOOLLEN -- MODIFIED TO ALWAYS INITIALIZE "USR" ARRAY C TO MISSING (10E10) WHEN BUFR FILE IS BEING C READ C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT"; IMPROVED MACHINE C PORTABILITY 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM C BORT TO BORT2 IN SOME CASES C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBINT (LUNIN, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS C THAN ZERO, UFBINT TREATS THE BUFR FILE AS THOUGH C IT WERE OPEN FOR INPUT C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND C DIMENSION OF USR C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - IF BUFR FILE OPEN FOR INPUT: THIS CAN ALSO BE A C SINGLE TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- C OR 16-BIT DELAYED REPLICATION (SEE REMARKS 1) C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE C "GENERIC" MNEMONICS NOT RELATED TO TABLE B OR D, C THESE RETURN THE FOLLOWING INFORMATION IN C CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C 1) UFBINT CAN ALSO BE CALLED TO PROVIDE INFORMATION ABOUT A SINGLE C TABLE D (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED C REPLICATION IN A SUBSET WHEN THE BUFR FILE IS OPEN FOR INPUT. C THE MNEMONIC IN STR MUST APPEAR AS IT DOES IN THE BUFR TABLE, C I.E., BRACKETED BY "{" AND "}" OR "[" AND "]" FOR 8-BIT DELAYED C REPLICATION, OR BRACKETED BY "(" AND ")" FOR 16-BIT DELAYED C REPLICATION. {NOTE: THIS WILL NOT WORK FOR SEQUENCES WITH C 1-BIT DELAYED REPLICATION (BRACKETED BY "<" AND ">"), STANDARD C REPLICATION (BRACKETED BY "'s), OR NO REPLICATION (NO C BRACKETING SYMBOLS).} C C FOR EXAMPLE: C C CALL UFBINT(LUNIN,PLEVL,1, 50,IRET,'{PLEVL}') C C WILL RETURN WITH IRET EQUAL TO THE NUMBER OF OCCURRENCES OF THE C 8-BIT DELAYED REPLICATION SEQUENCE PLEVL IN THE SUBSET AND WITH C (PLEVL(I),I=1,IRET) EQUAL TO THE NUMBER OF REPLICATIONS IN EACH C OCCURRENCE OF PLEVL IN THE SUBSET. IF THERE ARE NO OCCURRENCES C OF PLEVL IN THE SUBSET, IRET IS RETURNED AS ZERO. C C 2) WHEN THE BUFR FILE IS OPEN FOR OUTPUT, UFBINT CAN BE USED TO C PRE-ALLOCATE SPACE FOR SOME OR ALL MNEMONICS WITHIN DELAYED C REPLICATION SEQUENCES. A SUBSEQUENT CALL TO BUFR ARCHIVE C LIBRARY ROUTINE UFBREP OR UFBSEQ THEN ACTUALLY STORES THE C VALUES INTO THE BUFR FILES. HERE ARE TWO EXAMPLES OF THIS: C C EXAMPLE 1) PROBLEM: AN OUTPUT SUBSET "SEQNCE" IS LAID OUT AS C FOLLOWS IN A BUFR TABLE (NOTE 16 CHARACTERS HAVE BEEN C REMOVED FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN C THIS DOCBLOCK): C C | SEQNCE | {PLEVL} | C | PLEVL | WSPD WDIR TSIG PRLC TSIG PRLC TSIG PRLC | C C -- OR -- C C | SEQNCE | {PLEVL} | C | PLEVL | WSPD WDIR "PSEQ"3 | C | PSEQ | TSIG PRLC | C C IN THIS CASE THE APPLICATION PROGRAM MUST STORE VALUES WHICH C HAVE STANDARD REPLICATION NESTED INSIDE OF A DELAYED C REPLICATION SEQUENCE. FOR EXAMPLE, ASSUME 50 LEVELS OF WIND C SPEED, WIND DIRECTION, OBSERVED PRESSURE, FIRST GUESS c PRESSURE AND ANALYZED PRESSURE ARE TO BE WRITTEN TO "SEQNCE". C C THE FOLLOWING LOGIC WOULD ENCODE VALUES PROPERLY: C..................................................................... C .... C REAL*8 DROBS(2,50) C REAL*8 SROBS(2,150) C .... C DO I=1,50 C DROBS(1,I) = Value of wind speed on level "I" C DROBS(2,I) = Value of wind direction on level "I" C SROBS(1,I*3-2) = Value of observed pressure on level "I" C SROBS(2,I*3-2) = 25. ! Value in Code Table 0-08-021 (TSIG) C ! for time sigificance (Nominal C ! reporting time) for observed C ! pressure on level "I" C SROBS(1,I*3-1) = Value of first guess pressure on level "I" C SROBS(2,I*3-1) = 27. ! Value in Code Table 0-08-021 (TSIG) C ! for time sigificance (First guess) C ! for first guess pressure on level "I" C SROBS(1,I*3) = Value of analyzed pressure on level "I" C SROBS(2,I*3) = 16. ! Value in Code Table 0-08-021 (TSIG) C ! for time sigificance (Analysis) for C ! analyzed pressure on level "I" C ENDDO C C ! The call to UFBINT here will not only store the 50 C ! values of WSPD and WDIR into the BUFR subset, it C ! will also allocate the space to store three C ! replications of TSIG and PRLC on each of the 50 C ! delayed-replication "levels" C CALL UFBINT(LUNIN,DROBS,2, 50,IRET,'WSPD WDIR') C C ! The call to UFBREP here will actually store the 150 C ! values of both TSIG and PRLC (three values for each C ! on 50 delayed-replication "levels") C CALL UFBREP(LUNIN,SROBS,2,150,IRET,'TSIG PRLC') C .... C STOP C END C..................................................................... C C A SIMILAR EXAMPLE COULD BE PROVIDED FOR READING VALUES WHICH C HAVE STANDARD REPLICATION NESTED WITHIN DELAYED REPLICATION, C FROM BUFR FILES OPEN FOR INPUT. (NOT SHOWN HERE.) C C C EXAMPLE 2) PROBLEM: AN INPUT SUBSET, "REPT_IN", AND AN OUTPUT C SUBSET "REPT_OUT", ARE LAID OUT AS FOLLOWS IN A BUFR TABLE C (NOTE 16 CHARACTERS HAVE BEEN REMOVED FROM THE LAST COLUMN C TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK): C C | REPT_IN | YEAR MNTH DAYS HOUR MINU {PLEVL} CLAT CLON | C | REPT_OUT | YEAR DOYR HOUR MINU {PLEVL} CLAT CLON | C | PLEVL | PRLC TMBD REHU WDIR WSPD C C IN THIS CASE THE APPLICATION PROGRAM IS READING IN VALUES C FROM A BUFR FILE CONTAINING SUBSET "REPT_IN", CONVERTING C MONTH AND DAY TO DAY OF YEAR, AND THEN WRITING VALUES TO C SUBSET "REPT_OUT" IN ANOTHER BUFR FILE. A CONVENIENT WAY TO C DO THIS IS TO CALL UFBSEQ TO READ IN AND WRITE OUT THE C VALUES, HOWEVER THIS IS COMPLICATED BY THE PRESENCE OF THE C DELAYED-RELICATION SEQUENCE "PLEVL" BECAUSE THE OUTPUT CALL C TO UFBSEQ DOES NOT KNOW A-PRIORI HOW MANY REPLICATIONS ARE C NEEDED TO STORE THE CONTENTS OF "PLEVL" (IT SETS THE NUMBER C TO ZERO BY DEFUALT). A CALL TO UFBINT IS FIRST NEEDED TO C ALLOCATE THE SPACE AND DETERMINE THE NUMBER OF LEVELS NEEDED C TO STORE ALL VALUES IN "PLEVL". C C THE FOLLOWING LOGIC WOULD PEFORM THE READ/WRITE PROPERLY: C..................................................................... C .... C REAL*8 OBSI(2000),OBSO(1999),PLEVL(5,255),REPS_8 C CHARACTER*8 SUBSET C .... C C CALL DATELEN(10) C C ! Open input BUFR file in LUBFI and open output BUFR file in C ! LUBFJ, both use the BUFR table in LINDX C CALL OPENBF(LUBFI,'IN', LINDX) C CALL OPENBF(LUBFJ,'OUT',LINDX) C C ! Read through the BUFR messages in the input file C DO WHILE(IREADMG(LUBFI,SUBSET,IDATE).GE.0) C C ! Open message (for writing) in output file C CALL OPENMB(LUBFJ,'REPT_OUT',IDATE) C C ! Read through the subsets in this input BUFR messages C DO WHILE(IREADSB(LUBFI).EQ.0) C C ! This call to UFBSEQ will read in the entire contents C ! of subset "REPT_IN", storing them into array OBSI C ! (Note: On input, UFBSEQ knows how many replications C of "PLEV" are present) C CALL UFBSEQ(LUBFI,OBSI,2000,1,IRET,'REPT_IN') C C ! This call to UFBINT will return the number of C ! replications ("levels") in "PLEVL" for subset C ! "REPT_IN"" ! {see 1) above in REMARKS} C CALL UFBINT(LUBFI,REPS_8,1,1,IRET,'{PLEVL}') C IREPS = REPS_8 C C IYR = OBSI(1) C IMO = OBSI(2) C IDA = OBSI(3) C CALL xxxx(IYR, IMO, IDA, JDY) ! convert month and day C ! to day of year (JDY) C OBSO(1) = OBSI(1) C OBSO(2) = JDY C DO I = 3,1999 C OBSO(I) = OBSI(1+1) C ENDDO C C PLEVL = GETBMISS() C C ! The call to UFBINT here will allocate the space to C ! later allow UFBSEQ to store IREPS replications of C ! "PLEVL" into the output BUFR subset "REPT_OUT" (note C ! here it is simply storing missing values) C CALL UFBINT(LUBFJ,PLEVL,5,IREPS,IRET, C $ 'PRLC TMBD REHU WDIR WSPD') C C ! The call to UFBSEQ here will write out the entire C ! contents of subset "REPT_OUT", reading them from C ! array OBSO C CALL UFBSEQ(LUBFJ,OBSO,1999,1,IRET,'REPT_OUT') C C ! Write the subset into the output BUFR message C CALL WRITSB(LUBFJ) C ENDDO C C ! All done C C STOP C END C..................................................................... C C C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS C STRING TRYBUMP UFBRW C THIS ROUTINE IS CALLED BY: UFBINX UFBRMS C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR REAL*8 USR(I1,I2) DATA IFIRST1/0/,IFIRST2/0/ SAVE IFIRST1, IFIRST2 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- LUNIT = ABS(LUNIN) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IM.EQ.0) GOTO 901 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 IO = MIN(MAX(0,IL),1) IF(LUNIT.NE.LUNIN) IO = 0 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.EQ.-1) IFIRST1 = 1 IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST1 = 1 ENDIF GOTO 100 ENDIF C PARSE OR RECALL THE INPUT STRING C -------------------------------- CALL STRING(STR,LUN,I1,IO) C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION C -------------------------------------------------- IF(IO.EQ.0) THEN DO J=1,I2 DO I=1,I1 USR(I,J) = BMISS ENDDO ENDDO ENDIF C CALL THE MNEMONIC READER/WRITER C ------------------------------- CALL UFBRW(LUN,USR,I1,I2,IO,IRET) C IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN C --------------------------------------------------------------------- IF(IO.EQ.1 .AND. IRET.NE.I2 .AND. IRET.GE.0) THEN CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) IF(IRET.NE.I2) GOTO 903 ELSEIF(IRET.EQ.-1) THEN IRET = 0 ENDIF IF(IRET.EQ.0) THEN IF(IO.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ELSE IF(IPRT.EQ.-1) IFIRST2 = 1 IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') IF(IPRT.EQ.0) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST2 = 1 ENDIF ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 CALL BORT('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR '// . 'FILE, NONE ARE') 902 CALL BORT('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR '// . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// . 'SUBSET ARRAY') 903 WRITE(BORT_STR1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS'// . ': ",A)') STR WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// . ' - INCOMPLETE WRITE")') IRET,I2 CALL BORT2(BORT_STR1,BORT_STR2) END ./ufbinx.f0000644001370400056700000001402613440555365011430 0ustar jator2emc SUBROUTINE UFBINX(LUNIT,IMSG,ISUB,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBINX C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO C LOGICAL UNIT LUNIT FOR INPUT OPERATIONS (IF IT IS NOT ALREADY C OPENED AS SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST C DATA MESSAGE (IF BUFR FILE ALREADY OPENED), THEN (VIA A CALL TO C BUFR ARCHIVE LIBRARY SUBROUTINE UFBINT) READS SPECIFIED VALUES FROM C INTERNAL SUBSET ARRAYS ASSOCIATED WITH A PARTICULAR SUBSET FROM A C PARTICULAR BUFR MESSAGE IN A MESSAGE BUFFER. THE PARTICULAR SUBSET C AND BUFR MESSAGE ARE BASED BASED ON THE SUBSET NUMBER IN THE C MESSAGE AND THE MESSAGE NUMBER IN THE BUFR FILE. FINALLY, THIS C SUBROUTINE EITHER CLOSES THE BUFR FILE IN LUNIT (IF IS WAS OPENED C HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND POSITION C (IF IT WAS NOT OPENED HERE). SEE UFBINT FOR MORE INFORMATION ON C THE READING OF VALUES OUT OF A BUFR MESSAGE SUBSET. NOTE: THE C MESSAGE NUMBER HERE DOES NOT INCLUDE THE DICTIONARY MESSAGES AT THE C BEGINNING OF THE FILE. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION C VERSION BUT MAY HAVE BEEN IN THE PRODUCTION C VERSION AT ONE TIME AND THEN REMOVED) C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2009-03-23 J. ATOR -- MODIFY LOGIC TO HANDLE BUFR TABLE MESSAGES C ENCOUNTERED ANYWHERE IN THE FILE (AND NOT C JUST AT THE BEGINNING!) C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE C USE 'INX' ARGUMENT TO OPENBF C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBINX (LUNIT, IMSG, ISUB, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER TO READ IN C BUFR FILE C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} C C OUTPUT ARGUMENT LIST: C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ C FROM DATA SUBSET C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM C DATA SUBSET (MUST BE NO LARGER THAN I2) C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT CLOSBF OPENBF READMG C READSB REWNBF STATUS UFBINT C UPB C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF INCLUDE 'bufrlib.prm' CHARACTER*(*) STR CHARACTER*128 BORT_STR CHARACTER*8 SUBSET LOGICAL OPENIT REAL*8 USR(I1,I2) C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) OPENIT = IL.EQ.0 IF(OPENIT) THEN C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN C ---------------------------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) ELSE C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG C --------------------------------------------------------------------- CALL REWNBF(LUNIT,0) ENDIF C SKIP TO MESSAGE # IMSG C ---------------------- C Note that we need to use subroutine READMG to actually read in all C of the messages (including the first (IMSG-1) messages!), just in C case there are any embedded dictionary messages in the file. DO I=1,IMSG CALL READMG(LUNIT,SUBSET,JDATE,JRET) IF(JRET.LT.0) GOTO 901 ENDDO C POSITION AT SUBSET # ISUB C ------------------------- DO I=1,ISUB-1 IF(NSUB(LUN).GT.MSUB(LUN)) GOTO 902 IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 ENDDO CALL READSB(LUNIT,JRET) IF(JRET.NE.0) GOTO 902 CALL UFBINT(LUNIT,USR,I1,I2,IRET,STR) IF(OPENIT) THEN C CLOSE BUFR FILE IF IT WAS OPENED HERE C ------------------------------------- CALL CLOSBF(LUNIT) ELSE C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE C --------------------------------------------------------------------- CALL REWNBF(LUNIT,1) ENDIF C EXITS C ----- RETURN 901 WRITE(BORT_STR,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// . 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO'// . ' UNIT",I4)') IMSG,LUNIT CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// . 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR '// . 'FILE CONNECTED TO UNIT",I4)') ISUB,IMSG,LUNIT CALL BORT(BORT_STR) END ./ufbmem.f0000644001370400056700000002154313440555365011412 0ustar jator2emc SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBMEM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY C MSGS IN MODULE MSGMEM). IF MESSAGES ARE APPENDED TO EXISTING C MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO C STORE ALL MESSAGES INTERNALLY WAS INCREASED C FROM 4 MBYTES TO 8 MBYTES C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C 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 2004-11-15 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE EITHER C TOO MANY MESSAGES READ IN (I.E., .GT. C MAXMSG) OR TOO MANY BYTES READ IN (I.E., C .GT. MAXMEM), BUT RATHER JUST STORE MAXMSG C MESSAGES OR MAXMEM BYTES AND PRINT A C DIAGNOSTIC; PARAMETER MAXMEM (THE MAXIMUM C NUMBER OF BYTES REQUIRED TO STORE ALL C MESSAGES INTERNALLY) WAS INCREASED FROM 16 C MBYTES TO 50 MBYTES C 2005-11-29 J. ATOR -- USE RDMSGW AND NMWRD C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE C (DICTIONARY) MESSAGES C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C CALL STATUS TO GET LUN; REPLACE FORTRAN C REWIND AND BACKSPACE WITH C ROUTINES CEWIND C AND BACKBUFR C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- FIX MISSING DECLARATION OF COMMON /QUIET/ C C USAGE: CALL UFBMEM (LUNIT, INEW, IRET, IUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C INEW - INTEGER: SWITCH: C 0 = initialize internal arrays prior to C transferring messages here C else = append the messages transferred here to C internal memory arrays C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED C IUNIT - INTEGER: RETURN CODE: C 0 = no messages were read from LUNIT, file is C empty C LUNIT = INEW input as 0 C else = FORTRAN logical unit for BUFR file C associated with initial message transferred C to internal memory C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C C REMARKS: C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES C FROM INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT CLOSBF CPDXMM ERRWRT C IDXMSG NMWRD OPENBF RDMSGW C STATUS CEWIND BACKBUFR C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA USE MODA_MSGMEM INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE C ---------------------------------------------------------- CALL OPENBF(LUNIT,'IN',LUNIT) IF(INEW.EQ.0) THEN MSGP(0) = 0 MUNIT = 0 MLAST = 0 NDXTS = 0 LDXTS = 0 NDXM = 0 LDXM = 0 ENDIF NMSG = MSGP(0) IRET = 0 IFLG = 0 ITIM = 0 C Copy any BUFR dictionary table messages from the beginning of C LUNIT into MODULE MSGMEM for possible later use. Note that C such a table (if one exists) is already now in scope due to the C prior call to subroutine OPENBF, which in turn would have C automatically called subroutines READDX, RDBFDX and MAKESTAB C for this table. ITEMP = NDXTS CALL STATUS(LUNIT,LUN,IL,IM) CALL CEWIND(LUN) CALL CPDXMM(LUNIT) C If a table was indeed present at the beginning of the file, C then set the flag to indicate that this table is now in scope. IF ((ITEMP+1).EQ.NDXTS) LDXTS = NDXTS C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS C ------------------------------------------------------------ 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.EQ.-1) GOTO 100 IF(IER.EQ.-2) GOTO 900 IF(IDXMSG(MGWA).EQ.1) THEN C New "embedded" BUFR dictionary table messages have been found in C this file. Copy them into MODULE MSGMEM for later use. CALL BACKBUFR(LUN) !BACKSPACE LUNIT CALL CPDXMM(LUNIT) GOTO 1 ENDIF NMSG = NMSG+1 IF(NMSG .GT.MAXMSG) IFLG = 1 LMEM = NMWRD(MGWA) IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 IF(IFLG.EQ.0) THEN IRET = IRET+1 DO I=1,LMEM MSGS(MLAST+I) = MGWA(I) ENDDO MSGP(0) = NMSG MSGP(NMSG) = MLAST+1 ELSE IF(ITIM.EQ.0) THEN MLAST0 = MLAST ITIM=1 ENDIF ENDIF MLAST = MLAST+LMEM GOTO 1 C EXITS C ----- 100 IF(IFLG.EQ.1) THEN C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW C -------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) . 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF MLAST=MLAST0 ENDIF IF(IFLG.EQ.2) THEN C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW C -------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) . 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEM STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEM STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF MLAST=MLAST0 ENDIF IF(IRET.EQ.0) THEN CALL CLOSBF(LUNIT) ELSE IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) IF(MUNIT.EQ.0) MUNIT = LUNIT ENDIF IUNIT = MUNIT C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE '// . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT CALL BORT(BORT_STR) END ./ufbmex.f0000644001370400056700000001512513440555365011424 0ustar jator2emc SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBMEX C PRGMMR: WOOLLEN ORG: NP20 DATE: 2012-01-26 C C ABSTRACT: THIS SUBROUTINE OPENS A BUFR FILE FOR INPUT, READS EACH C MESSAGE AND TRANSFERS THEM ONE-BY-ONE TO INTERNAL MEMORY (ARRAY C MSGS IN MODULE MSGMEM). IF MESSAGES ARE APPENDED TO EXISTING C MESSAGES IN INTERNAL MEMORY, THE BUFR FILE READ HERE IS C CLOSED PRIOR TO RETURNING TO THE CALLING PROGRAM. AN ARRAY IS C ALSO RETURNED CONTAINING A LIST OF MESSAGE TYPES READ IN. C C THIS IS A VARIATION OF UFBMEM WHICH ENABLES MESSAGE SORTING BEFORE C READING. BECAUSE OF THIS RE-ORDERING, EMBEDDED TABLE MESSAGES ARE C NOT STORED IN MODULE MSGMEM, SINCE THEY ARE NO LONGER RELEVANT C ONCE THE RE-ORDERING (I.E. SORTING) HAS TAKEN PLACE. INSTEAD, A C SEPARATE UNIT NUMBER IS ADDED TO THE INPUT ARGUMENTS TO SPECIFY C WHERE THE NECESSARY BUFR TABLE INFORMATION CAN BE FOUND. C C PROGRAM HISTORY LOG: C 2012-01-26 J. WOOLLEN -- MODIFIED UFBMEM TO READ AND SORT MEMORY C MESSAGES FOR TRANJB INGEST ROUTINES AND C RETURN A LIST OF MESSAGE TYPES READ IN. C ALSO, A SEPARATE INPUT ARGUMENT IS ADDED C TO SPECIFY WHERE TO FIND THE BUFR TABLE, C INSTEAD OF SAVING EMBEDDED DICTIONARY C MESSAGES IN MODULE MSGMEM C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- FIX MISSING DECLARATION OF COMMON /QUIET/ C C USAGE: CALL UFBMEX (LUNIT, LUNDX, INEW, IRET, MESG) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR USER- C SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT C INEW - INTEGER: SWITCH: C 0 = initialize internal arrays prior to C transferring messages here C else = append the messages transferred here to C internal memory arrays C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: NUMBER OF MESSAGES TRANSFERRED C MESG - INTEGER: ARRAY OF MESSAGE TYPES READ INTO MEMORY C C INPUT FILES: C UNIT "LUNIT" - BUFR FILE C UNIT "LUNDX" - BUFR DICTIONARY TABLE IN CHARACTER FORMAT C C REMARKS: C NOTE THAT IREADMM, RDMEMM, READMM, UFBMMS, UFBMNS, UFBRMS, UFBTAB C OR UFBTAM CAN BE CALLED AFTER THIS TO READ SPECIFIC BUFR MESSAGES C FROM INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IUPBS01 C NMWRD OPENBF RDMSGW C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MGWA USE MODA_MSGMEM INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR INTEGER MESG(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE C ---------------------------------------------------------- CALL OPENBF(LUNIT,'IN',LUNDX) IF(INEW.EQ.0) THEN MSGP(0) = 0 MUNIT = 0 MLAST = 0 NDXTS = 0 LDXTS = 0 NDXM = 0 LDXM = 0 ENDIF NMSG = MSGP(0) IRET = 0 IFLG = 0 ITIM = 0 C SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING C ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE. NDXTS = 1 LDXTS = 1 IPMSGS(1) = 1 C TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS C ------------------------------------------------------------ 1 CALL RDMSGW(LUNIT,MGWA,IER) IF(IER.EQ.-1) GOTO 100 IF(IER.EQ.-2) GOTO 900 NMSG = NMSG+1 MESG(NMSG) = IUPBS01(MGWA,'MTYP') IF(NMSG .GT.MAXMSG) IFLG = 1 LMEM = NMWRD(MGWA) IF(LMEM+MLAST.GT.MAXMEM) IFLG = 2 IF(IFLG.EQ.0) THEN IRET = IRET+1 DO I=1,LMEM MSGS(MLAST+I) = MGWA(I) ENDDO MSGP(0) = NMSG MSGP(NMSG) = MLAST+1 ELSE IF(ITIM.EQ.0) THEN MLAST0 = MLAST ITIM=1 ENDIF ENDIF MLAST = MLAST+LMEM GOTO 1 C EXITS C ----- 100 IF(IFLG.EQ.1) THEN C EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW C -------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) . 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF MLAST=MLAST0 ENDIF IF(IFLG.EQ.2) THEN C EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW C -------------------------------------------------- IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A)' ) . 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEX STORED ', MLAST0, ' BYTES OUT OF ', MLAST, '<<<' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBMEX STORED ', MSGP(0), ' MESSAGES OUT OF ', NMSG, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF MLAST=MLAST0 ENDIF IF(IRET.EQ.0) THEN CALL CLOSBF(LUNIT) ELSE IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) IF(MUNIT.EQ.0) MUNIT = LUNIT ENDIF IUNIT = MUNIT C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '// . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT CALL BORT(BORT_STR) END ./ufbmms.f0000644001370400056700000001024213440555365011422 0ustar jator2emc SUBROUTINE UFBMMS(IMSG,ISUB,SUBSET,JDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBMMS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL C SUBSET ARRAYS FROM A PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY C BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE MESSAGE NUMBER IN C INTERNAL MEMORY. THIS SUBROUTINE IS ACTUALLY A COMBINATION OF C BUFR ARCHIVE LIBRARY SUBROUTINES RDMEMM AND RDMEMS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO C STORE ALL MESSAGES INTERNALLY WAS INCREASED C FROM 4 MBYTES TO 8 MBYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBMMS (IMSG, ISUB, SUBSET, JDATE) C INPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE C CONTAINING SUBSET C JDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT RDMEMM RDMEMS STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_MSGMEM INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG C ------------------------------------------- CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) IF(IRET.LT.0) GOTO 900 CALL RDMEMS(ISUB,IRET) IF(IRET.NE.0) GOTO 901 C EXITS C ----- RETURN 900 IF(IMSG.GT.0) THEN WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// . 'MEMORY (",I5,")")') IMSG,MSGP(0) ELSE WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE '// . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') ENDIF CALL BORT(BORT_STR) 901 CALL STATUS(MUNIT,LUN,IL,IM) WRITE(BORT_STR,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ '// . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// . 'REG. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG CALL BORT(BORT_STR) END ./ufbmns.f0000644001370400056700000001001613440555365011422 0ustar jator2emc SUBROUTINE UFBMNS(IREP,SUBSET,IDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBMNS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS A PARTICULAR SUBSET INTO INTERNAL C SUBSET ARRAYS FROM A COLLECTION OF BUFR MESSAGES IN INTERNAL MEMORY C BASED ON THE SUBSET NUMBER RELATIVE TO THE TOTAL NUMBER OF SUBSETS C IN THE COLLECTION. THE SUBROUTINE DOES NOT RETURN ANY INFORMATION C ABOUT WHICH MESSAGE NUMBER CONTAINED THE DESIRED SUBSET. IF THE C REQUESTED SUBSET IS LARGER THAN THE TOTAL NUMBER OF SUBSETS IN C MEMORY, THEN AN APPROPRIATE CALL IS MADE TO BUFR ARCHIVE LIBRARY C SUBROUTINE BORT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO C STORE ALL MESSAGES INTERNALLY WAS INCREASED C FROM 4 MBYTES TO 8 MBYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2009-03-23 J. ATOR -- USE IREADMM INSTEAD OF RDMEMM; C SIMPLIFY LOGIC C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBMNS (IREP, SUBSET, IDATE) C INPUT ARGUMENT LIST: C IREP - INTEGER: POINTER TO SUBSET NUMBER TO READ IN C COLLECTION OF MESSAGES C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR BUFR MESSAGE C CONTAINING SUBSET C IDATE - INTEGER: DATE-TIME FROM SECTION 1 OF BUFR MESSAGE C CONTAINING SUBSET, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT IREADMM NMSUB RDMEMS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGMEM INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C----------------------------------------------------------------------- JREP = 0 IMSG = 1 C READ SUBSET #ISUB FROM MEMORY MESSAGE #IMSG C ------------------------------------------- DO WHILE(IREADMM(IMSG,SUBSET,IDATE).EQ.0) IF(JREP+NMSUB(MUNIT).GE.IREP) THEN CALL RDMEMS(IREP-JREP,IRET) GOTO 100 ENDIF JREP = JREP+NMSUB(MUNIT) ENDDO GOTO 900 C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBMNS - REQ. SUBSET NO. TO READ IN '// . '(",I5,") EXCEEDS TOTAL NO. OF SUBSETS IN THE COLLECTION OF '// . 'MEMORY MESSAGES (",I5,")")') IREP,JREP CALL BORT(BORT_STR) END ./ufbovr.f0000644001370400056700000001701313440555365011437 0ustar jator2emc SUBROUTINE UFBOVR(LUNIT,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBOVR C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES OVER SPECIFIED VALUES WHICH EXIST C IN CURRENT INTERNAL BUFR SUBSET ARRAYS IN A FILE OPEN FOR OUTPUT. C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE PART OF A C DELAYED-REPLICATION SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION C AT ALL. EITHER BUFR ARCHIVE LIBRARY SUBROUTINE OPENMG OR OPENMB C MUST HAVE BEEN PREVIOUSLY CALLED TO OPEN AND INITIALIZE A BUFR C MESSAGE WITHIN MEMORY FOR THIS LUNIT. IN ADDITION, BUFR ARCHIVE C LIBRARY SUBROUTINE WRITSB OR INVMRG MUST HAVE BEEN CALLED TO STORE C DATA IN THE INTERNAL OUTPUT SUBSET ARRAYS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM C BORT TO BORT2 IN SOME CASES C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- FIX MISSING DECLARATION OF COMMON /QUIET/ C C USAGE: CALL UFBOVR (LUNIT, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES TO BE C WRITTEN TO DATA SUBSET C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES WRITTEN TO C DATA SUBSET (SHOULD BE SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS C STRING TRYBUMP C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR CHARACTER*(*) STR REAL*8 USR(I1,I2) DATA IFIRST1/0/,IFIRST2/0/ SAVE IFIRST1, IFIRST2 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 C .... DK: Why check, isn't IO always 1 here? IO = MIN(MAX(0,IL),1) IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.EQ.-1) IFIRST1 = 1 IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST1 = 1 ENDIF GOTO 100 ENDIF C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES C ---------------------------------------------------- CALL STRING(STR,LUN,I1,IO) CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 904 IF(IRET.EQ.0) THEN IF(IPRT.EQ.-1) IFIRST2 = 1 IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBOVR - NO SPECIFIED VALUES WRITTEN OUT, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') IF(IPRT.EQ.0) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST2 = 1 ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// . 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') 904 WRITE(BORT_STR1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS'// . ': ",A)') STR WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// . ' - INCOMPLETE WRITE")') IRET,I2 CALL BORT2(BORT_STR1,BORT_STR2) END ./ufbpos.f0000644001370400056700000001204313440555365011430 0ustar jator2emc SUBROUTINE UFBPOS(LUNIT,IREC,ISUB,SUBSET,JDATE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBPOS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1995-11-22 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C LUNIT HAS BEEN OPENED FOR INPUT OPERATIONS. IT POSITIONS THE C MESSAGE POINTER TO A USER-SPECIFIED BUFR MESSAGE NUMBER IN THE FILE C CONNECTED TO LUNIT AND THEN CALLS BUFR ARCHIVE LIBRARY SUBROUTINE C READMG TO READ THIS BUFR MESSAGE INTO A MESSAGE BUFFER (ARRAY MBAY C IN MODULE BITBUF). IT THEN POSITIONS THE SUBSET POINTER TO C A USER-SPECIFIED SUBSET NUMBER WITHIN THE BUFR MESSAGE AND CALLS C BUFR ARCHIVE LIBRARY SUBROUTINE READSB TO READ THIS SUBSET INTO C INTERNAL SUBSET ARRAYS. THE BUFR MESSAGE HERE MAY BE EITHER C COMPRESSED OR UNCOMPRESSED. THE USER-SPECIFIED MESSAGE NUMBER DOES C NOT INCLUDE ANY DICTIONARY MESSAGES THAT MAY BE AT THE TOP OF THE C FILE). C C PROGRAM HISTORY LOG: C 1995-11-22 J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN-LINED IN PROGRAM C NAM_STNMLIST) C 2005-03-04 D. KEYSER -- ADDED TO BUFR ARCHIVE LIBRARY; ADDED C DOCUMENTATION C 2005-11-29 J. ATOR -- USE IUPBS01 AND RDMSGW C 2006-04-14 J. ATOR -- REMOVE UNNECESSARY MOIN INITIALIZATION C 2009-03-23 J. ATOR -- MODIFIED TO HANDLE EMBEDDED BUFR TABLE C (DICTIONARY) MESSAGES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBPOS( LUNIT, IREC, ISUB, SUBSET, JDATE ) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C IREC - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C FILE (DOES NOT INCLUDE ANY DICTIONARY MESSSAGES THAT C MAY BE AT THE TOP OF THE FILE) C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C C OUTPUT ARGUMENT LIST: C SUBSET - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE C BEING READ C JDATE - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR C MESSAGE BEING READ, IN FORMAT OF EITHER YYMMDDHH OR C YYYYMMDDHH, DEPENDING ON DATELEN() VALUE C C REMARKS: C THIS ROUTINE CALLS: BORT CEWIND NMSUB READMG C READSB STATUS UFBCNT UPB C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_BITBUF INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR CHARACTER*8 SUBSET C----------------------------------------------------------------------- C---------------------------------------------------------------------- C MAKE SURE A FILE IS OPEN FOR INPUT C ---------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IREC.LE.0) GOTO 902 IF(ISUB.LE.0) GOTO 903 C SEE WHERE POINTERS ARE CURRENTLY LOCATED C ---------------------------------------- CALL UFBCNT(LUNIT,JREC,JSUB) C REWIND FILE IF REQUESTED POINTERS ARE BEHIND CURRENT POINTERS C ------------------------------------------------------------- IF(IREC.LT.JREC .OR. (IREC.EQ.JREC.AND.ISUB.LT.JSUB)) THEN CALL CEWIND(LUN) NMSG(LUN) = 0 NSUB(LUN) = 0 CALL UFBCNT(LUNIT,JREC,JSUB) ENDIF C READ SUBSET #ISUB FROM MESSAGE #IREC FROM FILE C ---------------------------------------------- DO WHILE (IREC.GT.JREC) CALL READMG(LUNIT,SUBSET,JDATE,IRET) IF(IRET.LT.0) GOTO 904 CALL UFBCNT(LUNIT,JREC,JSUB) ENDDO KSUB = NMSUB(LUNIT) IF(ISUB.GT.KSUB) GOTO 905 DO WHILE (ISUB-1.GT.JSUB) IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 CALL UFBCNT(LUNIT,JREC,JSUB) ENDDO CALL READSB(LUNIT,IRET) IF(IRET.NE.0) GOTO 905 C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST'// . ' BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT'// . ', IT MUST BE OPEN FOR INPUT') 902 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// . 'TO READ IN (",I5,") IS NOT VALID")') IREC CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER '// . 'TO READ IN (",I5,") IS NOT VALID")') ISUB CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// . 'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE '// . 'FILE (",I5,")")') IREC,JREC CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'// . ' IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// . 'REQ. MESSAGE (",I5,")")') ISUB,KSUB,IREC CALL BORT(BORT_STR) END ./ufbqcd.f0000644001370400056700000000723213440555365011402 0ustar jator2emc SUBROUTINE UFBQCD(LUNIT,NEMO,QCD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBQCD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS IN A MNEMONIC KNOWN TO BE IN THE BUFR C TABLE ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT, AND C RETURNS THE DESCRIPTOR ENTRY (Y) ASSOCIATED WITH IT WHEN THE FXY C DESCRIPTOR IS A SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 C (X=63). THIS ROUTINE WILL NOT WORK FOR ANY OTHER TYPE OF C DESCRIPTOR OR ANY OTHER SEQUENCE DESCRIPTOR TABLE D CATEGORY. C LUNIT MUST ALREADY BE OPENED FOR INPUT OR OUTPUT VIA A CALL TO C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM C IS WRITING "EVENTS" TO AN OUTPUT BUFR FILE (USUALLY THE "PREPBUFR" C FILE) USING THE SAME BUFR TABLE SINCE THE DESCRIPTOR ENTRY (Y) HERE C DEFINES THE EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN PASS C THE PROGRAM CODE INTO VARIOUS EVENTS WITHOUT ACTUALLY KNOWING ITS C VALUE AS LONG AS IT KNOWS THE MNEMONIC NAME ASSOCIATED WITH IT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C USAGE: CALL UFBQCD (LUNIT, NEMO, QCD) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) C NEMO - CHARACTER*(*): MNEMONIC C C OUTPUT ARGUMENT LIST: C QCD - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM C CODE) IN BUFR TABLE ASSOCIATED WITH NEMO (Y IN FXY C DESCRIPTOR, WHERE F=3 AND X=63) C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C UFBQCP. C C THIS ROUTINE CALLS: ADN30 BORT NEMTAB STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) NEMO CHARACTER*128 BORT_STR CHARACTER*6 FXY,ADN30 CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) IF(TAB.NE.'D') GOTO 901 FXY = ADN30(IDN,6) IF(FXY(2:3).NE.'63') GOTO 902 READ(FXY(4:6),'(F3.0)',ERR=903) QCD C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT '// . 'DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') NEMO CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// . 'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," -'// . ' CATEGORY MUST BE 63")') NEMO,FXY(2:3) CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: UFBQCD - ERROR READING ENTRY '// . '(PROGRAM CODE) FROM BUFR TBL SEQ. DESCRIPTOR ",A," ASSOC. '// . 'WITH INPUT MNEM. ",A)') FXY,NEMO CALL BORT(BORT_STR) END ./ufbqcp.f0000644001370400056700000000565713440555365011427 0ustar jator2emc SUBROUTINE UFBQCP(LUNIT,QCP,NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBQCP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS IN A FXY DESCRIPTOR ENTRY (Y) FOR A C SEQUENCE DESCRIPTOR (F=3) WITH TABLE D CATEGORY 63 (X=63) WHEN THE C DESCRIPTOR IS KNOWN TO BE IN THE BUFR TABLE IN LOGICAL UNIT LUNIT, C AND RETURNS THE MNEMONIC ASSOCIATED WITH IT. THIS ROUTINE WILL NOT C WORK FOR ANY OTHER TYPE OF DESCRIPTOR OR ANY OTHER SEQUENCE C DESCRIPTOR TABLE D CATEGORY. LUNIT MUST ALREADY BE OPENED FOR C INPUT OR OUTPUT VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE C OPENBF. THIS ROUTINE IS ESPECIALLY USEFUL WHEN THE CALLING PROGRAM C IS READING "EVENTS" FROM AN INPUT BUFR FILE IN LUNIT (USUALLY THE C "PREPBUFR" FILE) SINCE THE DESCRIPTOR ENTRY (Y) HERE DEFINES THE C EVENT PROGRAM CODE. THUS, THE CALLING PROGRAM CAN OBTAIN THE C MNEMONIC NAME ASSOCIATED WITH AN EVENT PROGRAM CODE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C USAGE: CALL UFBQCP (LUNIT, QCP, NEMO) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C (ASSOCIATED BUFR TABLE MAY BE INTERNAL OR EXTERNAL) C QCP - REAL: SEQUENCE DESCRIPTOR ENTRY (I.E., EVENT PROGRAM C CODE) (Y IN FXY DESCRIPTOR) C C OUTPUT ARGUMENT LIST: C NEMO - CHARACTER*(*): MNEMONIC IN BUFR TABLE ASSOCIATED WITH C SEQUENCE DESCRIPTOR FXY WHERE F=3 AND X=63 AND C Y=INT(QCP) C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C UFBQCD. C C THIS ROUTINE CALLS: BORT IFXY NUMTAB STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*(*) NEMO CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IDN = IFXY('363000')+IFIX(QCP) c .... get NEMO from IDN CALL NUMTAB(LUN,IDN,NEMO,TAB,IRET) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') END ./ufbrep.f0000644001370400056700000003020313440555365011413 0ustar jator2emc SUBROUTINE UFBREP(LUNIO,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBREP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO MNEMONICS WHICH ARE EITHER: C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE C OR C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN C OVERALL SUBSET DEFINITION C C THE DIFFERENCE IN THE WAY UFBREP WORKS AS COMPARED TO UFBINT IS IN C THE WAY THE MNEMONIC STRING IS INTERPRETED TO DEFINE WHICH ELEMENTS C ARE PROCESSED AND IN WHAT ORDER. UFBREP INTERPRETS THE FIRST C MNEMONIC IN THE STRING AS A "PIVOT". THIS MEANS THE 2ND DIMENSION C OF THE DATA RETURNED (AS INDICATED BY ARGUMENT I2) IS DEFINED BY C OCCURRENCES OF THE PIVOT ELEMENT FOUND WITHIN THE OVERALL SUBSET C DEFINITION. FOR EXAMPLE, IF THE SUBSET DEFINITION CONTAINS THE C FOLLOWING SEQUENCE OF MNEMONICS: C {..,A,..,B,..,C,..,D,..,A,..,C,..,D,..,B,.. C A,..,B,..,D,..,C,..,A,..,C,..,B,..,D,..}, C THEN READING A SUBSET VIA UFBREP WITH STR = "A B C D" RETURNS THE C FOLLOWING 4X4 MATRIX OF VALUES IN USR, USING A AS THE "PIVOT" C MNEMONIC SINCE IT WAS THE FIRST MNEMONIC IN THE STRING: C ( A1, B1, C1, D1, C A2, B2, C2, D2, C A3, B3, C3, D3, C A4, B4, C4, D4 ) C NOTE THAT, WHEN USING UFBREP, THE ORDER OF THE NON-PIVOT MNEMONICS C BETWEEN EACH PIVOT IS IMMATERIAL, I.E., IN THE ABOVE EXAMPLE, UFBREP C FINDS ALL OF THE OCCURRENCES OF MNEMONICS B, C AND D BETWEEN EACH C PIVOT BECAUSE IT SEARCHES INDEPENDENTLY FOR EACH ONE BETWEEN C SUCCESSIVE PIVOTS. C C IN CONTRAST, NOTE THERE IS ALSO A SEPARATE SUBROUTINE UFBSTP WHICH C IS SIMILAR TO UFBREP, EXCEPT THAT UFBSTP ALWAYS STEPS FORWARD WHEN C SEARCHING FOR EACH SUCCESSIVE NON-PIVOT MNEMONIC, RATHER THAN C SEARCHING INDEPENDENTLY FOR EACH ONE BETWEEN SUCCESSIVE PIVOTS. C SO IN THE ABOVE EXAMPLE WITH STR="A B C D" AND STARTING FROM EACH C SUCCESSIVE PIVOT MNEMONIC A, UFBSTP WOULD SEARCH FORWARD FOR THE C NEXT OCCURRENCE OF MNEMONIC B, THEN IF FOUND SEARCH FORWARD FROM C THERE FOR THE NEXT OCCURRENCE OF C, THEN IF FOUND SEARCH FORWARD C FROM THERE FOR THE NEXT OCCURRENCE OF D, ETC. UP UNTIL REACHING C THE NEXT OCCURRENCE OF THE PIVOT MNEMONIC A (OR THE END OF THE DATA C SUBSET), WITHOUT EVER DOING ANY BACKTRACKING. SO IN THE ABOVE C EXAMPLE UFBSTP WOULD RETURN THE FOLLOWING 4x4 MATRIX OF VALUES IN C ARRAY USR, WHERE XX DENOTES A "MISSING" VALUE: C ( A1, B1, C1, D1, C A2, B2, XX, XX, C A3, B3, C3, XX, C A4, B4, XX, XX ) C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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-05-19 J. WOOLLEN -- DISABLED THE PARSING SWITCH WHICH CONTROLS C CHECKING FOR IN THE SAME REPLICATION GROUP, C UFBREP DOES NOT NEED THIS CHECK, AND IT C INTERFERES WITH WHAT UFBREP CAN DO C OTHERWISE C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C UNUSUAL THINGS HAPPEN; CHANGED CALL FROM C BORT TO BORT2 IN SOME CASES C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBREP (LUNIO, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS C THAN ZERO, UFBREP TREATS THE BUFR FILE AS THOUGH C IT WERE OPEN FOR INPUT C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND C DIMENSION OF USR C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, C THESE RETURN THE FOLLOWING INFORMATION IN C CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS C STRING UFBRP C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /ACMODE/ IAC COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR REAL*8 USR(I1,I2) DATA IFIRST1/0/,IFIRST2/0/ SAVE IFIRST1, IFIRST2 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- LUNIT = ABS(LUNIO) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IM.EQ.0) GOTO 901 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 IO = MIN(MAX(0,IL),1) IF(LUNIO.NE.LUNIT) IO = 0 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.EQ.-1) IFIRST1 = 1 IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST1 = 1 ENDIF GOTO 100 ENDIF C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION C -------------------------------------------------- IF(IO.EQ.0) THEN DO J=1,I2 DO I=1,I1 USR(I,J) = BMISS ENDDO ENDDO ENDIF C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES C ---------------------------------------------------- IA2 = IAC IAC = 1 CALL STRING(STR,LUN,I1,IO) C CALL THE MNEMONIC READER/WRITER C ------------------------------- CALL UFBRP(LUN,USR,I1,I2,IO,IRET) IAC = IA2 IF(IO.EQ.1 .AND. IRET.LT.I2) GOTO 903 IF(IRET.EQ.0) THEN IF(IO.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ELSE IF(IPRT.EQ.-1) IFIRST2 = 1 IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES WRITTEN OUT, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') IF(IPRT.EQ.0) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST2 = 1 ENDIF ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 CALL BORT('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR '// . 'FILE, NONE ARE') 902 CALL BORT('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR '// . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// . 'SUBSET ARRAY') 903 WRITE(BORT_STR1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS'// . ': ",A)') STR WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// . 'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - '// . 'INCOMPLETE WRITE")') IRET,I2 CALL BORT2(BORT_STR1,BORT_STR2) END ./ufbrms.f0000644001370400056700000001411013440555365011425 0ustar jator2emc SUBROUTINE UFBRMS(IMSG,ISUB,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBRMS C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES OUT OF A PARTICULAR C SUBSET WHICH HAS BEEN READ INTO INTERNAL SUBSET ARRAYS FROM A C PARTICULAR BUFR MESSAGE IN INTERNAL MEMORY. THE DATA VALUES C CORRESPOND TO MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. THE SUBSET C READ IN IS BASED ON THE SUBSET NUMBER IN THE MESSAGE AND THE C MESSAGE READ IN IS BASED ON THE MESSAGE NUMBER IN INTERNAL MEMORY. C THIS SUBROUTINE IS ACTUALLY A COMBINATION OF BUFR ARCHIVE LIBRARY C SUBROUTINES RDMEMM, RDMEMS AND UFBINT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- THE MAXIMUM NUMBER OF BYTES REQUIRED TO C STORE ALL MESSAGES INTERNALLY WAS INCREASED C FROM 4 MBYTES TO 8 MBYTES C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBRMS (IMSG, ISUB, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C IMSG - INTEGER: POINTER TO BUFR MESSAGE NUMBER (RECORD) IN C STORAGE C ISUB - INTEGER: POINTER TO SUBSET NUMBER TO READ IN BUFR C MESSAGE C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR {THIS CAN ALSO BE A SINGLE TABLE D C (SEQUENCE) MNEMONIC WITH EITHER 8- OR 16-BIT DELAYED C REPLICATION (SEE REMARKS 1 IN UFBINT DOCBLOCK)} C C OUTPUT ARGUMENT LIST: C USR - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ C FROM DATA SUBSET C IRET - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM C DATA SUBSET (MUST BE NO LARGER THAN I2) C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT ERRWRT RDMEMM RDMEMS C STATUS UFBINT C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_MSGCWD USE MODA_MSGMEM INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 SUBSET REAL*8 USR(I1,I2) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF C UFBINT SUBSET #ISUB FROM MEMORY MESSAGE #IMSG C --------------------------------------------- CALL RDMEMM(IMSG,SUBSET,JDATE,IRET) IF(IRET.LT.0) GOTO 900 CALL RDMEMS(ISUB,IRET) IF(IRET.NE.0) GOTO 901 CALL UFBINT(MUNIT,USR,I1,I2,IRET,STR) C EXITS C ----- 100 RETURN 900 IF(IMSG.GT.0) THEN WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// . 'NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN '// . 'MEMORY (",I5,")")') IMSG,MSGP(0) ELSE WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE '// . 'NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")') ENDIF CALL BORT(BORT_STR) 901 CALL STATUS(MUNIT,LUN,IL,IM) WRITE(BORT_STR,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ '// . 'IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") IN THE '// . 'REQ. MEMORY MESSAGE (",I5,")")') ISUB,MSUB(LUN),IMSG CALL BORT(BORT_STR) END ./ufbrp.f0000644001370400056700000001161213440555365011251 0ustar jator2emc SUBROUTINE UFBRP(LUN,USR,I1,I2,IO,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBRP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED C STRINGS OF MNEMONICS WHICH ARE EITHER: C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE C OR C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN C OVERALL SUBSET DEFINITION C C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE C LIBRARY SUBROUTINE UFBREP. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY 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 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBRP (LUN, USR, I1, I2, IO, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: INVTAG C THIS ROUTINE IS CALLED BY: UFBREP C Normally not called by any application C programs (they should call UFBREP). C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 USR(I1,I2) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 INS1 = 0 INS2 = 0 C FIND FIRST NON-ZERO NODE IN STRING C ---------------------------------- DO NZ=1,NNOD IF(NODS(NZ).GT.0) GOTO 1 ENDDO GOTO 100 C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME C ---------------------------------------------------- 1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 IF(IO.EQ.1 .AND. IRET.EQ.I2) GOTO 100 INS1 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) IF(INS1.EQ.0) GOTO 100 INS2 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN)) IF(INS2.EQ.0) INS2 = NVAL(LUN) IRET = IRET+1 C READ USER VALUES C ---------------- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN DO I=1,NNOD IF(NODS(I).GT.0) THEN INVN = INVTAG(NODS(I),LUN,INS1,INS2) IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) ENDIF ENDDO ENDIF C WRITE USER VALUES C ----------------- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN DO I=1,NNOD IF(NODS(I).GT.0) THEN INVN = INVTAG(NODS(I),LUN,INS1,INS2) IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) ENDIF ENDDO ENDIF C GO FOR NEXT FRAME C ----------------- GOTO 1 C EXIT C ---- 100 RETURN END ./ufbrw.f0000644001370400056700000001662713440555365011273 0ustar jator2emc SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBRW C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED C STRINGS OF MNEMONICS WHICH ARE PART OF A DELAYED-REPLICATION C SEQUENCE, OR FOR WHICH THERE IS NO REPLICATION AT ALL. C C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE C LIBRARY SUBROUTINE UFBINT. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1996-12-11 J. WOOLLEN -- REMOVED A HARD ABORT FOR USERS WHO TRY TO C WRITE NON-EXISTING MNEMONICS C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION C 2009-04-21 J. ATOR -- USE ERRWRT; USE LSTJPB INSTEAD OF LSTRPS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBRW (LUN, USR, I1, I2, IO, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C -1 = NONE OF THE MNEMONICS IN THE STRING PASSED C TO UFBINT WERE FOUND IN THE SUBSET TEMPLATE C C REMARKS: C THIS ROUTINE CALLS: CONWIN DRSTPL ERRWRT GETWIN C IBFMS INVWIN LSTJPB NEWWIN C NXTWIN C THIS ROUTINE IS CALLED BY: TRYBUMP UFBINT C Normally not called by any application C programs (they should call UFBINT). C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /QUIET / IPRT CHARACTER*128 ERRSTR REAL*8 USR(I1,I2) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C LOOP OVER COND WINDOWS C ---------------------- INC1 = 1 INC2 = 1 1 CALL CONWIN(LUN,INC1,INC2) IF(NNOD.EQ.0) THEN IRET = I2 GOTO 100 ELSEIF(INC1.EQ.0) THEN GOTO 100 ELSE DO I=1,NNOD IF(NODS(I).GT.0) THEN INS2 = INC1 CALL GETWIN(NODS(I),LUN,INS1,INS2) IF(INS1.EQ.0) GOTO 100 GOTO 2 ENDIF ENDDO IRET = -1 GOTO 100 ENDIF C LOOP OVER STORE NODES C --------------------- 2 IRET = IRET+1 IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(5(A,I7))' ) . 'BUFRLIB: UFBRW - IRET:INS1:INS2:INC1:INC2 = ', . IRET, ':', INS1, ':', INS2, ':', INC1, ':', INC2 CALL ERRWRT(ERRSTR) KK = INS1 DO WHILE ( ( INS2 - KK ) .GE. 5 ) WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) . (TAG(INV(I,LUN)),I=KK,KK+4) CALL ERRWRT(ERRSTR) KK = KK+5 ENDDO WRITE ( UNIT=ERRSTR, FMT='(5A10)' ) . (TAG(INV(I,LUN)),I=KK,INS2) CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF C WRITE USER VALUES C ----------------- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN DO I=1,NNOD IF(NODS(I).GT.0) THEN IF(IBFMS(USR(I,IRET)).EQ.0) THEN INVN = INVWIN(NODS(I),LUN,INS1,INS2) IF(INVN.EQ.0) THEN CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) IF(INVN.EQ.0) THEN IRET = 0 GOTO 100 ENDIF CALL NEWWIN(LUN,INC1,INC2) VAL(INVN,LUN) = USR(I,IRET) ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN VAL(INVN,LUN) = USR(I,IRET) ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN VAL(INVN,LUN) = USR(I,IRET) ELSE CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) IF(INVN.EQ.0) THEN IRET = 0 GOTO 100 ENDIF CALL NEWWIN(LUN,INC1,INC2) VAL(INVN,LUN) = USR(I,IRET) ENDIF ENDIF ENDIF ENDDO ENDIF C READ USER VALUES C ---------------- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN DO I=1,NNOD USR(I,IRET) = BMISS IF(NODS(I).GT.0) THEN INVN = INVWIN(NODS(I),LUN,INS1,INS2) IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) ENDIF ENDDO ENDIF C DECIDE WHAT TO DO NEXT C ---------------------- IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100 CALL NXTWIN(LUN,INS1,INS2) IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 IF(NCON.GT.0) GOTO 1 C EXIT C ---- 100 RETURN END ./ufbseq.f0000644001370400056700000003546013440555365011427 0ustar jator2emc SUBROUTINE UFBSEQ(LUNIN,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBSEQ C PRGMMR: WOOLLEN ORG: NP20 DATE: 2000-09-19 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF C ABS(LUNIN) {I.E., IF ABS(LUNIN) POINTS TO A BUFR FILE THAT IS OPEN C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET}. C THE DATA VALUES CORRESPOND TO A SEQUENCE OF TABLE B MNEMONICS WHICH C ARE REPRESENTED BY A SINGLE TABLE A OR TABLE D SEQUENCE MNEMONIC. C THIS SEQUENCE MNEMONIC MAY ITSELF CONTAIN ONE OR MORE TABLE D C SEQUENCE MNEMONICS ALONG WITH TABLE B MNEMONICS, THE SEQUENCE C MNEMONICS HERE CAN USE EITHER DELAYED REPLICATION, REGULAR (I.E., C NON-DELAYED) REPLICATION OR THEY CAN HAVE NO REPLICATION AT ALL. C HOWEVER, IN CASES WHERE THIS SUBROUTINE IS WRITING DATA VALUES TO C SEQUENCES USING DELAYED-REPLICATION, THE APPLICATION PROGRAM MUST C FIRST CALL BUFR ARCHIVE LIBRARY ROUTINE DRFINI TO PRE-ALLOCATE THE C SPACE NEEDED TO EXPAND THE DELAYED-REPLICATION SEQUENCE (THE NUMBER C OF REPLICATIONS IN DELAYED-REPLICATION IS SET TO ZERO BY DEFAULT). C (SEE BUFR ARCHIVE LIBRARY DRFINI DOCBLOCK REMARKS FOR MORE C INFORMATION.) IF UFBSEQ IS READING VALUES, THEN EITHER BUFR ARCHIVE C LIBRARY SUBROUTINE READSB OR READNS MUST HAVE BEEN PREVIOUSLY C CALLED TO READ THE SUBSET FROM UNIT ABS(LUNIN) INTO INTERNAL C MEMORY. IF IT IS WRITING VALUES, THEN EITHER BUFR ARCHIVE LIBRARY C SUBROUTINE OPENMG OR OPENMB MUST HAVE BEEN PREVIOUSLY CALLED TO C OPEN AND INITIALIZE A BUFR MESSAGE WITHIN MEMORY FOR THIS C ABS(LUNIN). C C PROGRAM HISTORY LOG: C 2000-09-19 J. WOOLLEN -- ORIGINAL AUTHOR C 2002-05-14 J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY UFBSEQ C WOULD NOT RECOGNIZE COMPRESSED DELAYED C REPLICATION AS A LEGITIMATE DATA STRUCTURE C 2003-05-19 J. WOOLLEN -- CORRECTED THE LOGIC ARRAY OF EXIT C CONDITIONS FOR THE SUBROUTINE, PREVIOUSLY, C IN SOME CASES, PROPER EXITS WERE MISSED, C GENERATING BOGUS ERROR MESSAGES, BECAUSE OF C SEVERAL MISCELLANEOUS BUGS WHICH ARE NOW C REMOVED C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY OR C UNUSUAL THINGS HAPPEN C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-09-10 J. ATOR -- FIX BUG INVOLVING NESTED DELAYED REPLICATION C WHERE FIRST REPLICATION OF OUTER SEQUENCE C DOES NOT CONTAIN A REPLICATION OF THE INNER C SEQUENCE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBSEQ (LUNIN, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT C NUMBER FOR BUFR FILE C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIN IS LESS C THAN ZERO, UFBSEQ TREATS THE BUFR FILE AS THOUGH C IT WERE OPEN FOR INPUT C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF UNIQUE TABLE B C MNEMONICS REPRESENTED BY THE SINGLE TABLE A OR TABLE D C SEQUENCE MNEMONIC IN STR) C I2 - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND C DIMENSION OF USR C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET; THIS C CORRESPONDS TO THE NUMBER OF REPLICATIONS OF THE C MNEMONIC IN STR C STR - CHARACTER*(*): STRING CONTAINING A SINGLE TABLE A OR C TABLE D SEQUENCE MNEMONIC WHOSE SEQUENCE OF TABLE B C MNEMONICS ARE IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE C "GENERIC" MNEMONICS NOT RELATED TO TABLE A OR D, C THESE RETURN THE FOLLOWING INFORMATION IN C CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT INVTAG INVWIN C PARSTR STATUS C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES INCLUDE 'bufrlib.prm' PARAMETER (MTAG=10) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*156 BORT_STR CHARACTER*128 ERRSTR CHARACTER*10 TAGS(MTAG) REAL*8 USR(I1,I2) DATA IFIRST1/0/,IFIRST2/0/ SAVE IFIRST1, IFIRST2 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- LUNIT = ABS(LUNIN) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IM.EQ.0) GOTO 901 IO = MIN(MAX(0,IL),1) IF(LUNIT.NE.LUNIN) IO = 0 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.EQ.-1) IFIRST1 = 1 IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST1 = 1 ENDIF GOTO 100 ENDIF C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS C ------------------------------------------------------ CALL PARSTR(STR,TAGS,MTAG,NTAG,' ',.TRUE.) IF(NTAG.LT.1) GOTO 902 IF(NTAG.GT.1) GOTO 903 IF(I1.LE.0) GOTO 904 IF(I2.LE.0) GOTO 905 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 906 C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION C -------------------------------------------------- IF(IO.EQ.0) THEN DO J=1,I2 DO I=1,I1 USR(I,J) = BMISS ENDDO ENDDO ENDIF C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE C --------------------------------------------- DO NODE=INODE(LUN),ISC(INODE(LUN)) IF(STR.EQ.TAG(NODE)) THEN IF(TYP(NODE).EQ.'SEQ'.OR.TYP(NODE).EQ.'RPC') THEN INS1 = 1 5 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN)) IF(INS1.EQ.0) GOTO 200 IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN INS1 = INS1+1 GOTO 5 ENDIF INS2 = INVTAG(NODE,LUN,INS1+1,NVAL(LUN)) IF(INS2.EQ.0) INS2 = 10E5 NODS = NODE DO WHILE(LINK(NODS).EQ.0.AND.JMPB(NODS).GT.0) NODS = JMPB(NODS) ENDDO IF(LINK(NODS).EQ.0) THEN INSX = NVAL(LUN) ELSEIF(LINK(NODS).GT.0) THEN INSX = INVWIN(LINK(NODS),LUN,INS1+1,NVAL(LUN))-1 ENDIF INS2 = MIN(INS2,INSX) ELSEIF(TYP(NODE).EQ.'SUB') THEN INS1 = 1 INS2 = NVAL(LUN) ELSE GOTO 907 ENDIF NSEQ = 0 DO ISQ=INS1,INS2 ITYP = ITP(INV(ISQ,LUN)) IF(ITYP.GT.1) NSEQ = NSEQ+1 ENDDO IF(NSEQ.GT.I1) GOTO 908 GOTO 1 ENDIF ENDDO GOTO 200 C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME C ---------------------------------------------------- 1 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN)) IF(INS1.GT.NVAL(LUN)) GOTO 200 IF(INS1.GT.0) THEN IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN INS1 = INS1+1 GOTO 1 ELSEIF(IO.EQ.0.AND.IRET+1.GT.I2) THEN GOTO 909 ENDIF ELSEIF(INS1.EQ.0) THEN IF(IO.EQ.1.AND.IRET.LT.I2) GOTO 910 ELSE GOTO 911 ENDIF IF(INS1.EQ. 0) GOTO 200 IF(IRET.EQ.I2) GOTO 200 IRET = IRET+1 INS1 = INS1+1 C READ/WRITE USER VALUES C ---------------------- J = INS1 DO I=1,NSEQ DO WHILE(ITP(INV(J,LUN)).LT.2) J = J+1 ENDDO IF(IO.EQ.0) USR(I,IRET) = VAL(J,LUN ) IF(IO.EQ.1) VAL(J,LUN ) = USR(I,IRET) J = J+1 ENDDO C CHECK FOR NEXT FRAME C -------------------- GOTO 1 200 CONTINUE IF(IRET.EQ.0) THEN IF(IO.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ELSE IF(IPRT.EQ.-1) IFIRST2 = 1 IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') IF(IPRT.EQ.0) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST2 = 1 ENDIF ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 CALL BORT('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '// . 'FILE, NONE ARE') 902 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '// . 'DOES NOT CONTAIN ANY MNEMONICS!!")') STR CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'// . ',")")') STR,NTAG CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THIRD ARGUMENT (INPUT) MUST'// . ' BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') . I1,TAGS(1) CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - FOURTH ARGUMENT (INPUT) '// . 'MUST BE .GT. ZERO (HERE IT IS",I4,") - INPUT MNEMONIC IS ",A)') . I2,TAGS(1) CALL BORT(BORT_STR) 906 CALL BORT('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// . 'SUBSET ARRAY') 907 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') TAGS(1),TYP(NODE) CALL BORT(BORT_STR) 908 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'// . '" CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. SPECIFIED IN'// . ' (INPUT) ARGUMENT 3 (",I3,")")') TAGS(1),NSEQ,I1 CALL BORT(BORT_STR) 909 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' READ > '// . 'LIMIT OF",I5," IN THE 4-TH ARG. (INPUT) - INCOMPLETE READ '// . '(INPUT MNEMONIC IS ",A,")")') I2,TAGS(1) CALL BORT(BORT_STR) 910 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '// . '(",I5,") .LT. NO. REQUESTED (",I5,") - INCOMPLETE WRITE '// . '(INPUT MNEMONIC IS ",A,")")') IRET,I2,TAGS(1) CALL BORT(BORT_STR) 911 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. '// . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') INS1,TAGS(1) CALL BORT(BORT_STR) END ./ufbsp.f0000644001370400056700000001145213440555365011254 0ustar jator2emc SUBROUTINE UFBSP(LUN,USR,I1,I2,IO,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBSP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR C FROM THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF IO C (I.E., IF IO INDICATES LUN POINTS TO A BUFR FILE THAT IS OPEN FOR C INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED C STRINGS OF MNEMONICS WHICH ARE EITHER: C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE C OR C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN C OVERALL SUBSET DEFINITION C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE UFBRP, BUT THERE IS AN IMPORTANT DIFFERENCE (SEE BELOW). C C THIS SUBROUTINE SHOULD NEVER BE CALLED BY ANY APPLICATION PROGRAM; C INSTEAD, APPLICATION PROGRAMS SHOULD ALWAYS CALL BUFR ARCHIVE C LIBRARY SUBROUTINE UFBSTP. C C SEE THE DOCBLOCK FOR BUFR ARCHIVE LIBRARY SUBROUTINE UFBREP FOR AN C EXPLANATION OF HOW UFBSTP DIFFERS FROM UFBREP, AND THEREFORE HOW C UFBSP DIFFERS FROM UFBRP. C C PROGRAM HISTORY LOG: C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBSP (LUN, USR, I1, I2, IO, IRET) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF USR C IO - INTEGER: STATUS INDICATOR FOR BUFR FILE ASSOCIATED C WITH LUN: C 0 = input file C 1 = output file C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: INVTAG C THIS ROUTINE IS CALLED BY: UFBSTP C Normally not called by any application C programs (they should call UFBSTP). C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 USR(I1,I2) C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 INS1 = 0 INS2 = 0 C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME C ---------------------------------------------------- 1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100 INS1 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) IF(INS1.EQ.0) GOTO 100 INS2 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN)) IF(INS2.EQ.0) INS2 = NVAL(LUN) IRET = IRET+1 C READ USER VALUES C ---------------- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN INVM = INS1 DO I=1,NNOD IF(NODS(I).GT.0) THEN INVN = INVTAG(NODS(I),LUN,INVM,INS2) IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) INVM = MAX(INVN,INVM) ENDIF ENDDO ENDIF C WRITE USER VALUES C ----------------- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN INVM = INS1 DO I=1,NNOD IF(NODS(I).GT.0) THEN INVN = INVTAG(NODS(I),LUN,INVM,INS2) IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET) INVM = MAX(INVN,INVM) ENDIF ENDDO ENDIF C GO FOR NEXT FRAME C ----------------- GOTO 1 C EXIT C ---- 100 RETURN END ./ufbstp.f0000644001370400056700000002274213440555365011444 0ustar jator2emc SUBROUTINE UFBSTP(LUNIO,USR,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBSTP C PRGMMR: WOOLLEN ORG: NP20 DATE: 1999-11-18 C C ABSTRACT: THIS SUBROUTINE WRITES OR READS SPECIFIED VALUES TO OR FROM C THE CURRENT BUFR DATA SUBSET WITHIN INTERNAL ARRAYS, WITH THE C DIRECTION OF THE DATA TRANSFER DETERMINED BY THE CONTEXT OF C ABS(LUNIO) (I.E., IF ABS(LUNIO) POINTS TO A BUFR FILE THAT IS OPEN C FOR INPUT, THEN DATA VALUES ARE READ FROM THE INTERNAL DATA SUBSET; C OTHERWISE, DATA VALUES ARE WRITTEN TO THE INTERNAL DATA SUBSET). C THE DATA VALUES CORRESPOND TO INTERNAL ARRAYS REPRESENTING PARSED C STRINGS OF MNEMONICS WHICH ARE EITHER: C 1) PART OF A REGULAR (I.E., NON-DELAYED) REPLICATION SEQUENCE C OR C 2) REPLICATED BY BEING DIRECTLY LISTED MORE THAN ONCE WITHIN AN C OVERALL SUBSET DEFINITION C SO IN THAT RESPECT IT IS VERY SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE UFBREP. HOWEVER, THERE IS AN IMPORTANT DIFFERENCE IN C HOW UFBSTP PROCESSES THE INPUT MNEMONIC STRING STR; FOR MORE DETAILS C SEE THE EXAMPLE IN THE DOCBLOCK FOR SUBROUTINE UFBREP. C C PROGRAM HISTORY LOG: C 1999-11-18 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN; CHANGED CALL FROM BORT TO BORT2 IN C SOME CASES C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST1 AND IFIRST2 FLAGS C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBSTP (LUNIO, USR, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIO - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT C NUMBER FOR BUFR FILE C - IF BUFR FILE OPEN FOR OUTPUT AND LUNIO IS LESS C THAN ZERO, UFBSTP TREATS THE BUFR FILE AS THOUGH C IT WERE OPEN FOR INPUT C USR - ONLY IF BUFR FILE OPEN FOR OUTPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C WRITTEN TO DATA SUBSET C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF USR (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: LENGTH OF SECOND C DIMENSION OF USR C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS C OF DATA VALUES TO BE WRITTEN TO DATA SUBSET C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF USR C - IF BUFR FILE OPEN FOR INPUT: THERE ARE THREE C "GENERIC" MNEMONICS NOT RELATED TO TABLE B, C THESE RETURN THE FOLLOWING INFORMATION IN C CORRESPONDING USR LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET C NUMBER OF THIS SUBSET WITHIN THE BUFR C MESSAGE (RECORD) NUMBER 'IREC' C C OUTPUT ARGUMENT LIST: C USR - ONLY IF BUFR FILE OPEN FOR INPUT: C REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES C READ FROM DATA SUBSET C IRET - INTEGER: C - IF BUFR FILE OPEN FOR INPUT: NUMBER OF "LEVELS" OF C DATA VALUES READ FROM DATA SUBSET (MUST BE NO C LARGER THAN I2) C - IF BUFR FILE OPEN FOR OUTPUT: NUMBER OF "LEVELS" C OF DATA VALUES WRITTEN TO DATA SUBSET (SHOULD BE C SAME AS I2) C C REMARKS: C THIS ROUTINE CALLS: BORT BORT2 ERRWRT STATUS C STRING UFBSP C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR REAL*8 USR(I1,I2) DATA IFIRST1/0/,IFIRST2/0/ SAVE IFIRST1, IFIRST2 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS AND I-NODE C -------------------------------- LUNIT = ABS(LUNIO) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IM.EQ.0) GOTO 901 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 IO = MIN(MAX(0,IL),1) IF(LUNIO.NE.LUNIT) IO = 0 IF(I1.LE.0) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ELSEIF(I2.LE.0) THEN IF(IPRT.EQ.-1) IFIRST1 = 1 IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST1 = 1 ENDIF GOTO 100 ENDIF C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION C -------------------------------------------------- IF(IO.EQ.0) THEN DO J=1,I2 DO I=1,I1 USR(I,J) = BMISS ENDDO ENDDO ENDIF C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES C ---------------------------------------------------- CALL STRING(STR,LUN,I1,IO) C CALL THE MNEMONIC READER/WRITER C ------------------------------- CALL UFBSP(LUN,USR,I1,I2,IO,IRET) IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 903 IF(IRET.EQ.0) THEN IF(IO.EQ.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF ELSE IF(IPRT.EQ.-1) IFIRST2 = 1 IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES WRITTEN OUT, ' // . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)') IF(IPRT.EQ.0) THEN ERRSTR = 'Note: Only the first occurrence of this WARNING ' // . 'message is printed, there may be more. To output all ' // . 'such messages,' CALL ERRWRT(ERRSTR) ERRSTR = 'modify your application program to add ' // . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // . 'to a BUFRLIB routine.' CALL ERRWRT(ERRSTR) ENDIF CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') IFIRST2 = 1 ENDIF ENDIF ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE'// . ' OPEN') 901 CALL BORT('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR '// . 'FILE, NONE ARE') 902 CALL BORT('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR '// . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '// . 'SUBSET ARRAY') 903 WRITE(BORT_STR1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS'// . ': ",A)') STR WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'// . ' - INCOMPLETE WRITE")') IRET,I2 CALL BORT2(BORT_STR1,BORT_STR2) END ./ufbtab.f0000644001370400056700000005061513440555365011404 0ustar jator2emc SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBTAB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO C ABS(LUNIN) FOR INPUT OPERATIONS (IF IT IS NOT ALREADY OPENED AS C SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST DATA C MESSAGE (IF BUFR FILE ALREADY OPENED), THE EXTENT OF ITS PROCESSING C IS DETERMINED BY THE SIGN OF LUNIN. IF LUNIN IS GREATER THAN ZERO, C THIS SUBROUTINE READS SPECIFIED VALUES FROM ALL DATA SUBSETS IN THE C BUFR FILE INTO INTERNAL ARRAYS AND RETURNS THESE VALUES ALONG WITH C A COUNT OF THE SUBSETS. IF LUNIN IS LESS THAN ZERO, THIS C SUBROUTINE RETURNS THE BUFR ARCHIVE LIBRARY'S GLOBAL VALUE FOR C MISSING (REGARDLESS OF THE MNEMONICS SPECIFIED IN STR) C ALONG WITH A COUNT OF THE SUBSETS (SEE REMARKS 2). FINALLY, THIS C SUBROUTINE EITHER CLOSES THE BUFR FILE IN ABS(LUNIN) (IF IT WAS C OPENED HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND C POSITION (IF IT WAS NOT OPENED HERE). WHEN LUNIN IS GREATER THAN C ZERO, THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE C IS NO REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT C THIS SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC C IN EACH SUBSET). UFBTAB PROVIDES A MECHANISM WHEREBY A USER CAN C EITHER DO A QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE C OR MORE MNEMNONICS AMONGST ALL DATA SUBSETS FOR AN ENTIRE BUFR FILE C (WHEN LUNIN IS GREATER THAN ZERO), OR SIMPLY OBTAIN A COUNT OF C SUBSETS IN THE BUFR FILE (WHEN LUNIN IS LESS THAN ZERO); NO OTHER C BUFR ARCHIVE LIBRARY ROUTINES HAVE TO BE CALLED. THIS SUBROUTINE C IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UFBTAM EXCEPT UFBTAM C READS SUBSETS FROM MESSAGES STORED IN INTERNAL MEMORY AND IT HAS NO C OPTION FOR RETURNING ONLY A COUNT OF THE SUBSETS. IN ADDITION, C UFBTAM CURRENTLY CANNOT READ DATA FROM COMPRESSED BUFR MESSAGES. C UFBTAB CAN READ DATA FROM BOTH UNCOMPRESSED AND COMPRESSED BUFR C MESSAGES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- IMPROVED MACHINE PORTABILITY C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MODIFIED TO NOT ABORT WHEN THERE ARE TOO C MANY SUBSETS COMING IN (I.E., .GT. "I2"), C BUT RATHER JUST PROCESS "I2" REPORTS AND C PRINT A DIAGNOSTIC; MAXJL (MAXIMUM NUMBER C OF JUMP/LINK ENTRIES) INCREASED FROM 15000 C TO 16000 (WAS IN VERIFICATION VERSION); C MODIFIED TO CALL ROUTINE REWNBF WHEN THE C BUFR FILE IS ALREADY OPENED, ALLOWS C SPECIFIC SUBSET INFORMATION TO BE READ FROM C A FILE IN THE MIDST OF ITS BEING READ FROM C OR WRITTEN TO), BEFORE OPENBF WAS ALWAYS C CALLED AND THIS WOULD HAVE LED TO AN ABORT C OF THE APPLICATION PROGRAM (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-09-16 J. WOOLLEN -- WORKS FOR COMPRESSED BUFR MESSAGES; ADDED C OPTION TO RETURN ONLY SUBSET COUNT (WHEN C INPUT UNIT NUMBER IS LESS THAN ZERO) C 2006-04-14 J. ATOR -- ADD DECLARATION FOR CREF C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-04-21 J. ATOR -- USE ERRWRT C 2009-12-01 J. ATOR -- FIX BUG FOR COMPRESSED CHARACTER STRINGS C WHICH ARE IDENTICAL ACROSS ALL SUBSETS IN C A SINGLE MESSAGE C 2010-05-07 J. ATOR -- WHEN CALLING IREADMG, TREAT READ ERROR AS C END-OF-FILE CONDITION C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2012-09-15 J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE; C USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE C THE C FILE WITHOUT CLOSING THE FORTRAN FILE C 2014-11-20 J. ATOR -- ENSURE OPENBF HAS BEEN CALLED AT LEAST ONCE C BEFORE CALLING STATUS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2016-12-19 J. WOOLLEN -- FIX BUG TO PREVENT INVENTORY OVERFLOW C C USAGE: CALL UFBTAB (LUNIN, TAB, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C LUNIN - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE C I1 - INTEGER: C - IF LUNIN IS GREATER THAN ZERO: LENGTH OF FIRST C DIMENSION OF TAB (MUST BE AT LEAST AS LARGE AS THE C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR) C - IF LUNIN IS LESS THAN ZERO: LENGTH OF FIRST C DIMENSION OF TAB (RECOMMEND PASSING IN WITH VALUE C OF 1 - SEE REMARKS 2) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB C - IF LUNIN IS GREATER THAN ZERO: MUST BE AT LEAST AS C LARGE AS VALUE RETURNED IN IRET, OTHERWISE ONLY C FIRST I2 SUBSETS ARE RETURNED IN TAB C - IF LUNIN IS LESS THAN ZERO: RECOMMEND PASSING IN C WITH VALUE OF 1 - SEE REMARKS 2 C STR - CHARACTER*(*): C - IF LUNIN IS GREATER THAN ZERO: STRING OF BLANK- C SEPARATED TABLE B MNEMONICS IN ONE-TO-ONE C CORRESPONDENCE WITH FIRST DIMENSION OF TAB, I1 C (THE NUMBER OF MNEMONICS IN THE STRING MUST BE NO C LARGER THAN I1) C - THERE ARE THREE "GENERIC" MNEMONICS NOT C RELATED TO TABLE B, THESE RETURN THE FOLLOWING C INFORMATION IN CORRESPONDING TAB LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR C MESSAGE (RECORD) NUMBER IN WHICH THIS C SUBSET RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE CURRENT C SUBSET NUMBER OF THIS SUBSET WITHIN C THE BUFR MESSAGE (RECORD) NUMBER C 'IREC' C - IF LUNIN IS LESS THAN ZERO: DUMMY {RECOMMEND C PASSING IN STRING AS A 1-CHARACTER BLANK (i.e., C ' ') - SEE REMARKS 2} C C OUTPUT ARGUMENT LIST: C TAB - REAL*8: (I1,I2): C - IF LUNIN IS GREATER THAN ZERO: STARTING ADDRESS OF C DATA VALUES READ FROM BUFR FILE C - IF LUNIN IS LESS THAN ZERO: STARTING ADDRESS OF C ARRAY OF VALUES ALL RETURNED WITH THE BUFRLIB'S C GLOBAL VALUE FOR MISSING (BMISS) C IRET - INTEGER: NUMBER OF DATA SUBSETS IN BUFR FILE C - IF LUNIN IS GREATER THAN ZERO: MUST BE NO LARGER C THAN I2, OTHERWISE ONLY FIRST I2 SUBSETS ARE C RETURNED IN TAB C C REMARKS: C 1) NOTE THAT UFBMEM CAN BE CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C 2) BELOW ARE TWO EXAMPLES WHERE THE USER CALLS UFBTAB WITH LUNIN C LESS THAN ZERO SO AS TO ONLY OBTAIN A COUNT OF SUBSETS IN A C BUFR FILE (ALONG WITH THE BUFRLIB'S GLOBAL VALUE FOR C "MISSING"). C C EXAMPLE 1) I1 AND I2 ARE SET TO 1 SUCH THAT TAB IS A SCALAR AND C STR IS SET TO A 1-CHARACTER BLANK. THESE ARE THE C RECOMMENDED VALUES FOR I1, I2 AND STR SINCE THEY USE THE C LEAST AMOUNT OF MEMORY): C C REAL(8) TAB C .... C .... C CALL UFBTAB(-LUNIN,TAB,1,1,IRET,' ') C .... C .... C C HERE IRET WILL RETURN THE COUNT OF SUBSETS IN THE BUFR FILE C AND TAB WILL RETURN THE BUFRLIB'S GLOBAL VALUE FOR "MISSING" C (BMISS). C C EXAMPLE 2) I1 IS SET TO 4 AND I2 IS SET TO 8 SUCH THAT TAB IS A C 32-WORD ARRAY, AND STR IS SET TO A NONSENSICAL STRING. C THESE VALUES FOR I1, I2 AND STR WASTE MEMORY BUT GIVE THE C SAME ANSWERS FOR TAB AND IRET AS IN EXAMPLE 1 (FOR THE SAME C INPUT BUFR FILE!): C C REAL(8) TAB(4,8) C .... C .... C CALL UFBTAB(-LUNIN,TAB,4,8,IRET,'BUFR IS A WONDERFUL FMT') C .... C .... C C HERE IRET WILL AGAIN RETURN THE COUNT OF SUBSETS IN THE BUFR C FILE AND ALL 32 VALUES OF ARRAY TAB WILL RETURN THE C BUFRLIB'S GLOBAL VALUE FOR "MISSING" (BMISS). C C THE SIXTH ARGUMENT STR IS A DUMMY VALUE AND CAN BE SET TO C ANY CHARACTER STRING (AGAIN, A 1-CHARACTER BLANK ' ' IS C RECOMMENDED). THE THIRD ARGUMENT I1 HAS NO RELATIONSHIP WITH C THE NUMBER OF BLANK-SEPARATED MNEMONICS IN STR AND CAN BE SET C TO ANY INTEGER VALUE (AGAIN, 1 IS RECOMMENDED). THE FOURTH C ARGUMENT I2 HAS NO RELATIONSHIP WITH THE NUMBER OF DATA SUBSETS C IN THE BUFR FILE RETURNED IN IRET (AGAIN, 1 IS RECOMMENDED). C C..................................................................... C C THIS ROUTINE CALLS: BORT CLOSBF ERRWRT IREADMG C IREADSB MESGBC NMSUB OPENBF C PARSTR REWNBF STATUS STRING C UPB UPBB UPC UPS C USRTPL C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /ACMODE/ IAC COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR,ERRSTR CHARACTER*40 CREF CHARACTER*10 TGS(100) CHARACTER*8 SUBSET,CVAL EQUIVALENCE (CVAL,RVAL) LOGICAL OPENIT,JUST_COUNT REAL*8 TAB(I1,I2),RVAL,UPS DATA MAXTG /100/ C----------------------------------------------------------------------- MPS(NODE) = 2**(IBT(NODE))-1 LPS(LBIT) = MAX(2**(LBIT)-1,1) C----------------------------------------------------------------------- C SET COUNTERS TO ZERO C -------------------- IRET = 0 IREC = 0 ISUB = 0 IACC = IAC C CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL C VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT C ------------------------------------------------------------------ LUNIT = ABS(LUNIN) JUST_COUNT = LUNIN.LT.LUNIT C Make sure OPENBF has been called at least once before trying to C call STATUS; otherwise, STATUS might try to access array space C that hasn't yet been dynamically allocated. CALL OPENBF(0,'FIRST',0) CALL STATUS(LUNIT,LUN,IL,IM) OPENIT = IL.EQ.0 IF(OPENIT) THEN C OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN C ---------------------------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) ELSE C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG C --------------------------------------------------------------------- CALL REWNBF(LUNIT,0) ENDIF IAC = 1 C SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR C MISSING (BMISS) C ------------------------------------------------------------- DO J=1,I2 DO I=1,I1 TAB(I,J) = BMISS ENDDO ENDDO IF(JUST_COUNT) THEN C COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING) C -------------------------------------------------------------------- DO WHILE(IREADMG(-LUNIT,SUBSET,IDATE).GE.0) IRET = IRET+NMSUB(LUNIT) ENDDO GOTO 25 ENDIF C OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING C ------------------------------------------- CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) DO I=1,NTG IF(TGS(I).EQ.'IREC') IREC = I IF(TGS(I).EQ.'ISUB') ISUB = I ENDDO C READ A MESSAGE AND PARSE A STRING C --------------------------------- 10 IF(IREADMG(-LUNIT,SUBSET,JDATE).LT.0) GOTO 25 CALL STRING(STR,LUN,I1,0) IF(IREC.GT.0) NODS(IREC) = 0 IF(ISUB.GT.0) NODS(ISUB) = 0 C PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT C -------------------------------------------------------- CALL MESGBC(-LUNIT,MTYP,ICMP) IF(ICMP.EQ.0) THEN GOTO 15 ELSEIF(ICMP.EQ.1) then GOTO 115 ELSE GOTO 900 ENDIF C --------------------------------------------- C THIS BRANCH IS FOR UNCOMPRESSED MESSAGES C --------------------------------------------- C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- 15 IF(NSUB(LUN).EQ.MSUB(LUN)) GOTO 10 IF(IRET+1.GT.I2) GOTO 99 IRET = IRET+1 DO I=1,NNOD NODS(I) = ABS(NODS(I)) ENDDO C PARSE THE STRING NODES FROM A SUBSET C ------------------------------------ MBIT = MBYT(LUN)*8 + 16 NBIT = 0 N = 1 CALL USRTPL(LUN,N,N) 20 IF(N+1.LE.NVAL(LUN)) THEN N = N+1 NODE = INV(N,LUN) MBIT = MBIT+NBIT NBIT = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) CALL USRTPL(LUN,N,IVAL) ENDIF DO I=1,NNOD IF(NODS(I).EQ.NODE) THEN IF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) TAB(I,IRET) = IVAL ELSEIF(ITP(NODE).EQ.2) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) ELSEIF(ITP(NODE).EQ.3) THEN CVAL = ' ' KBIT = MBIT CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT,.TRUE.) TAB(I,IRET) = RVAL ENDIF NODS(I) = -NODS(I) GOTO 20 ENDIF ENDDO DO I=1,NNOD IF(NODS(I).GT.0) GOTO 20 ENDDO ENDIF C UPDATE THE SUBSET POINTERS BEFORE NEXT READ C ------------------------------------------- IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) GOTO 15 C --------------------------------------------- C THIS BRANCH IS FOR COMPRESSED MESSAGES C --------------------------------------------- C STORE ANY MESSAGE AND/OR SUBSET COUNTERS C --------------------------------------------- C CHECK ARRAY BOUNDS C ------------------ 115 IF(IRET+MSUB(LUN).GT.I2) GOTO 99 C STORE MESG/SUBS TOKENS C ---------------------- IF(IREC.GT.0.OR.ISUB.GT.0) THEN DO NSB=1,MSUB(LUN) IF(IREC.GT.0) TAB(IREC,IRET+NSB) = NMSG(LUN) IF(ISUB.GT.0) TAB(ISUB,IRET+NSB) = NSB ENDDO ENDIF C SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF C ------------------------------------------------ CALL USRTPL(LUN,1,1) IBIT = MBYT(LUN) N = 0 C UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY) C ------------------------------------------------------------------ C READ ELEMENTS LOOP C ------------------ 120 DO N=N+1,NVAL(LUN) NODE = INV(N,LUN) NBIT = IBT(NODE) ITYP = ITP(NODE) C FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED C ------------------------------------------------------------------- IF(N.EQ.1) THEN DO I=1,NNOD NODS(I) = ABS(NODS(I)) ENDDO ELSE DO I=1,NNOD IF(NODS(I).GT.0) GOTO 125 ENDDO GOTO 135 ENDIF C FIND THE EXTENT OF THE NEXT SUB-GROUP C ------------------------------------- 125 IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT) CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) NIBIT = IBIT + LINC*MSUB(LUN) ELSEIF(ITYP.EQ.3) THEN CREF=' ' CALL UPC(CREF,NBIT/8,MBAY(1,LUN),IBIT,.TRUE.) CALL UPB(LINC, 6,MBAY(1,LUN),IBIT) NIBIT = IBIT + 8*LINC*MSUB(LUN) ELSE GOTO 120 ENDIF C PROCESS A TYPE1 NODE INTO NVAL C ------------------------------ IF(ITYP.EQ.1) THEN JBIT = IBIT + LINC CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) IVAL = LREF+NINC CALL USRTPL(LUN,N,IVAL) GOTO 120 ENDIF C LOOP OVER STRING NODES C ---------------------- DO I=1,NNOD C CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND C -------------------------------------------------------------- IF(NODE.NE.NODS(I)) GOTO 130 NODS(I) = -NODS(I) LRET = IRET C PROCESS A FOUND NODE INTO TAB C ----------------------------- IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN DO NSB=1,MSUB(LUN) JBIT = IBIT + LINC*(NSB-1) CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT) IVAL = LREF+NINC LRET = LRET+1 IF(NINC.LT.LPS(LINC)) TAB(I,LRET) = UPS(IVAL,NODE) ENDDO ELSEIF(ITYP.EQ.3) THEN DO NSB=1,MSUB(LUN) IF(LINC.EQ.0) THEN CVAL = CREF ELSE JBIT = IBIT + LINC*(NSB-1)*8 CVAL = ' ' CALL UPC(CVAL,LINC,MBAY(1,LUN),JBIT,.TRUE.) ENDIF LRET = LRET+1 TAB(I,LRET) = RVAL ENDDO ELSE CALL BORT('UFBTAB - INVALID ELEMENT TYPE SPECIFIED') ENDIF C END OF LOOPS FOR COMPRESSED MESSAGE PARSING C ------------------------------------------- 130 CONTINUE ENDDO IBIT = NIBIT C END OF READ ELEMENTS LOOP C ------------------------- ENDDO 135 IRET = IRET+MSUB(LUN) C END OF MESSAGE PARSING - GO BACK FOR ANOTHER C -------------------------------------------- GOTO 10 C ------------------------------------------- C ERROR PROCESSING AND EXIT ROUTES BELOW C ------------------------------------------- C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW C ------------------------------------------- 99 NREP = IRET DO WHILE(IREADSB(LUNIT).EQ.0) NREP = NREP+1 ENDDO DO WHILE(IREADMG(-LUNIT,SUBSET,JDATE).GE.0) NREP = NREP+NMSUB(LUNIT) ENDDO IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', . 'IS .GT. LIMIT OF ', I2, ' IN THE 4TH ARG. (INPUT) - ', . 'INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBTAB STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF 25 IF(OPENIT) THEN C CLOSE BUFR FILE IF IT WAS OPENED HERE C ------------------------------------- CALL CLOSBF(LUNIT) ELSE C RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE C --------------------------------------------------------------------- CALL REWNBF(LUNIT,1) ENDIF IAC = IACC C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '// . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '// . 'ROUTINE MESGBC")') ICMP CALL BORT(BORT_STR) END ./ufbtam.f0000644001370400056700000002425313440555365011416 0ustar jator2emc SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFBTAM C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES INTO INTERNAL ARRAYS C FROM ALL DATA SUBSETS IN BUFR MESSAGES STORED IN INTERNAL MEMORY. C THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE IS NO C REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT THIS C SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC IN C EACH SUBSET). UFBTAM PROVIDES A MECHANISM WHEREBY A USER CAN DO A C QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE OR MORE C MNEMNONICS AMONGST ALL DATA SUBSETS FOR A GROUP OF BUFR MESSAGES C STORED IN INTERNAL MEMORY, NO OTHER BUFR ARCHIVE LIBRARY ROUTINES C HAVE TO BE CALLED. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE C LIBRARY SUBROUTINE UFBTAB EXCEPT UFBTAB READS SUBSETS FROM MESSAGES C IN A PHYSICAL BUFR FILE. UFBTAM CURRENTLY CANNOT READ DATA FROM C COMPRESSED BUFR MESSAGES. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES 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 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO C 16 MBYTES; MODIFIED TO NOT ABORT WHEN THERE C ARE TOO MANY SUBSETS COMING IN (I.E., .GT. C I2), BUT RATHER JUST PROCESS I2 REPORTS AND C PRINT A DIAGNOSTIC C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF C BUFR MESSAGES WHICH CAN BE STORED C INTERNALLY) INCREASED FROM 50000 TO 200000; C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF C BYTES REQUIRED TO STORE ALL MESSAGES C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO C 50 MBYTES C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-04-21 J. ATOR -- USE ERRWRT C 2009-10-21 D. KEYSER -- ADDED OPTION TO INPUT NEW MNEMONIC "ITBL" C IN ARGUMENT STR, RETURNS THE BUFR C DICTIONARY TABLE NUMBER ASSOCIATED WITH C EACH SUBSET IN INTERNAL MEMORY C 2012-03-02 J. ATOR -- USE FUNCTION UPS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UFBTAM (TAB, I1, I2, IRET, STR) C INPUT ARGUMENT LIST: C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF TAB (MUST BE AT C LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED C MNEMONICS IN STR) C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST C DIMENSION OF TAB C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED C TO TABLE B, THESE RETURN THE FOLLOWING C INFORMATION IN CORRESPONDING TAB LOCATION: C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING") C 'IREC' WHICH ALWAYS RETURNS THE BUFR MESSAGE C (RECORD) NUMBER IN WHICH EACH SUBSET IN C INTERNAL MEMORY RESIDES C 'ISUB' WHICH ALWAYS RETURNS THE LOCATION WITHIN C MESSAGE "IREC" (I.E., THE SUBSET NUMBER) C FOR EACH SUBSET IN INTERNAL MEMORY C 'ITBL' WHICH ALWAYS RETURNS THE BUFR DICTIONARY C TABLE NUMBER ASSOCIATED WITH EACH SUBSET C IN INTERNAL MEMORY C C OUTPUT ARGUMENT LIST: C TAB - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ C FROM INTERNAL MEMORY C IRET - INTEGER: NUMBER OF DATA SUBSETS IN INTERNAL MEMORY C (MUST BE NO LARGER THAN I2) C C REMARKS: C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR C MESSAGES INTO INTERNAL MEMORY. C C THIS ROUTINE CALLS: BORT ERRWRT NMSUB PARSTR C RDMEMM STATUS STRING UPB C UPBB UPC UPS USRTPL C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_MSGMEM USE MODA_TABLES INCLUDE 'bufrlib.prm' COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),VALS(10),KONS(10) COMMON /QUIET / IPRT CHARACTER*(*) STR CHARACTER*128 BORT_STR,ERRSTR CHARACTER*10 TGS(100) CHARACTER*8 SUBSET,CVAL EQUIVALENCE (CVAL,RVAL) REAL*8 TAB(I1,I2),RVAL,UPS DATA MAXTG /100/ C----------------------------------------------------------------------- MPS(NODE) = 2**(IBT(NODE))-1 C----------------------------------------------------------------------- IRET = 0 IF(MSGP(0).EQ.0) GOTO 100 DO J=1,I2 DO I=1,I1 TAB(I,J) = BMISS ENDDO ENDDO C CHECK FOR SPECIAL TAGS IN STRING C -------------------------------- CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) IREC = 0 ISUB = 0 ITBL = 0 DO I=1,NTG IF(TGS(I).EQ.'IREC') IREC = I IF(TGS(I).EQ.'ISUB') ISUB = I IF(TGS(I).EQ.'ITBL') ITBL = I ENDDO C READ A MESSAGE AND PARSE A STRING C --------------------------------- CALL STATUS(MUNIT,LUN,IL,IM) DO IMSG=1,MSGP(0) CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) IF(MRET.LT.0) GOTO 900 CALL STRING(STR,LUN,I1,0) IF(IREC.GT.0) NODS(IREC) = 0 IF(ISUB.GT.0) NODS(ISUB) = 0 IF(ITBL.GT.0) NODS(ITBL) = 0 C PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE C --------------------------------------------- DO WHILE (NSUB(LUN).LT.MSUB(LUN)) IF(IRET+1.GT.I2) GOTO 99 IRET = IRET+1 DO I=1,NNOD NODS(I) = ABS(NODS(I)) ENDDO CALL USRTPL(LUN,1,1) MBIT = MBYT(LUN)*8+16 NBIT = 0 N = 1 20 IF(N+1.LE.NVAL(LUN)) THEN N = N+1 NODE = INV(N,LUN) MBIT = MBIT+NBIT NBIT = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) CALL USRTPL(LUN,N,IVAL) ENDIF DO I=1,NNOD IF(NODS(I).EQ.NODE) THEN IF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) TAB(I,IRET) = IVAL ELSEIF(ITP(NODE).EQ.2) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE) ELSEIF(ITP(NODE).EQ.3) THEN CVAL = ' ' KBIT = MBIT CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT,.TRUE.) TAB(I,IRET) = RVAL ENDIF NODS(I) = -NODS(I) GOTO 20 ENDIF ENDDO DO I=1,NNOD IF(NODS(I).GT.0) GOTO 20 ENDDO ENDIF C UPDATE THE SUBSET POINTERS BEFORE NEXT READ C ------------------------------------------- IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN) IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN) IF(ITBL.GT.0) TAB(ITBL,IRET) = LDXTS ENDDO ENDDO GOTO 200 C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW C ------------------------------------------- 99 CALL RDMEMM(0,SUBSET,JDATE,MRET) NREP = 0 DO IMSG=1,MSGP(0) CALL RDMEMM(IMSG,SUBSET,JDATE,MRET) IF(MRET.LT.0) GOTO 900 NREP = NREP+NMSUB(MUNIT) ENDDO IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' ) . 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', . 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - ', . 'INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) . '>>>UFBTAM STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C RESET THE MEMORY FILE C --------------------- 200 CALL RDMEMM(0,SUBSET,JDATE,MRET) C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '// . 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') IMSG CALL BORT(BORT_STR) END ./ufdump.f0000644001370400056700000004033413440555365011436 0ustar jator2emc SUBROUTINE UFDUMP(LUNIT,LUPRT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UFDUMP C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE C CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE C INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT. C LUNIT MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR C ARCHIVE LIBRARY SUBROUTINE OPENBF. THE DATA SUBSET MUST HAVE BEEN C SUBSEQUENTLY READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY ARRAYS VIA C A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR READERME, C FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR VIA C A SINGLE CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READNS!). FOR A C PARTICULAR SUBSET, THE PRINT LISTING CONTAINS EACH MNEMONIC C ACCOMPANIED BY ITS CORRESPONDING DATA VALUE (INCLUDING THE ACTUAL C BITS THAT WERE SET FOR FLAG TABLE VALUES!) AS WELL AS OTHER USEFUL C IDENTIFICATION INFORMATION. THIS SUBROUTINE IS SIMILAR TO BUFR C ARCHIVE LIBRARY SUBROUTINE UFBDMP EXCEPT THAT IT DOES NOT PRINT C POINTERS, COUNTERS AND OTHER MORE ESOTERIC INFORMATION DESCRIBING C THE INTERNAL SUBSET STRUCTURES. EACH SUBROUTINE, UFBDMP AND UFDUMP, C IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP C IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 J. WOOLLEN -- MODIFIED TO HANDLE PRINT OF CHARACTER C VALUES GREATER THAN EIGHT BYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC C INFO WHEN ROUTINE TERMINATES ABNORMALLY C 2004-08-18 J. ATOR -- ADDED FUZZINESS TEST AND THRESHOLD FOR C MISSING VALUE; ADDED INTERACTIVE AND C SCROLLING CAPABILITY SIMILAR TO UFBDMP C 2006-04-14 J. ATOR -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET C ACTUAL BITS THAT WERE SET TO GENERATE VALUE C 2007-01-19 J. ATOR -- USE FUNCTION IBFMS C 2009-03-23 J. ATOR -- ADD LEVEL MARKERS TO OUTPUT FOR SEQUENCES C WHERE THE REPLICATION COUNT IS > 1; OUTPUT C ALL OCCURRENCES OF LONG CHARACTER STRINGS C 2012-02-24 J. ATOR -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS C 2012-03-02 J. ATOR -- LABEL REDEFINED REFERENCE VALUES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 J. WOOLLEN -- PRINT LEVEL IDENTIFIERS FOR EVENT STACKS C C USAGE: CALL UFDUMP (LUNIT, LUPRT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LUPRT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT C FILE C 0 = LUPRT is set to 06 C C OUTPUT FILES: C IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT) C IF LUPRT = 0: UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: C THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS C AT A TIME WHEN LUPRT IS INPUT AS "0". IN THIS CASE, THE EXECUTING C SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND C STANDARD OUTPUT. INITIALLY, THE FIRST TWENTY ELEMENTS OF THE C CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL, C FOLLOWED BY THE PROMPT "( for MORE, q to QUIT)". C IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY C "" (e.g., ""), THE NEXT TWENTY ELEMENTS WILL BE C DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT. THIS CONTINUES C UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL C ENTERS "q" FOLLOWED BY "" AFTER THE PROMPT, IN WHICH CASE C THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING C PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE). C C THIS ROUTINE CALLS: BORT FSTAG ICBFMS IBFMS C IREADMT ISIZE NEMTAB NUMTBD C READLC RJUST SRCHTBF STATUS C STRSUC UPFTBV C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABABD USE MODA_TABLES USE MODA_NRV203 INCLUDE 'bufrlib.prm' COMMON /TABLEF/ CDMF CHARACTER*120 CFMEANG CHARACTER*80 FMT CHARACTER*64 DESC CHARACTER*24 UNIT CHARACTER*120 LCHR2 CHARACTER*20 LCHR,PMISS CHARACTER*15 NEMO3 CHARACTER*10 NEMO,NEMO2,TAGRFE CHARACTER*8 NEMOD CHARACTER*6 NUMB CHARACTER*7 FMTF CHARACTER*8 CVAL CHARACTER*3 TYPE CHARACTER*1 CDMF,TAB,YOU EQUIVALENCE (RVAL,CVAL) REAL*8 RVAL LOGICAL TRACK,FOUND,RDRV PARAMETER (MXCFDP=5) INTEGER ICFDP(MXCFDP) PARAMETER (MXFV=31) INTEGER IFV(MXFV) PARAMETER (MXSEQ=10) INTEGER IDXREP(MXSEQ) INTEGER NUMREP(MXSEQ) CHARACTER*10 SEQNAM(MXSEQ) PARAMETER (MXLS=10) CHARACTER*10 LSNEMO(MXLS) INTEGER LSCT(MXLS) DATA PMISS /' MISSING'/ DATA YOU /'Y'/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- NSEQ = 0 NLS = 0 LCFMEANG = LEN(CFMEANG) IF(LUPRT.EQ.0) THEN LUOUT = 6 ELSE LUOUT = LUPRT ENDIF C CHECK THE FILE STATUS AND I-NODE C -------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903 WRITE(LUOUT,*) WRITE(LUOUT,*) 'MESSAGE TYPE ',TAG(INODE(LUN)) WRITE(LUOUT,*) C DUMP THE CONTENTS OF MODULE USRINT FOR UNIT LUNIT C ------------------------------------------------- C If code/flag table details are being printed, and if this is the C first subset of a new message, then make sure the appropriate C master tables have been read in to memory for this message. IF(CDMF.EQ.'Y' .AND. NSUB(LUN).EQ.1) ITMP = IREADMT(LUN) DO NV=1,NVAL(LUN) IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN C When LUPRT=0, the output will be scrolled, 20 elements at a time C ---------------------------------------------------------------- PRINT*,'( for MORE, q to QUIT)' READ(5,'(A1)') YOU C If the terminal enters "q" followed by "" after the prompt C "( for MORE, q to QUIT)", scrolling will end and the C subroutine will return to the calling program C ------------------------------------------------------------------- IF(YOU.EQ.'q') THEN PRINT* PRINT*,'==> You have chosen to stop the dumping of this subset' PRINT* GOTO 100 ENDIF ENDIF NODE = INV (NV,LUN) NEMO = TAG (NODE) ITYP = ITP (NODE) TYPE = TYP (NODE) IF(ITYP.GE.1.AND.ITYP.LE.3) THEN CALL NEMTAB(LUN,NEMO,IDN,TAB,N) NUMB = TABB(N,LUN)(1:6) DESC = TABB(N,LUN)(16:70) UNIT = TABB(N,LUN)(71:94) RVAL = VAL(NV,LUN) ENDIF IF((ITYP.EQ.0).OR.(ITYP.EQ.1)) THEN C Sequence descriptor or delayed descriptor replication factor IF((TYPE.EQ.'REP').OR.(TYPE.EQ.'DRP').OR. . (TYPE.EQ.'DRB').OR.(TYPE.EQ.'DRS')) THEN C Print the number of replications NSEQ = NSEQ+1 IF(NSEQ.GT.MXSEQ) GOTO 904 IF(TYPE.EQ.'REP') THEN NUMREP(NSEQ) = IRF(NODE) ELSE NUMREP(NSEQ) = NINT(RVAL) ENDIF CALL STRSUC(NEMO,NEMO2,LNM2) FMT = '(11X,A,I6,1X,A)' WRITE(LUOUT,FMT) NEMO2(1:LNM2), NUMREP(NSEQ), 'REPLICATIONS' C How many times is this sequence replicated? IF(NUMREP(NSEQ).GT.1) THEN C Track the sequence SEQNAM(NSEQ) = NEMO IDXREP(NSEQ) = 1 ELSE C Don't bother NSEQ = NSEQ-1 ENDIF ELSEIF( ((TYPE.EQ.'SEQ').OR.(TYPE.EQ.'RPC').OR.(TYPE.EQ.'RPS')) . .AND. (NSEQ.GT.0) ) THEN C Is this one of the sequences being tracked? II = NSEQ TRACK = .FALSE. CALL STRSUC(NEMO,NEMO2,LNM2) DO WHILE ((II.GE.1).AND.(.NOT.TRACK)) IF(INDEX(SEQNAM(II),NEMO2(1:LNM2)).GT.0) THEN TRACK = .TRUE. C Mark this level in the output FMT = '(4X,A,2X,A,2X,A,I6,2X,A)' WRITE(LUOUT,FMT) '++++++', NEMO2(1:LNM2), . 'REPLICATION #', IDXREP(II), '++++++' IF(IDXREP(II).LT.NUMREP(II)) THEN C There are more levels to come IDXREP(II) = IDXREP(II)+1 ELSE C This was the last level for this sequence, so stop C tracking it NSEQ = NSEQ-1 ENDIF ELSE II = II-1 ENDIF ENDDO ENDIF ELSEIF(ITYP.EQ.2) THEN C Other numeric value C First check if this node contains a redefined reference C value. If so, modify the DESC field to label it as such. JJ = 1 RDRV = .FALSE. DO WHILE ((JJ.LE.NNRV).AND.(.NOT.RDRV)) IF (NODE.EQ.INODNRV(JJ)) THEN RDRV = .TRUE. DESC = 'New reference value for ' // NEMO UNIT = ' ' ELSE JJ = JJ + 1 ENDIF ENDDO C Check if this element refers to another element via a bitmap. C If so, modify the DESC field to identify the referred element. NRFE = NRFELM(NV,LUN) IF(NRFE.GT.0) THEN TAGRFE = TAG(INV(NRFE,LUN)) JJ = 48 DO WHILE((JJ.GE.1).AND.(DESC(JJ:JJ).EQ.' ')) JJ = JJ - 1 ENDDO IF(JJ.LE.33) DESC(JJ+1:JJ+15) = ' for ' // TAGRFE ENDIF C Now print the value IF(IBFMS(RVAL).NE.0) THEN C The value is "missing". FMT = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)' WRITE(LUOUT,FMT) NUMB,NEMO,PMISS,UNIT,DESC ELSE FMT = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)' C Based upon the corresponding scale factor, select an C appropriate format for the printing of this value. WRITE(FMT(19:20),'(I2)') MAX(1,ISC(NODE)) IF(UNIT(1:4).EQ.'FLAG') THEN C Print a listing of the bits corresponding to C this value. CALL UPFTBV(LUNIT,NEMO,RVAL,MXFV,IFV,NIFV) IF(NIFV.GT.0) THEN UNIT(11:11) = '(' IPT = 12 DO II=1,NIFV ISZ = ISIZE(IFV(II)) WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)' IF((IPT+ISZ).LE.24) THEN WRITE(UNIT(IPT:IPT+ISZ),FMTF) IFV(II), ',' IPT = IPT + ISZ + 1 ELSE UNIT(12:23) = 'MANY BITS ON' IPT = 25 ENDIF ENDDO UNIT(IPT-1:IPT-1) = ')' ENDIF ENDIF WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC IF( (UNIT(1:4).EQ.'FLAG' .OR. UNIT(1:4).EQ.'CODE') .AND. . (CDMF.EQ.'Y') ) THEN C Print the meanings of the code and flag values. FMT = '(35X,I4,A,A)' IF(UNIT(1:4).EQ.'CODE') THEN NIFV = 1 IFV(NIFV) = NINT(RVAL) ENDIF DO II=1,NIFV ICFDP(1) = (-1) IFVD = (-1) CALL SRCHTBF(IDN,IFV(II),ICFDP,MXCFDP,IFVD, . CFMEANG,LCFMEANG,LCFMG,IERSF) IF(IERSF.EQ.0) THEN WRITE(LUOUT,FMT) IFV(II),' = ',CFMEANG(1:LCFMG) ELSEIF(IERSF.LT.0) THEN WRITE(LUOUT,FMT) IFV(II),' = ', . '***THIS IS AN ILLEGAL/UNDEFINED VALUE***' ELSE C The meaning of this value is dependent on the C value of another mnemonic in the report. Look for C that other mnemonic within the report and then use C it and its associated value to retrieve and print C the proper meaning from the code/flag tables. IERFT = (-1) JJ = 0 DO WHILE((JJ.LT.IERSF).AND.(IERFT.LT.0)) JJ = JJ + 1 CALL NUMTBD(LUN,ICFDP(JJ),NEMOD,TAB,IERBD) IF((IERBD.GT.0).AND.(TAB.EQ.'B')) THEN CALL FSTAG(LUN,NEMOD,-1,NV,NOUT,IERFT) ENDIF ENDDO IF(IERFT.EQ.0) THEN IFVD = NINT(VAL(NOUT,LUN)) IF(JJ.GT.1) ICFDP(1) = ICFDP(JJ) CALL SRCHTBF(IDN,IFV(II),ICFDP,MXCFDP,IFVD, . CFMEANG,LCFMEANG,LCFMG,IERSF) IF(IERSF.EQ.0) THEN WRITE(LUOUT,FMT) IFV(II),' = ', . CFMEANG(1:LCFMG) ENDIF ENDIF ENDIF ENDDO ENDIF ENDIF ELSEIF(ITYP.EQ.3) THEN C Character (CCITT IA5) value NCHR = IBT(NODE)/8 IF(IBFMS(RVAL).NE.0) THEN LCHR = PMISS ELSE IF(NCHR.LE.8) THEN LCHR = CVAL ELSE C Track the number of occurrences of this long character string, so C that we can properly output each one. II = 1 FOUND = .FALSE. DO WHILE((II.LE.NLS).AND.(.NOT.FOUND)) IF(NEMO.EQ.LSNEMO(II)) THEN FOUND = .TRUE. ELSE II = II + 1 ENDIF ENDDO IF(.NOT.FOUND) THEN NLS = NLS+1 IF(NLS.GT.MXLS) GOTO 905 LSNEMO(NLS) = NEMO LSCT(NLS) = 1 NEMO3 = NEMO ELSE CALL STRSUC(NEMO,NEMO3,LNM3) LSCT(II) = LSCT(II) + 1 WRITE(FMTF,'(A,I1,A)') '(2A,I', ISIZE(LSCT(II)), ')' WRITE(NEMO3,FMTF) NEMO(1:LNM3), '#', LSCT(II) ENDIF CALL READLC(LUNIT,LCHR2,NEMO3) IF (ICBFMS(LCHR2,NCHR).NE.0) THEN LCHR = PMISS ELSE LCHR = LCHR2(1:20) ENDIF ENDIF IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN IRET = RJUST(LCHR) FMT = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)' WRITE(LUOUT,FMT) NUMB,NEMO,LCHR,NCHR,UNIT,DESC ELSE FMT = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)' WRITE(LUOUT,FMT) NUMB,NEMO,LCHR2(1:NCHR),NCHR,UNIT,DESC ENDIF ENDIF ENDDO WRITE(LUOUT,3) 3 FORMAT(/' >>> END OF SUBSET <<< '/) C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '// . 'OUTPUT, IT MUST BE OPEN FOR INPUT') 902 CALL BORT('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '// . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '// . 'INTERNAL SUBSET ARRAY') 904 CALL BORT('BUFRLIB: UFDUMP - MXSEQ OVERFLOW') 905 CALL BORT('BUFRLIB: UFDUMP - MXLS OVERFLOW') END ./upbb.f0000644001370400056700000000514513440555365011067 0ustar jator2emc SUBROUTINE UPBB(NVAL,NBITS,IBIT,IBAY) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPBB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). C THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPB, EXCEPT IN C UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF ARGUMENTS IS C DIFFERENT). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN- C LINING CODE WITH FPP DIRECTIVES C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- ADDED CHECK FOR NBITS EQUAL TO ZERO; C MODIFIED LOGIC TO MAKE IT CONSISTENT WITH C LOGIC IN UPB; UNIFIED/PORTABLE FOR WRF; C ADDED DOCUMENTATION (INCLUDING HISTORY) C C USAGE: CALL UPBB (NVAL, NBITS, IBIT, IBAY) C INPUT ARGUMENT LIST: C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK C NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY TO START UNPACKING C FROM C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED C NVAL C C OUTPUT ARGUMENT LIST: C NVAL - INTEGER: UNPACKED INTEGER C C REMARKS: C THIS ROUTINE CALLS: IREV C THIS ROUTINE IS CALLED BY: RCSTPL RDTREE UFBGET UFBTAB C UFBTAM UPB WRITLC C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) DIMENSION IBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- C IF NBITS=0, THEN JUST SET NVAL=0 AND RETURN C ------------------------------------------- IF(NBITS.EQ.0)THEN NVAL=0 GOTO 100 ENDIF NWD = IBIT/NBITW + 1 NBT = MOD(IBIT,NBITW) INT = ISHFT(IREV(IBAY(NWD)),NBT) INT = ISHFT(INT,NBITS-NBITW) LBT = NBT+NBITS IF(LBT.GT.NBITW) THEN JNT = IREV(IBAY(NWD+1)) INT = IOR(INT,ISHFT(JNT,LBT-2*NBITW)) ENDIF NVAL = INT C EXIT C ---- 100 RETURN END ./upb.f0000644001370400056700000000466113440555365010727 0ustar jator2emc SUBROUTINE UPB(NVAL,NBITS,IBAY,IBIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER C CONTAINED WITHIN NBITS BITS OF IBAY, STARTING WITH BIT (IBIT+1). C ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS C UNPACKED. THIS IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UPBB, C EXCEPT IN UPBB IBIT IS NOT UPDATED UPON OUTPUT (AND THE ORDER OF C ARGUMENTS IS DIFFERENT). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-05-19 J. ATOR -- ADDED CHECK FOR NBITS EQUAL TO ZERO C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION C 2003-11-04 J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS C IN DECODER VERSION) 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 C 2009-03-23 J. ATOR -- REWROTE TO CALL UPBB C C USAGE: CALL UPB (NVAL, NBITS, IBAY, IBIT) C INPUT ARGUMENT LIST: C NBITS - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO UNPACK C NVAL C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED C NVAL C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER C WHICH TO START UNPACKING C C OUTPUT ARGUMENT LIST: C NVAL - INTEGER: UNPACKED INTEGER C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT C THAT WAS UNPACKED C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C PKB. C C THIS ROUTINE CALLS: UPBB C THIS ROUTINE IS CALLED BY: COPYSB IUPB MVB RDCMPS C RDMGSB READSB STNDRD UFBINX C UFBPOS UFBTAB UFBTAM UPC C WRCMPS WRITLC C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION IBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- CALL UPBB(NVAL,NBITS,IBIT,IBAY) IBIT = IBIT+NBITS RETURN END ./upc.f0000644001370400056700000000572613440555365010733 0ustar jator2emc SUBROUTINE UPC(CHR,NCHR,IBAY,IBIT,CNVNULL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPC C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF C LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF IBAY, STARTING WITH BIT C (IBIT+1). ON OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT C WAS UNPACKED. NOTE THAT THE STRING TO BE UNPACKED DOES NOT C NECESSARILY NEED TO BE ALIGNED ON A BYTE BOUNDARY WITHIN IBAY. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR 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 C 2009-03-23 J. ATOR -- TREAT NULL CHARACTERS AS BLANKS; C PREVENT OVERFLOW OF CHR C 2014-11-19 J. ATOR -- ADD CNVNULL ARGUMENT C C USAGE: CALL UPC (CHR, NCHR, IBAY, IBIT, CNVNULL) C INPUT ARGUMENT LIST: C NCHR - INTEGER: NUMBER OF BYTES OF IBAY WITHIN WHICH TO C UNPACK CHR (I,E, THE NUMBER OF CHARACTERS IN CHR) C IBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING PACKED C CHR C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER C WHICH TO START UNPACKING C CNVNULL - LOGICAL: .TRUE. IF NULL CHARACTERS SHOULD BE C CONVERTED TO BLANKS C C OUTPUT ARGUMENT LIST: C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING OF LENGTH C NCHR C IBIT - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT C THAT WAS UNPACKED C C REMARKS: C THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE C PKC. C C THIS ROUTINE CALLS: IPKM IUPM UPB C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE READLC STBFDX C STNDRD UFBGET UFBTAB UFBTAM C WRCMPS C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) CHARACTER*(*) CHR CHARACTER*8 CVAL DIMENSION IBAY(*),IVAL(2) EQUIVALENCE (CVAL,IVAL) LOGICAL CNVNULL C---------------------------------------------------------------------- C---------------------------------------------------------------------- LB = IORD(NBYTW) CVAL = ' ' NUMCHR = MIN(NCHR,LEN(CHR)) DO I=1,NUMCHR CALL UPB(IVAL(1),8,IBAY,IBIT) IF((IVAL(1).EQ.0).AND.(CNVNULL)) THEN CHR(I:I) = ' ' ELSE CHR(I:I) = CVAL(LB:LB) ENDIF IF(IASCII.EQ.0) CALL IPKM(CHR(I:I),1,IATOE(IUPM(CHR(I:I),8))) ENDDO RETURN END ./upds3.f0000644001370400056700000000546313440555365011200 0ustar jator2emc SUBROUTINE UPDS3(MBAY,LCDS3,CDS3,NDS3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPDS3 C PRGMMR: ATOR ORG: NP12 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE DESCRIPTORS C CONTAINED WITHIN SECTION 3 OF A BUFR MESSAGE STORED IN ARRAY MBAY. C THE START OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE C ALIGNED ON THE FIRST FOUR BYTES OF MBAY. NOTE ALSO THAT THIS C SUBROUTINE DOES NOT RECURSIVELY RESOLVE SEQUENCE DESCRIPTORS THAT C APPEAR WITHIN SECTION 3; RATHER, WHAT IS RETURNED IS THE EXACT LIST C OF DESCRIPTORS AS IT APPEARS WITHIN SECTION 3. C C PROGRAM HISTORY LOG: C 2003-11-04 J. ATOR -- ORIGINAL AUTHOR (WAS IN DECODER VERSION) C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF C 2004-08-18 J. ATOR -- REMOVED IFIRST CHECK, SINCE WRDLEN NOW C KEEPS TRACK OF WHETHER IT HAS BEEN CALLED C 2005-11-29 J. ATOR -- USE GETLENS C 2009-03-23 J. ATOR -- ADDED LCDS3 ARGUMENT AND CHECK C C USAGE: CALL UPDS3 (MBAY, LCDS3, CDS3, NDS3) C INPUT ARGUMENT LIST: C MBAY - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE C LCDS3 - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF CDS3; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE CDS3 ARRAY C C OUTPUT ARGUMENT LIST: C CDS3 - CHARACTER*6: *-WORD ARRAY CONTAINING UNPACKED LIST OF C DESCRIPTORS (FIRST NDS3 WORDS FILLED) C NDS3 - INTEGER: NUMBER OF DESCRIPTORS RETURNED C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT IUPB GETLENS C WRDLEN C THIS ROUTINE IS CALLED BY: READS3 C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ DIMENSION MBAY(*) CHARACTER*6 CDS3(*), ADN30 C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Call subroutine WRDLEN to initialize some important information C about the local machine, just in case subroutine OPENBF hasn't C been called yet. CALL WRDLEN C Skip to the beginning of Section 3. CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5) IPT = LEN0 + LEN1 + LEN2 C Unpack the Section 3 descriptors. NDS3 = 0 DO JJ = 8,(LEN3-1),2 NDS3 = NDS3 + 1 IF(NDS3.GT.LCDS3) GOTO 900 CDS3(NDS3) = ADN30(IUPB(MBAY,IPT+JJ,16),6) ENDDO RETURN 900 CALL BORT('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR '// . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./upftbv.f0000644001370400056700000000551013440555365011441 0ustar jator2emc SUBROUTINE UPFTBV(LUNIT,NEMO,VAL,MXIB,IBIT,NIB) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPFTBV C PRGMMR: JATOR ORG: NP12 DATE: 2005-11-29 C C ABSTRACT: GIVEN A MNEMONIC OF TYPE "FLAG TABLE" ALONG WITH ITS C CORRESPONDING VALUE, THIS SUBROUTINE DETERMINES THE BIT SETTINGS C EQUIVALANT TO THAT VALUE. NOTE THAT THIS SUBROUTINE IS THE C LOGICAL INVERSE OF BUFRLIB SUBROUTINE PKFTBV. C C PROGRAM HISTORY LOG: C 2005-11-29 J. ATOR -- ORIGINAL VERSION C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: UPFTBV (LUNIT,NEMO,VAL,MXIB,IBIT,NIB) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C NEMO - CHARACTER*(*): MNEMONIC OF TYPE "FLAG TABLE" C VAL - REAL*8: VALUE CORRESPONDING TO NEMO C MXIB - INTEGER: DIMENSIONED SIZE OF IBIT IN CALLING PROGRAM C C OUTPUT ARGUMENT LIST: C IBIT - INTEGER(*): BIT NUMBERS WHICH WERE SET TO "ON" C (I.E. SET TO "1") IN VAL C NIB - INTEGER: NUMBER OF BIT NUMBERS RETURNED IN IBIT C C REMARKS: C THIS ROUTINE CALLS: BORT NEMTAB STATUS VALX C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' REAL*8 VAL,R8VAL,R82I INTEGER IBIT (*) CHARACTER*(*) NEMO CHARACTER*128 BORT_STR CHARACTER*1 TAB C---------------------------------------------------------------------- C---------------------------------------------------------------------- C Perform some sanity checks. CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 CALL NEMTAB(LUN,NEMO,IDN,TAB,N) IF(N.EQ.0) GOTO 901 IF(TABB(N,LUN)(71:74).NE.'FLAG') GOTO 902 C Figure out which bits are set. NIB = 0 R8VAL = VAL NBITS = VALX(TABB(N,LUN)(110:112)) DO I=(NBITS-1),0,-1 R82I = (2.)**I IF(ABS(R8VAL-R82I).LT.(0.005)) THEN NIB = NIB + 1 IF(NIB.GT.MXIB) GOTO 903 IBIT(NIB) = NBITS-I RETURN ELSEIF(R82I.LT.R8VAL) THEN NIB = NIB + 1 IF(NIB.GT.MXIB) GOTO 903 IBIT(NIB) = NBITS-I R8VAL = R8VAL - R82I ENDIF ENDDO RETURN 900 CALL BORT('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR INPUT') 901 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// . '" NOT FOUND IN TABLE B")') NEMO CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: UPFTBV - MNEMONIC ",A,'// . '" IS NOT A FLAG TABLE")') NEMO CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') END ./ups.f0000644001370400056700000000472713440555365010753 0ustar jator2emc REAL*8 FUNCTION UPS(IVAL,NODE) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPS C PRGMMR: J. ATOR ORG: NP12 DATE: 2012-03-02 C C ABSTRACT: THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED C BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENCE VALUES. C NORMALLY THE SCALE AND REFERENCE VALUES ARE OBTAINED FROM INDEX C NODE OF THE INTERNAL JUMP/LINK TABLE ARRAYS ISC(*) AND IRF(*); C HOWEVER, THE REFERENCE VALUE IN IRF(*) WILL BE OVERRIDDEN IF A C 2-03 OPERATOR IS IN EFFECT FOR THIS NODE. C C PROGRAM HISTORY LOG: C 2012-03-02 J. ATOR -- ORIGINAL AUTHOR; ADAPTED FROM INTERNAL C STATEMENT FUNCTION IN OTHER SUBROUTINES C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: UPS (IVAL,NODE) C INPUT ARGUMENT LIST: C IVAL - INTEGER: PACKED BUFR INTEGER C NODE - INTEGER: INDEX INTO INTERNAL JUMP/LINK TABLES C C OUTPUT ARGUMENT LIST: C UPS - REAL*8: USER VALUE C C REMARKS: C THIS ROUTINE CALLS: None C THIS ROUTINE IS CALLED BY: RDCMPS RDTREE UFBGET UFBTAB C UFBTAM C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABLES USE MODA_NRV203 INCLUDE 'bufrlib.prm' REAL*8 TEN DATA TEN /10./ C----------------------------------------------------------------------- UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE)) IF ( NNRV .GT. 0 ) THEN C There are redefined reference values in the jump/link table, C so we need to check if this node is affected by any of them. DO JJ = 1, NNRV IF ( NODE .EQ. INODNRV(JJ) ) THEN C This node contains a redefined reference value. C Per the rules of BUFR, negative values may be encoded C as positive integers with the left-most bit set to 1. IMASK = 2**(IBT(NODE)-1) IF ( IAND(IVAL,IMASK) .GT. 0 ) THEN NRV(JJ) = (-1) * ( IVAL - IMASK ) ELSE NRV(JJ) = IVAL END IF UPS = NRV(JJ) RETURN ELSE IF ( ( TAG(NODE)(1:8) .EQ. TAGNRV(JJ) ) .AND. . ( NODE .GE. ISNRV(JJ) ) .AND. . ( NODE .LE. IENRV(JJ) ) ) THEN C The corresponding redefinded reference value needs to C be used when decoding this value. UPS = ( IVAL + NRV(JJ) ) * TEN**(-ISC(NODE)) RETURN END IF END DO END IF RETURN END ./uptdd.f0000644001370400056700000000731313440555365011256 0ustar jator2emc SUBROUTINE UPTDD(ID,LUN,IENT,IRET) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UPTDD C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE RETURNS THE BIT-WISE REPRESENTATION OF THE C FXY VALUE CORRESPONDING TO, SEQUENTIALLY, A PARTICULAR (IENT'th) C "CHILD" MNEMONIC OF A TABLE D SEQUENCE ("PARENT") MNEMONIC. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL UPTDD (ID, LUN, IENT, IRET) C INPUT ARGUMENT LIST: C ID - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN C INTERNAL BUFR TABLE D ARRAY TABD C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C IENT - INTEGER: ORDINAL INDICATOR OF CHILD MNEMONIC TO RETURN C FROM WITHIN TABD(ID,LUN) SEQUENCE: C 0 = return a count of the total number of child C mnemonics within TABD(ID,LUN) C C OUTPUT ARGUMENT LIST: C IRET - INTEGER: RETURN VALUE (SEE REMARKS) C C REMARKS: C THE INTERPRETATION OF THE RETURN VALUE IRET DEPENDS UPON THE INPUT C VALUE IENT, AS FOLLOWS: C C IF ( IENT = 0 ) THEN C IRET = a count of the total number of child mnemonics within C TABD(ID,LUN) C ELSE C IRET = the bit-wise representation of the FXY value C corresponding to the IENT'th child mnemonic of C TABD(ID,LUN) C END IF C C C THIS ROUTINE CALLS: BORT IUPM C THIS ROUTINE IS CALLED BY: NEMTBD RESTD C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD INCLUDE 'bufrlib.prm' COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*128 BORT_STR CHARACTER*56 DXSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- LDD = LDXD(IDXV+1)+1 C CHECK IF IENT IS IN BOUNDS C -------------------------- NDSC = IUPM(TABD(ID,LUN)(LDD:LDD),8) IF(IENT.EQ.0) THEN IRET = NDSC GOTO 100 ELSEIF(IENT.LT.0 .OR. IENT.GT.NDSC) THEN GOTO 900 ENDIF C RETURN THE DESCRIPTOR INDICATED BY IENT C --------------------------------------- IDSC = LDD+1 + (IENT-1)*2 IRET = IUPM(TABD(ID,LUN)(IDSC:IDSC),16) C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UPTDD - VALUE OF THIRD ARGUMENT IENT'// . ' (INPUT) IS OUT OF RANGE (IENT =",I4,")")') IENT CALL BORT(BORT_STR) END ./usrtpl.f0000644001370400056700000002063413440555365011470 0ustar jator2emc SUBROUTINE USRTPL(LUN,INVN,NBMP) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: USRTPL C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL C SUBSET ARRAYS IN MODULE USRINT FOR CASES OF NODE EXPANSION C (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED C REPLICATION FACTOR). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY) (INCOMPLETE); OUTPUTS MORE C COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY OR UNUSUAL THINGS C HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO C "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED C PROBLEMS ON SOME FOREIGN MACHINES) C 2009-03-31 J. WOOLLEN -- ADD DOCUMENTATION C 2009-04-21 J. ATOR -- USE ERRWRT C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL USRTPL (LUN, INVN, NBMP) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C INVN - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE C TO BE EXPANDED WITHIN THE SUBSET TEMPLATE C NBMP - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE C EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE) C C REMARKS: C THIS ROUTINE CALLS: BORT ERRWRT C THIS ROUTINE IS CALLED BY: DRFINI DRSTPL MSGUPD OPENMB C OPENMG RDCMPS TRYBUMP UFBGET C UFBTAB UFBTAM WRCMPS WRITLC C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_TABLES USE MODA_IVTTMP INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR LOGICAL DRP,DRS,DRB,DRX C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,I3,A,I7,A,I5,A,A10)' ) . 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ', . LUN, ':', INVN, ':', NBMP, ':', TAG(INODE(LUN)) CALL ERRWRT(ERRSTR) CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF IF(NBMP.LE.0) THEN IF(IPRT.GE.1) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT('BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF DRP = .FALSE. DRS = .FALSE. DRX = .FALSE. C SET UP A NODE EXPANSION C ----------------------- IF(INVN.EQ.1) THEN c .... case where node is a Table A mnemonic (nodi is positional index) NODI = INODE(LUN) INV(1,LUN) = NODI NVAL(LUN) = 1 IF(NBMP.NE.1) GOTO 900 ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN c .... case where node is (hopefully) a delayed replication factor NODI = INV(INVN,LUN) DRP = TYP(NODI) .EQ. 'DRP' DRS = TYP(NODI) .EQ. 'DRS' DRB = TYP(NODI) .EQ. 'DRB' DRX = DRP .OR. DRS .OR. DRB IVAL = VAL(INVN,LUN) JVAL = 2**IBT(NODI)-1 VAL(INVN,LUN) = IVAL+NBMP IF(DRB.AND.NBMP.NE.1) GOTO 901 IF(.NOT.DRX ) GOTO 902 IF(IVAL.LT.0. ) GOTO 903 IF(IVAL+NBMP.GT.JVAL) GOTO 904 ELSE GOTO 905 ENDIF C RECALL A PRE-FAB NODE EXPANSION SEGMENT C --------------------------------------- NEWN = 0 N1 = ISEQ(NODI,1) N2 = ISEQ(NODI,2) IF(N1.EQ.0 ) GOTO 906 IF(N2-N1+1.GT.MAXJL) GOTO 907 DO N=N1,N2 NEWN = NEWN+1 ITMP(NEWN) = JSEQ(N) VTMP(NEWN) = VALI(JSEQ(N)) ENDDO C MOVE OLD NODES - STORE NEW ONES C ------------------------------- IF(NVAL(LUN)+NEWN*NBMP.GT.MAXSS) GOTO 908 DO J=NVAL(LUN),INVN+1,-1 INV(J+NEWN*NBMP,LUN) = INV(J,LUN) VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN) ENDDO IF(DRP.OR.DRS) VTMP(1) = NEWN KNVN = INVN DO I=1,NBMP DO J=1,NEWN KNVN = KNVN+1 INV(KNVN,LUN) = ITMP(J) VAL(KNVN,LUN) = VTMP(J) ENDDO ENDDO C RESET POINTERS AND COUNTERS C --------------------------- NVAL(LUN) = NVAL(LUN) + NEWN*NBMP IF(IPRT.GE.2) THEN CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') WRITE ( UNIT=ERRSTR, FMT='(A,A,A10,2(A,I5),A,I7)' ) . 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', . 'NVAL(LUN) = ', TAG(INV(INVN,LUN)), ':', NEWN, ':', . NBMP, ':', NVAL(LUN) CALL ERRWRT(ERRSTR) DO I=1,NEWN WRITE ( UNIT=ERRSTR, FMT='(2(A,I5),A,A10)' ) . 'For I = ', I, ', ITMP(I) = ', ITMP(I), . ', TAG(ITMP(I)) = ', TAG(ITMP(I)) CALL ERRWRT(ERRSTR) ENDDO CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') CALL ERRWRT(' ') ENDIF IF(DRX) THEN NODE = NODI INVR = INVN 4 NODE = JMPB(NODE) IF(NODE.GT.0) THEN IF(ITP(NODE).EQ.0) THEN DO INVR=INVR-1,1,-1 IF(INV(INVR,LUN).EQ.NODE) THEN VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP GOTO 4 ENDIF ENDDO GOTO 909 ELSE GOTO 4 ENDIF ENDIF ENDIF C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// . 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '// . 'NODE) (",A,")")') NBMP,TAG(NODI) CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// . 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'// . ' (",A,")")') NBMP,TAG(NODI) CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '// . 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') . TYP(NODI),TAG(NODI) CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '// . 'NEGATIVE (=",I5,") (",A,")")') IVAL,TAG(NODI) CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'// . ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') JVAL,TAG(NODI) CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '// . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'// . ') (",A,")")') INVN,NVAL(LUN),TAG(NODI) CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'// . 'A,")")') TAG(NODI) CALL BORT(BORT_STR) 907 WRITE(BORT_STR,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '// . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') MAXJL,TAG(NODI) CALL BORT(BORT_STR) 908 WRITE(BORT_STR,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'// . ', EXCEEDS THE LIMIT (",I6,") (",A,")")') . NVAL(LUN)+NEWN*NBMP,MAXSS,TAG(NODI) CALL BORT(BORT_STR) 909 WRITE(BORT_STR,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'// . '")")') TAG(NODI) CALL BORT(BORT_STR) END ./valx.f0000644001370400056700000000564513440555365011116 0ustar jator2emc FUNCTION VALX(STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: VALX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS FUNCTION DECODES A REAL NUMBER FROM A CHARACTER C STRING. IF THE DECODE FAILS, THEN THE VALUE BMISS IS C RETURNED. NOTE THAT, UNLIKE FOR SUBROUTINE STRNUM, THE INPUT C STRING MAY CONTAIN A LEADING SIGN CHARACTER (E.G. '+', '-'). C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- RENAMED THIS FUNCTION FROM "VAL$" TO "VALX" C TO REMOVE THE POSSIBILITY OF THE "$" SYMBOL C CAUSING PROBLEMS ON OTHER PLATFORMS 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 2009-04-21 J. ATOR -- USE ERRWRT C C USAGE: VALX (STR) C INPUT ARGUMENT LIST: C STR - CHARACTER*(*): STRING CONTAINING ENCODED REAL VALUE C C OUTPUT ARGUMENT LIST: C VALX - REAL: DECODED VALUE C C REMARKS: C THIS ROUTINE CALLS: BORT2 ERRWRT RJUST C THIS ROUTINE IS CALLED BY: GETTBH NEMTBB UPFTBV C Normally not called by any application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' CHARACTER*(*) STR CHARACTER*128 BORT_STR1,BORT_STR2 CHARACTER*99 BSTR CHARACTER*8 FMT COMMON /QUIET / IPRT C---------------------------------------------------------------------- C---------------------------------------------------------------------- LENS = LEN(STR) IF(LENS.GT.99) GOTO 900 BSTR(1:LENS) = STR RJ = RJUST(BSTR(1:LENS)) WRITE(FMT,'(''(F'',I2,''.0)'')') LENS VALX = BMISS READ(BSTR,FMT,ERR=800) VAL VALX = VAL GOTO 100 800 IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT('BUFRLIB: VALX - ERROR READING STRING:') CALL ERRWRT(BSTR(1:LENS)) CALL ERRWRT('RETURN WITH VALX = MISSING') CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR1,'("STRING IS: ",A)') STR WRITE(BORT_STR2,'("BUFRLIB: VALX - STRING LENGTH EXCEEDS LIMIT '// . ' OF 99 CHARACTERS")') CALL BORT2(BORT_STR1,BORT_STR2) END ./wrcmps.f0000644001370400056700000004047113440555365011453 0ustar jator2emc SUBROUTINE WRCMPS(LUNIX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRCMPS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY C (ARRAY IBAY IN MODULE BITBUF), STORING IT FOR COMPRESSION. C IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MGWA). IF THE C SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT C COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN C ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION). C THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); LOGICAL VARIABLES C "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL C MEMORY (IN COMMON BLOCK /COMPRS/), THIS C FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD C TO MESSAGES BEING WRITTEN OUT BEFORE THEY C ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-08-18 J. ATOR -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS C SAME CAPABILITY); IMPROVE DOCUMENTATION; C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS C THE SAME FOR ALL SUBSETS IN A MESSAGE; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-08-18 J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST' C 2) ADDED 'KMISS' TO FIX BUG WHICH WOULD C OCCASIONALLY SKIP OVER SUBSETS C 3) ADDED LOGIC TO MAKE SURE MISSING VALUES C ARE REPRESENTED BY INCREMENTS WITH ALL C BITS ON C 4) REMOVED TWO UNECESSARY REFERENCES TO C 'WRIT1' C 2005-11-29 J. ATOR -- FIX INITIALIZATION BUG FOR CHARACTER C COMPRESSION; INCREASE MXCSB TO 4000; C USE IUPBS01; CHECK EDITION NUMBER OF BUFR C MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT C 2009-03-23 J. ATOR -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL C 2009-08-11 J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER C STRINGS. ALSO SEPARATED MATX,CATX,NCOL FROM C OTHER VARS IN COMMON COMPRS FOR USE IN C SUBROUTINE WRITLC. ALSO PASSED MBAY(1,LUN) C AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER C FOR USE BY WRITLC. C 2012-02-17 J. ATOR -- FIXED A BUG INVOLVING COMPRESSED FILES WITH C EMBEDDED DICTIONARY MESSAGES C 2014-12-03 J. ATOR -- USE PKX TO PACK LOCAL REFERENCE VALUE FOR C CHARACTER STRINGS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2015-09-24 D. STOKES -- INCLUDE EDGE4 IN SAVE LIST C 2016-03-18 J. ATOR -- FIX BUG INVOLVING ENCODING OF LONG CHARACTER C STRINGS (VIA WRITLC) INTO MESSAGES WHICH C ALSO CONTAIN DELAYED REPLICATION SEQUENCES C C USAGE: CALL WRCMPS (LUNIX) C INPUT ARGUMENT LIST: C LUNIX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A C "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT) C C REMARKS: C THIS ROUTINE CALLS: BORT CMSGINI IUPBS01 MSGFULL C MSGWRT PKB PKC PKX C STATUS UPB UPC USRTPL C THIS ROUTINE IS CALLED BY: CLOSMG WRITSA WRITSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_MGWA USE MODA_TABLES USE MODA_COMPRX USE MODA_COMPRS USE MODA_S01CM INCLUDE 'bufrlib.prm' COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS CHARACTER*128 BORT_STR CHARACTER*8 SUBSET LOGICAL MSGFULL C NOTE THE FOLLOWING LOGICAL FLAGS: C FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE C FIRST SUBSET OF A NEW MESSAGE C FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED C WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY C PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY C IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!) C WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS C TO BE WRITTEN OUT LOGICAL FIRST,KMISS,EDGE4 DATA FIRST /.TRUE./ SAVE FIRST,IBYT,JBIT,SUBSET,EDGE4 C----------------------------------------------------------------------- RLN2 = 1./LOG(2.) C----------------------------------------------------------------------- C GET THE UNIT AND SUBSET TAG C --------------------------- LUNIT = ABS(LUNIX) CALL STATUS(LUNIT,LUN,IL,IM) C IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN C ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR C MESSAGE FOR OUTPUT. 1 IF(FIRST) THEN KBYT = 0 NCOL = 0 LUNC = LUN NROW = NVAL(LUN) SUBSET = TAG(INODE(LUN)) FIRST = .FALSE. FLUSH = .FALSE. WRIT1 = .FALSE. C THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE C HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY C THE INFORMATION IN SECTIONS 0, 1, 2 AND 3. THIS WILL C ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL C FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB. LATER ON, C A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED C BUFR MESSAGE THAT WILL BE WRITTEN OUT. CALL CMSGINI(LUN,MBAY(1,LUN),SUBSET,IDATE(LUN),NCOL,KBYT) C CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED EDGE4 = .FALSE. IF(NS01V.GT.0) THEN II = 1 DO WHILE ( (.NOT.EDGE4) .AND. (II.LE.NS01V) ) IF( (CMNEM(II).EQ.'BEN') .AND. (IVMNEM(II).GE.4) ) THEN EDGE4 = .TRUE. ELSE II = II+1 ENDIF ENDDO ENDIF ENDIF IF(LUN.NE.LUNC) GOTO 900 C IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT C THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE C THE FINAL COMPRESSED BUFR MESSAGE. IF(LUNIX.LT.0) THEN IF(NCOL.EQ.0) GOTO 100 IF(NCOL.GT.0) THEN FLUSH = .TRUE. WRIT1 = .TRUE. ICOL = 1 GOTO 20 ENDIF ENDIF C CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS C --------------------------------------------------- IF(NCOL+1.GT.MXCSB) THEN GOTO 50 ELSEIF(NVAL(LUN).NE.NROW) THEN WRIT1 = .TRUE. ICOL = 1 GOTO 20 ELSEIF(NVAL(LUN).GT.MXCDV) THEN GOTO 901 ENDIF C STORE THE NEXT SUBSET FOR COMPRESSION C ------------------------------------- C WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE? C (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY C RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL C REFERENCE VALUES, INCREMENTS, ETC.) 10 NCOL = NCOL+1 ICOL = NCOL IBIT = 16 DO I=1,NVAL(LUN) NODE = INV(I,LUN) ITYP(I) = ITP(NODE) IWID(I) = IBT(NODE) IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT) ELSEIF(ITYP(I).EQ.3) THEN CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT,.TRUE.) ENDIF ENDDO C COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH C ---------------------------------------------------------- C LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA C (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS C IN THE MESSAGE) 20 LDATA = 0 IF(NCOL.LE.0) GOTO 902 DO I=1,NROW IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN C ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES, C SO KMIS(I) WILL STORE: C .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING" C .TRUE. OTHERWISE IMISS = 2**IWID(I)-1 IF(ICOL.EQ.1) THEN KMIN(I) = IMISS KMAX(I) = 0 KMIS(I) = .FALSE. ENDIF DO J=ICOL,NCOL IF(MATX(I,J).LT.IMISS) THEN KMIN(I) = MIN(KMIN(I),MATX(I,J)) KMAX(I) = MAX(KMAX(I),MATX(I,J)) ELSE KMIS(I) = .TRUE. ENDIF ENDDO KMISS = KMIS(I).AND.KMIN(I).LT.IMISS RANGE = MAX(1,KMAX(I)-KMIN(I)+1) IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE C NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT C COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE. C ASSUMING THAT NONE OF THE VALUES ARE "MISSING", C EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN C OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN. IF(KMISS) GOTO 903 WRIT1 = .TRUE. NCOL = NCOL-1 ICOL = 1 GOTO 20 ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL. C COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE C LARGEST OF THE INCREMENTS. KBIT(I) = NINT(LOG(RANGE)*RLN2) IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1 C HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER C EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING C DESCRIPTOR! IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I) ELSE C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. KBIT(I) = 0 ENDIF LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) ELSEIF(ITYP(I).EQ.3) THEN C ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES, C SO KMIS(I) WILL STORE: C .FALSE. IF ALL SUCH VALUES ARE IDENTICAL C .TRUE. OTHERWISE IF(ICOL.EQ.1) THEN CSTR(I) = CATX(I,1) KMIS(I) = .FALSE. ENDIF DO J=ICOL,NCOL IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN KMIS(I) = .TRUE. ENDIF ENDDO IF (KMIS(I)) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL. KBIT(I) = IWID(I) ELSE C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. KBIT(I) = 0 ENDIF LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) ENDIF ENDDO C ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT C ------------------------------------------ IBYT = (LDATA+8-MOD(LDATA,8))/8 C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE C THAT WE ROUND TO AN EVEN BYTE COUNT IF( (.NOT.EDGE4) .AND. (MOD(IBYT,2).NE.0) ) IBYT = IBYT+1 JBIT = IBYT*8-LDATA C CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN C ------------------------------------------------------------------ IF(MSGFULL(IBYT,KBYT,MAXCMB)) THEN C THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE. C SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED, C THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS C MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET C (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A C NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!). WRIT1 = .TRUE. NCOL = NCOL-1 ICOL = 1 GOTO 20 ELSEIF(.NOT.WRIT1) THEN C ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN. CALL USRTPL(LUN,1,1) NSUB(LUN) = -NCOL GOTO 100 ENDIF C WRITE THE COMPLETE COMPRESSED MESSAGE C ------------------------------------- C NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED C BUFR MESSAGE THAT WILL BE WRITTEN OUT. 50 CALL CMSGINI(LUN,MGWA,SUBSET,IDATE(LUN),NCOL,IBYT) C NOW ADD THE SECTION 4 DATA. IBIT = IBYT*8 DO I=1,NROW IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN CALL PKB(KMIN(I),IWID(I),MGWA,IBIT) CALL PKB(KBIT(I), 6,MGWA,IBIT) IF(KBIT(I).GT.0) THEN DO J=1,NCOL IF(MATX(I,J).LT.2**IWID(I)-1) THEN INCR = MATX(I,J)-KMIN(I) ELSE INCR = 2**KBIT(I)-1 ENDIF CALL PKB(INCR,KBIT(I),MGWA,IBIT) ENDDO ENDIF ELSEIF(ITYP(I).EQ.3) THEN NCHR = IWID(I)/8 IF(KBIT(I).GT.0) THEN CALL PKX( 0,IWID(I),MGWA,IBIT) CALL PKB(NCHR, 6,MGWA,IBIT) DO J=1,NCOL CALL PKC(CATX(I,J),NCHR,MGWA,IBIT) ENDDO ELSE CALL PKC(CSTR(I),NCHR,MGWA,IBIT) CALL PKB( 0, 6,MGWA,IBIT) ENDIF ENDIF ENDDO C FILL IN THE END OF THE MESSAGE C ------------------------------ C PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY C BYTE COUNT. CALL PKB( 0,JBIT,MGWA,IBIT) C ADD SECTION 5. CALL PKC('7777', 4,MGWA,IBIT) C SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE C ------------------------------------------------------------- IF(MOD(IBIT,8).NE.0) GOTO 904 LBYT = IUPBS01(MGWA,'LENM') NBYT = IBIT/8 IF(NBYT.NE.LBYT) GOTO 905 CALL MSGWRT(LUNIT,MGWA,NBYT) MAXROW = MAX(MAXROW,NROW) MAXCOL = MAX(MAXCOL,NCOL) NCMSGS = NCMSGS+1 NCSUBS = NCSUBS+NCOL NCBYTS = NCBYTS+NBYT C RESET C ----- C NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK C AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE C WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT. FIRST = .TRUE. IF(.NOT.FLUSH) GOTO 1 C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '// . 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'// . ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// . 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '// . 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// . 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR') 904 CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '// . ' A BYTE BOUNDARY') 905 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'// .',I6,")")') LBYT,NBYT CALL BORT(BORT_STR) END ./wrdesc.c0000644001370400056700000000316713440555365011425 0ustar jator2emc/*$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRDESC C PRGMMR: ATOR ORG: NP12 DATE: 2004-08-18 C C ABSTRACT: GIVEN THE BIT-WISE REPRESENTATION OF A DESCRIPTOR, C THIS ROUTINE ADDS IT TO AN ONGOING ARRAY OF DESCRIPTORS, AFTER C FIRST MAKING SURE THAT THERE IS ENOUGH ROOM IN THE ARRAY. C IF AN ARRAY OVERFLOW OCCURS, THEN AN APPROPRIATE ERROR MESSAGE C WILL BE WRITTEN VIA BORT. C C PROGRAM HISTORY LOG: C 2004-08-18 J. ATOR -- ORIGINAL AUTHOR C C USAGE: CALL WRDESC( DESC, DESCARY, NDESCARY ) C INPUT ARGUMENT LIST: C DESC - INTEGER: BIT-WISE REPRESENTATION OF DESCRIPTOR C TO BE WRITTEN INTO DESCARY C DESCARY - INTEGER: ARRAY OF DESCRIPTORS C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR C INTO DESCARY C C OUTPUT ARGUMENT LIST: C DESCARY - INTEGER: ARRAY OF DESCRIPTORS C NDESCARY - INTEGER: NUMBER OF DESCRIPTORS WRITTEN SO FAR C INTO DESCARY C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: RESTD C Normally not called by application C programs but it could be. C C ATTRIBUTES: C LANGUAGE: C C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$*/ #include "bufrlib.h" void wrdesc( f77int desc, f77int descary[], f77int *ndescary ) { char errstr[129]; /* ** Is there room in descary for desc ? */ if ( ( *ndescary + 1 ) < MAXNC ) { descary[(*ndescary)++] = desc; } else { sprintf( errstr, "BUFRLIB: WRDESC - EXPANDED SECTION 3 CONTAINS" " MORE THAN %d DESCRIPTORS", MAXNC ); bort( errstr, ( f77int ) strlen( errstr ) ); } return; } ./wrdlen.F0000644001370400056700000003174113440555365011373 0ustar jator2emc SUBROUTINE WRDLEN C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRDLEN C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE FIGURES OUT SOME IMPORTANT INFORMATION C ABOUT THE LOCAL MACHINE ON WHICH THE BUFR ARCHIVE LIBRARY SOFTWARE C IS BEING RUN AND STORES THIS INTO COMMON BLOCK /HRDWRD/. SUCH C INFORMATION INCLUDES DETERMINING THE NUMBER OF BITS AND THE NUMBER C OF BYTES IN A MACHINE WORD AS WELL AS DETERMINING WHETHER THE C MACHINE USES THE ASCII OR EBCDIC CHARACTER SET. C C NOTE: IT IS ONLY NECESSARY FOR THIS SUBROUTINE TO BE CALLED ONCE, C AND THIS IS NORMALLY DONE DURING THE FIRST CALL TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF. HOWEVER, THE SUBROUTINE DOES KEEP TRACK C OF WHETHER IT HAS ALREADY BEEN CALLED; THUS, IF IT IS CALLED AGAIN C LATER BY A DIFFERENT BUFR ARCHIVE LIBRARY SUBROUTINE, IT WILL JUST C QUIETLY RETURN WITHOUT (RE)COMPUTING ALL OF THE INFORMATION WITHIN C COMMON BLOCK /HRDWRD/. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 OR FOR INFORMATIONAL PURPOSES; C NBYTW INITIALIZED AS ZERO THE FIRST TIME C THIS ROUTINE IS CALLED (BEFORE WAS C UNDEFINED WHEN FIRST REFERENCED) C 2004-08-18 J. ATOR -- ADDED SAVE FOR IFIRST FLAG AND IMMEDIATE C RETURN IF IFIRST=1 C 2007-01-19 J. ATOR -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW C DETERMINED AT COMPILE TIME AND CONFIGURED C WITHIN BUFRLIB VIA CONDITIONAL COMPILATION C DIRECTIVES C 2009-03-23 J. ATOR -- CALL BVERS TO GET VERSION NUMBER C C USAGE: CALL WRDLEN C C REMARKS: C THIS ROUTINE CALLS: BORT BVERS ERRWRT IUPM C THIS ROUTINE IS CALLED BY: COBFL COPYBF DATEBF DATELEN C DUMPBF IUPBS01 MESGBC MESGBF C OPENBF RDMTBB RDMTBD RDMTBF C UPDS3 C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255) COMMON /QUIET / IPRT CHARACTER*128 BORT_STR,ERRSTR CHARACTER*8 CINT,DINT,CVSTR CHARACTER*6 CNDIAN,CLANG EQUIVALENCE (CINT,INT) EQUIVALENCE (DINT,JNT) LOGICAL PRINT DATA IFIRST/0/ SAVE IFIRST C----------------------------------------------------------------------- C----------------------------------------------------------------------- C HAS THIS SUBROUTINE ALREADY BEEN CALLED? IF(IFIRST.EQ.0) THEN C NO, SO CHECK WHETHER DIAGNOSTIC INFORMATION SHOULD BE PRINTED C AND THEN PROCEED THROUGH THE REST OF THE SUBROUTINE. PRINT = IPRT.GE.1 IFIRST = 1 ELSE C YES, SO THERE IS NO NEED TO PROCEED ANY FURTHER. RETURN ENDIF C COUNT THE BITS IN A WORD - MAX 64 ALLOWED C ----------------------------------------- INT = 1 DO I=1,65 INT = ISHFT(INT,1) IF(INT.EQ.0) GOTO 10 ENDDO c .... DK: Can the below ever happen since upper loop bounds is 65? 10 IF(I.GE.65) GOTO 900 IF(MOD(I,8).NE.0) GOTO 901 C NBITW is no. of bits in a word, NBYTW is no. of bytes in a word C --------------------------------------------------------------- NBITW = I NBYTW = I/8 C INDEX THE BYTE STORAGE ORDER - HIGH BYTE TO LOW BYTE C ----------------------------------------------------- JNT = 0 DO I = 1,8 IORD(I) = 9999 ENDDO DO I=1,NBYTW INT = ISHFT(1,(NBYTW-I)*8) DO J=1,NBYTW IF(CINT(J:J).NE.DINT(J:J)) GOTO 20 ENDDO c .... DK: Can the below ever happen since upper loop bounds is NBYTW? 20 IF(J.GT.NBYTW) GOTO 902 IORD(I) = J ENDDO C SETUP AN ASCII/EBCDIC TRANSLATOR AND DETERMINE WHICH IS NATIVE C -------------------------------------------------------------- IA = IUPM('A',8) IF(IA.EQ. 65) THEN IASCII = 1 CLANG = 'ASCII ' ELSEIF(IA.EQ.193) THEN IASCII = 0 CLANG = 'EBCDIC' ELSE GOTO 903 ENDIF DO I=0,255 IETOA(I) = 0 IATOE(I) = 0 ENDDO IETOA( 1) = 1 IATOE( 1) = 1 IETOA( 2) = 2 IATOE( 2) = 2 IETOA( 3) = 3 IATOE( 3) = 3 IETOA( 5) = 9 IATOE( 9) = 5 IETOA( 7) = 127 IATOE(127) = 7 IETOA( 11) = 11 IATOE( 11) = 11 IETOA( 12) = 12 IATOE( 12) = 12 IETOA( 13) = 13 IATOE( 13) = 13 IETOA( 14) = 14 IATOE( 14) = 14 IETOA( 15) = 15 IATOE( 15) = 15 IETOA( 16) = 16 IATOE( 16) = 16 IETOA( 17) = 17 IATOE( 17) = 17 IETOA( 18) = 18 IATOE( 18) = 18 IETOA( 19) = 19 IATOE( 19) = 19 IETOA( 22) = 8 IATOE( 8) = 22 IETOA( 24) = 24 IATOE( 24) = 24 IETOA( 25) = 25 IATOE( 25) = 25 IETOA( 29) = 29 IATOE( 29) = 29 IETOA( 31) = 31 IATOE( 31) = 31 IETOA( 34) = 28 IATOE( 28) = 34 IETOA( 37) = 10 IATOE( 10) = 37 IETOA( 38) = 23 IATOE( 23) = 38 IETOA( 39) = 27 IATOE( 27) = 39 IETOA( 45) = 5 IATOE( 5) = 45 IETOA( 46) = 6 IATOE( 6) = 46 IETOA( 47) = 7 IATOE( 7) = 47 IETOA( 50) = 22 IATOE( 22) = 50 IETOA( 53) = 30 IATOE( 30) = 53 IETOA( 55) = 4 IATOE( 4) = 55 IETOA( 60) = 20 IATOE( 20) = 60 IETOA( 61) = 21 IATOE( 21) = 61 IETOA( 63) = 26 IATOE( 26) = 63 IETOA( 64) = 32 IATOE( 32) = 64 IETOA( 74) = 91 IATOE( 91) = 74 IETOA( 75) = 46 IATOE( 46) = 75 IETOA( 76) = 60 IATOE( 60) = 76 IETOA( 77) = 40 IATOE( 40) = 77 IETOA( 78) = 43 IATOE( 43) = 78 IETOA( 79) = 33 IATOE( 33) = 79 IETOA( 80) = 38 IATOE( 38) = 80 IETOA( 90) = 93 IATOE( 93) = 90 IETOA( 91) = 36 IATOE( 36) = 91 IETOA( 92) = 42 IATOE( 42) = 92 IETOA( 93) = 41 IATOE( 41) = 93 IETOA( 94) = 59 IATOE( 59) = 94 IETOA( 95) = 94 IATOE( 94) = 95 IETOA( 96) = 45 IATOE( 45) = 96 IETOA( 97) = 47 IATOE( 47) = 97 IETOA(106) = 124 IATOE(124) = 106 IETOA(107) = 44 IATOE( 44) = 107 IETOA(108) = 37 IATOE( 37) = 108 IETOA(109) = 95 IATOE( 95) = 109 IETOA(110) = 62 IATOE( 62) = 110 IETOA(111) = 63 IATOE( 63) = 111 IETOA(121) = 96 IATOE( 96) = 121 IETOA(122) = 58 IATOE( 58) = 122 IETOA(123) = 35 IATOE( 35) = 123 IETOA(124) = 64 IATOE( 64) = 124 IETOA(125) = 39 IATOE( 39) = 125 IETOA(126) = 61 IATOE( 61) = 126 IETOA(127) = 34 IATOE( 34) = 127 IETOA(129) = 97 IATOE( 97) = 129 IETOA(130) = 98 IATOE( 98) = 130 IETOA(131) = 99 IATOE( 99) = 131 IETOA(132) = 100 IATOE(100) = 132 IETOA(133) = 101 IATOE(101) = 133 IETOA(134) = 102 IATOE(102) = 134 IETOA(135) = 103 IATOE(103) = 135 IETOA(136) = 104 IATOE(104) = 136 IETOA(137) = 105 IATOE(105) = 137 IETOA(145) = 106 IATOE(106) = 145 IETOA(146) = 107 IATOE(107) = 146 IETOA(147) = 108 IATOE(108) = 147 IETOA(148) = 109 IATOE(109) = 148 IETOA(149) = 110 IATOE(110) = 149 IETOA(150) = 111 IATOE(111) = 150 IETOA(151) = 112 IATOE(112) = 151 IETOA(152) = 113 IATOE(113) = 152 IETOA(153) = 114 IATOE(114) = 153 IETOA(161) = 126 IATOE(126) = 161 IETOA(162) = 115 IATOE(115) = 162 IETOA(163) = 116 IATOE(116) = 163 IETOA(164) = 117 IATOE(117) = 164 IETOA(165) = 118 IATOE(118) = 165 IETOA(166) = 119 IATOE(119) = 166 IETOA(167) = 120 IATOE(120) = 167 IETOA(168) = 121 IATOE(121) = 168 IETOA(169) = 122 IATOE(122) = 169 IETOA(173) = 91 IATOE( 91) = 173 IETOA(176) = 48 IATOE( 48) = 176 IETOA(177) = 49 IATOE( 49) = 177 IETOA(178) = 50 IATOE( 50) = 178 IETOA(179) = 51 IATOE( 51) = 179 IETOA(180) = 52 IATOE( 52) = 180 IETOA(181) = 53 IATOE( 53) = 181 IETOA(182) = 54 IATOE( 54) = 182 IETOA(183) = 55 IATOE( 55) = 183 IETOA(184) = 56 IATOE( 56) = 184 IETOA(185) = 57 IATOE( 57) = 185 IETOA(189) = 93 IATOE( 93) = 189 IETOA(192) = 123 IATOE(123) = 192 IETOA(193) = 65 IATOE( 65) = 193 IETOA(194) = 66 IATOE( 66) = 194 IETOA(195) = 67 IATOE( 67) = 195 IETOA(196) = 68 IATOE( 68) = 196 IETOA(197) = 69 IATOE( 69) = 197 IETOA(198) = 70 IATOE( 70) = 198 IETOA(199) = 71 IATOE( 71) = 199 IETOA(200) = 72 IATOE( 72) = 200 IETOA(201) = 73 IATOE( 73) = 201 IETOA(208) = 125 IATOE(125) = 208 IETOA(209) = 74 IATOE( 74) = 209 IETOA(210) = 75 IATOE( 75) = 210 IETOA(211) = 76 IATOE( 76) = 211 IETOA(212) = 77 IATOE( 77) = 212 IETOA(213) = 78 IATOE( 78) = 213 IETOA(214) = 79 IATOE( 79) = 214 IETOA(215) = 80 IATOE( 80) = 215 IETOA(216) = 81 IATOE( 81) = 216 IETOA(217) = 82 IATOE( 82) = 217 IETOA(224) = 92 IATOE( 92) = 224 IETOA(226) = 83 IATOE( 83) = 226 IETOA(227) = 84 IATOE( 84) = 227 IETOA(228) = 85 IATOE( 85) = 228 IETOA(229) = 86 IATOE( 86) = 229 IETOA(230) = 87 IATOE( 87) = 230 IETOA(231) = 88 IATOE( 88) = 231 IETOA(232) = 89 IATOE( 89) = 232 IETOA(233) = 90 IATOE( 90) = 233 IETOA(240) = 48 IATOE( 48) = 240 IETOA(241) = 49 IATOE( 49) = 241 IETOA(242) = 50 IATOE( 50) = 242 IETOA(243) = 51 IATOE( 51) = 243 IETOA(244) = 52 IATOE( 52) = 244 IETOA(245) = 53 IATOE( 53) = 245 IETOA(246) = 54 IATOE( 54) = 246 IETOA(247) = 55 IATOE( 55) = 247 IETOA(248) = 56 IATOE( 56) = 248 IETOA(249) = 57 IATOE( 57) = 249 C SHOW SOME RESULTS C ----------------- IF(PRINT) THEN CALL BVERS(CVSTR) #ifdef BIG_ENDIAN CNDIAN = ' BIG ' #else CNDIAN = 'LITTLE' #endif ERRSTR = '=============== ' // . 'WELCOME TO THE BUFR ARCHIVE LIBRARY' // ' ==============' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I2)' ) . ' MACHINE CHARACTERISTICS: NUMBER OF BYTES PER WORD =', NBYTW CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I3)' ) . ' NUMBER OF BITS PER WORD =', NBITW CALL ERRWRT(ERRSTR) ERRSTR = ' BYTE ORDER IS ' // CNDIAN // . ' ENDIAN' CALL ERRWRT(ERRSTR) ERRSTR = ' ' // CLANG // . ' IS THE NATIVE LANGUAGE' CALL ERRWRT(ERRSTR) ERRSTR = '====================== VERSION: ' // CVSTR // . '==========================' CALL ERRWRT(ERRSTR) CALL ERRWRT(' ') ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH IS '// . 'LIMITED TO 64 BITS (THIS MACHINE APPARENTLY HAS",I4," BIT '// . 'WORDS!)")') I CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH (",I4,"'// . ') IS NOT A MULTIPLE OF 8 (THIS MACHINE HAS WORDS NOT ON WHOLE'// . ' BYTE BOUNDARIES!)")') I CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - BYTE ORDER CHECKING MISTAKE'// . ', LOOP INDEX J (HERE =",I3,") IS .GT. NO. OF BYTES PER WORD '// . 'ON THIS MACHINE (",I3,")")') J,NBYTW CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - CAN''T DETERMINE MACHINE '// . 'NATIVE LANGUAGE (CHAR. A UNPACKS TO INT.",I4," NEITHER ASCII '// . ' (65) NOR EBCDIC (193)")') IA CALL BORT(BORT_STR) END ./wrdxtb.f0000644001370400056700000001326513440555365011453 0ustar jator2emc SUBROUTINE WRDXTB(LUNDX,LUNOT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRDXTB C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23 C C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES C ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT. C BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE C LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE C BEEN OPENED FOR OUTPUT. THE TABLE MESSAGES ARE GENERATED FROM C ARRAYS IN INTERNAL MEMORY (MODULE TABABD). LUNDX CAN BE THE C SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR C MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES. C C PROGRAM HISTORY LOG: C 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX C 2012-04-06 J. ATOR -- PREVENT STORING OF MORE THAN 255 TABLE A, C TABLE B OR TABLE D DESCRIPTORS IN ANY C SINGLE DX MESSAGE C 2014-11-14 J. ATOR -- REPLACE IPKM CALLS WITH PKB CALLS C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL WRDXTB (LUNDX,LUNOT) C INPUT ARGUMENT LIST: C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED C WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT; C CAN BE SAME AS LUNOT C LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT CPBFDX DXMINI C GETLENS IUPB IUPM MSGFULL C MSGWRT PKB PKC STATUS C THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_TABABD USE MODA_MGWA INCLUDE 'bufrlib.prm' COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*128 BORT_STR CHARACTER*56 DXSTR CHARACTER*6 ADN30 LOGICAL MSGFULL C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK FILE STATUSES C ------------------- CALL STATUS(LUNOT,LOT,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 CALL STATUS(LUNDX,LDX,IL,IM) IF(IL.EQ.0) GOTO 902 C IF FILES ARE DIFFERENT, COPY INTERNAL TABLE C INFORMATION FROM LUNDX TO LUNOT C ------------------------------------------- IF(LUNDX.NE.LUNOT) CALL CPBFDX(LDX,LOT) C GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT C -------------------------------------------------------- CALL DXMINI(LOT,MGWA,MBYT,MBY4,MBYA,MBYB,MBYD) LDA = LDXA(IDXV+1) LDB = LDXB(IDXV+1) LDD = LDXD(IDXV+1) L30 = LD30(IDXV+1) C Table A information DO I=1,NTBA(LOT) IF(MSGFULL(MBYT,LDA,MAXDX).OR. + (IUPB(MGWA,MBYA,8).EQ.255)) THEN CALL MSGWRT(LUNOT,MGWA,MBYT) CALL DXMINI(LOT,MGWA,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF MBIT = 8*(MBY4-1) CALL PKB(IUPB(MGWA,MBY4,24)+LDA,24,MGWA,MBIT) MBIT = 8*(MBYA-1) CALL PKB(IUPB(MGWA,MBYA, 8)+ 1, 8,MGWA,MBIT) MBIT = 8*(MBYB-1) CALL PKC(TABA(I,LOT),LDA,MGWA,MBIT) CALL PKB( 0, 8,MGWA,MBIT) CALL PKB( 0, 8,MGWA,MBIT) MBYT = MBYT+LDA MBYB = MBYB+LDA MBYD = MBYD+LDA ENDDO C Table B information DO I=1,NTBB(LOT) IF(MSGFULL(MBYT,LDB,MAXDX).OR. + (IUPB(MGWA,MBYB,8).EQ.255)) THEN CALL MSGWRT(LUNOT,MGWA,MBYT) CALL DXMINI(LOT,MGWA,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF MBIT = 8*(MBY4-1) CALL PKB(IUPB(MGWA,MBY4,24)+LDB,24,MGWA,MBIT) MBIT = 8*(MBYB-1) CALL PKB(IUPB(MGWA,MBYB, 8)+ 1, 8,MGWA,MBIT) MBIT = 8*(MBYD-1) CALL PKC(TABB(I,LOT),LDB,MGWA,MBIT) CALL PKB( 0, 8,MGWA,MBIT) MBYT = MBYT+LDB MBYD = MBYD+LDB ENDDO C Table D information DO I=1,NTBD(LOT) NSEQ = IUPM(TABD(I,LOT)(LDD+1:LDD+1),8) LEND = LDD+1 + L30*NSEQ IF(MSGFULL(MBYT,LEND,MAXDX).OR. + (IUPB(MGWA,MBYD,8).EQ.255)) THEN CALL MSGWRT(LUNOT,MGWA,MBYT) CALL DXMINI(LOT,MGWA,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF MBIT = 8*(MBY4-1) CALL PKB(IUPB(MGWA,MBY4,24)+LEND,24,MGWA,MBIT) MBIT = 8*(MBYD-1) CALL PKB(IUPB(MGWA,MBYD, 8)+ 1, 8,MGWA,MBIT) MBIT = 8*(MBYT-4) CALL PKC(TABD(I,LOT),LDD,MGWA,MBIT) CALL PKB( NSEQ, 8,MGWA,MBIT) DO J=1,NSEQ JJ = LDD+2 + (J-1)*2 IDN = IUPM(TABD(I,LOT)(JJ:JJ),16) CALL PKC(ADN30(IDN,L30),L30,MGWA,MBIT) ENDDO MBYT = MBYT+LEND ENDDO C Write the unwritten (leftover) message. CALL MSGWRT(LUNOT,MGWA,MBYT) C Write out one additional (dummy) DX message containing zero C subsets. This will serve as a delimiter for this set of C table messages within output unit LUNOT, just in case the C next thing written to LUNOT ends up being another set of C table messages. CALL DXMINI(LOT,MGWA,MBYT,MBY4,MBYA,MBYB,MBYD) CALL GETLENS(MGWA,2,LEN0,LEN1,LEN2,L3,L4,L5) MBIT = (LEN0+LEN1+LEN2+4)*8 CALL PKB(0,16,MGWA,MBIT) CALL MSGWRT(LUNOT,MGWA,MBYT) C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '// . 'MUST BE OPEN') END ./writcp.f0000644001370400056700000000327113440555365011445 0ustar jator2emc SUBROUTINE WRITCP(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITCP C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT NOW SIMPLY CALLS C BUFR ARCHIVE LIBRARY SUBROUTINE CMPMSG TO TOGGLE ON MESSAGE C COMPRESSION, FOLLOWED BY A CALL TO WRITSB TO PACK UP THE CURRENT C SUBSET WITHIN MEMORY AND TRY TO ADD IT TO THE COMPRESSED BUFR C MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT, C FOLLOWED BY ANOTHER CALL TO CMPMSG TO TOGGLE OFF MESSAGE C COMPRESSION. THIS SUBROUTINE USES THE SAME INPUT AND OUTPUT C PARAMETERS AS WRITSB. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR 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 2005-03-09 J. ATOR -- MODIFIED TO USE CMPMSG AND WRITSB C C USAGE: CALL WRITCP (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: CMPMSG WRITSB C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CALL CMPMSG('Y') CALL WRITSB(LUNIT) CALL CMPMSG('N') RETURN END ./writdx.f0000644001370400056700000000677013440555365011465 0ustar jator2emc SUBROUTINE WRITDX(LUNIT,LUN,LUNDX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES TO C THE BEGINNING OF AN OUTPUT BUFR FILE IN LUNIT. THE TABLE MESSAGES C ARE READ FROM ARRAYS IN INTERNAL MEMORY (MODULE TABABD). C AN INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READDX GENERATES C THESE INTERNAL ARRAYS. 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 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 2009-03-23 J. ATOR -- USE WRDXTB C C USAGE: CALL WRITDX (LUNIT, LUN, LUNDX) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C BEING WRITTEN C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING C DICTIONARY TABLE INFORMATION TO BE USED (BY READDX) TO C CREATE INTERNAL TABLES WRITTEN TO LUNIT (SEE READDX); C IF SET EQUAL TO LUNIT, THIS SUBROUTINE CALLS BORT C C REMARKS: C THIS ROUTINE CALLS: BORT READDX WRDXTB C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK UNITS, TABLE MUST BE COMING FROM AN INPUT FILE C ---------------------------------------------------- IF(LUNIT.EQ.LUNDX) GOTO 900 C MUST FIRST CALL READDX TO GENERATE INTERNAL DICTIONARY TABLE ARRAYS C ------------------------------------------------------------------- CALL READDX(LUNIT,LUN,LUNDX) C NOW CALL WRDXTB TO WRITE OUT DICTIONARY MESSAGES FROM THESE ARRAYS C ------------------------------------------------------------------ CALL WRDXTB(LUNIT,LUNIT) C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRITDX - FILES CONTAINING BUFR DATA '// . 'AND DICTIONARY TABLE CANNOT BE THE SAME (HERE BOTH SHARE '// . 'FORTRAN UNIT NUMBER ",I3,")")') LUNIT CALL BORT(BORT_STR) END ./writlc.f0000644001370400056700000001772113440555365011446 0ustar jator2emc SUBROUTINE WRITLC(LUNIT,CHR,STR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITLC C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04 C C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER DATA ELEMENT ASSOCIATED C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER C (ARRAY MBAY IN MODULE BITBUF). IT IS DESIGNED TO BE USED C TO STORE CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT C BYTES. NOTE THAT SUBROUTINE WRITSB OR WRITSA MUST HAVE ALREADY C BEEN CALLED TO STORE ALL OTHER ELEMENTS OF THE SUBSET BEFORE THIS C SUBROUTINE CAN BE CALLED TO FILL IN ANY LONG CHARACTER STRINGS. C C PROGRAM HISTORY LOG: C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION; OUTPUTS MORE COMPLETE C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES C 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 C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR C 2009-03-23 J. ATOR -- ADDED '#' OPTION FOR MORE THAN ONE C OCCURRENCE OF STR c 2009-08-11 J. WOOLLEN -- ADDED COMMON COMPRS ALONG WITH LOGIC TO c WRITE LONG STRINGS INTO COMPRESSED SUBSETS C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS C WHEN USED WITH '#' OCCURRENCE CODE C 2014-10-22 J. ATOR -- NO LONGER ABORT IF NO SUBSET AVAILABLE FOR C WRITING; JUST PRINT A WARNING MESSAGE C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL WRITLC (LUNIT, CHR, STR) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E., C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES) C STR - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR C C REMARKS: C THIS ROUTINE CALLS: BORT GETLENS IUPBS3 PARSTR C PARUTG PKC STATUS UPB C UPBB USRTPL C THIS ROUTINE IS CALLED BY: MSGUPD C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF USE MODA_TABLES USE MODA_COMPRS INCLUDE 'bufrlib.prm' COMMON /QUIET / IPRT CHARACTER*(*) CHR,STR CHARACTER*128 BORT_STR CHARACTER*128 ERRSTR CHARACTER*10 CTAG CHARACTER*14 TGS(10) DATA MAXTG /10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE) C ------------------------------------------------------------------ CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.) IF(NTG.GT.1) GOTO 903 C Check if a specific occurrence of the input string was requested; C if not, then the default is to write the first occurrence. CALL PARUTG(LUN,1,TGS(1),NNOD,KON,ROID) IF(KON.EQ.6) THEN IOID=NINT(ROID) IF(IOID.LE.0) IOID = 1 CTAG = ' ' II = 1 DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#')) CTAG(II:II)=TGS(1)(II:II) II = II + 1 ENDDO ELSE IOID = 1 CTAG = TGS(1)(1:10) ENDIF C USE THIS LEG FOR STRINGING COMPRESSED DATA (UP TO MXLCC CHARACTERS) C ---------------------------------------------------------------- IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN N = 1 ITAGCT = 0 CALL USRTPL(LUN,N,N) DO WHILE (N+1.LE.NVAL(LUN)) N = N+1 NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN CALL USRTPL(LUN,N,MATX(N,NCOL)) ELSEIF(CTAG.EQ.TAG(NODE)) THEN ITAGCT = ITAGCT + 1 IF(ITAGCT.EQ.IOID) THEN IF(ITP(NODE).NE.3) GOTO 904 CATX(N,NCOL)=' ' C -------------------------------------------------- C Note: the following stmt enforces a limit of MXLCC C characters per long character string when writing C compressed messages. This limit keeps the static C array CATX to a reasonable dimensioned size. C -------------------------------------------------- NCHR=MIN(MXLCC,IBT(NODE)/8) CATX(N,NCOL)=CHR(1:NCHR) CALL USRTPL(LUN,1,1) GOTO 100 ENDIF ENDIF ENDDO GOTO 906 ENDIF C OTHERWISE LOCATE THE BEGINNING OF THE DATA (SECTION 4) IN THE MESSAGE C --------------------------------------------------------------------- CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5) MBYTE = LEN0 + LEN1 + LEN2 + LEN3 + 4 NSUBS = 1 C FIND THE MOST RECENTLY WRITTEN SUBSET IN THE MESSAGE C ---------------------------------------------------- DO WHILE(NSUBS.LT.NSUB(LUN)) IBIT = MBYTE*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) MBYTE = MBYTE + NBYT NSUBS = NSUBS + 1 ENDDO IF(NSUBS.NE.NSUB(LUN)) THEN IF(IPRT.GE.0) THEN CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') ERRSTR = 'BUFRLIB: WRITLC - COULD NOT WRITE VALUE FOR ' // CTAG . // ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING' CALL ERRWRT(ERRSTR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') CALL ERRWRT(' ') ENDIF GOTO 100 ENDIF C LOCATE AND WRITE THE LONG CHARACTER STRING WITHIN THIS SUBSET C ------------------------------------------------------------- ITAGCT = 0 MBIT = MBYTE*8 + 16 NBIT = 0 N = 1 CALL USRTPL(LUN,N,N) DO WHILE (N+1.LE.NVAL(LUN)) N = N+1 NODE = INV(N,LUN) MBIT = MBIT+NBIT NBIT = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN)) CALL USRTPL(LUN,N,IVAL) ELSEIF(CTAG.EQ.TAG(NODE)) THEN ITAGCT = ITAGCT + 1 IF(ITAGCT.EQ.IOID) THEN IF(ITP(NODE).NE.3) GOTO 904 NCHR = NBIT/8 IBIT = MBIT DO J=1,NCHR CALL PKC(' ',1,MBAY(1,LUN),IBIT) ENDDO CALL PKC(CHR,NCHR,MBAY(1,LUN),MBIT) CALL USRTPL(LUN,1,1) GOTO 100 ENDIF ENDIF ENDDO GOTO 906 C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 903 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'// . ',")")') STR,NTG CALL BORT(BORT_STR) 904 WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '// . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') TGS(1),TYP(NODE) CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '// . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'// . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN) CALL BORT(BORT_STR) 906 WRITE(BORT_STR,'("BUFRLB: WRITLC - UNABLE TO FIND ",A," IN '// . 'SUBSET")') TGS(1) CALL BORT(BORT_STR) END ./writsa.f0000644001370400056700000001636713465106644011457 0ustar jator2emc SUBROUTINE WRITSA(LUNXX,LMSGT,MSGT,MSGL) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITSA C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C ABS(LUNXX) HAS BEEN OPENED FOR OUTPUT OPERATIONS. C C WHEN LUNXX IS GREATER THAN ZERO, IT PACKS UP THE CURRENT SUBSET C WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE BUFR MESSAGE THAT IS C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNXX). THE DETERMINATION AS C TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO THE MESSAGE IS MADE C VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE LIBRARY SUBROUTINES C WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT THE MESSAGE IS C COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT BE ADDED TO THE C CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO ABS(LUNXX) C AND A NEW ONE IS CREATED IN ORDER TO HOLD THE SUBSET. AS LONG AS C LUNXX IS GREATER THAN ZERO, WRITSA FUNCTIONS EXACTLY LIKE BUFR C ARCHIVE LIBRARY SUBROUTINE WRITSB, EXCEPT THAT WRITSA ALSO RETURNS C A COPY OF EACH COMPLETED BUFR MESSAGE TO THE APPLICATION PROGRAM C IN THE FIRST MSGL WORDS OF ARRAY MSGT. C C ALTERNATIVELY, WHEN LUNXX IS LESS THAN ZERO, THIS IS A SIGNAL TO C FORCE ANY CURRENT MESSAGE IN MEMORY TO BE FLUSHED TO ABS(LUNXX) AND C RETURNED IN ARRAY MSGT. IN SUCH CASES, ANY CURRENT SUBSET IN MEMORY C IS IGNORED. THIS OPTION IS NECESSARY BECAUSE ANY MESSAGE RETURNED C IN MSGT FROM A CALL TO THIS ROUTINE NEVER CONTAINS THE ACTUAL SUBSET C THAT WAS PACKED UP AND STORED DURING THE SAME CALL TO THIS ROUTINE. C THEREFORE, THE ONLY WAY TO ENSURE THAT EVERY LAST BUFR SUBSET IS C RETURNED WITHIN A BUFR MESSAGE IN MSGT BEFORE, E.G., EXITING THE C APPLICATION PROGRAM, IS TO DO ONE FINAL CALL TO THIS ROUTINE WITH C LUNXX LESS THAN ZERO IN ORDER TO FORCIBLY FLUSH OUT AND RETURN ONE C FINAL BUFR MESSAGE. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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-18 J. ATOR -- ADD POST-MSGUPD CHECK FOR AND RETURN OF C MESSAGE WITHIN MSGT IN ORDER TO PREVENT C LOSS OF MESSAGE IN CERTAIN SITUATIONS; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES C 2009-03-23 J. ATOR -- ADDED LMSGT ARGUMENT AND CHECK C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C 2019-05-09 J. ATOR -- ADDED DIMENSIONS FOR MSGLEN AND MSGTXT C C USAGE: CALL WRITSA (LUNXX, LMSGT, MSGT, MSGL) C INPUT ARGUMENT LIST: C LUNXX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE {IF LUNXX IS LESS THAN ZERO, THEN ANY C CURRENT MESSAGE IN MEMORY WILL BE FORCIBLY FLUSHED TO C ABS(LUNXX) AND TO ARRAY MSGT} C LMSGT - INTEGER: DIMENSIONED SIZE (IN INTEGER WORDS) OF MSGT; C USED BY THE SUBROUTINE TO ENSURE THAT IT DOES NOT C OVERFLOW THE MSGT ARRAY C C OUTPUT ARGUMENT LIST: C MSGT - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR C MESSAGE (FIRST MSGL WORDS FILLED) C MSGL - INTEGER: NUMBER OF WORDS FILLED IN MSGT C 0 = no message was returned C C REMARKS: C THIS ROUTINE CALLS: BORT CLOSMG MSGUPD STATUS C WRCMPS WRTREE C THIS ROUTINE IS CALLED BY: None C Normally called only by application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_BUFRMG INCLUDE 'bufrlib.prm' COMMON /MSGCMP/ CCMF CHARACTER*1 CCMF DIMENSION MSGT(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- LUNIT = ABS(LUNXX) C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C IF LUNXX < 0, FORCE MEMORY MSG TO BE WRITTEN (W/O ANY CURRENT SUBSET) C --------------------------------------------------------------------- IF(LUNXX.LT.0) CALL CLOSMG(LUNIT) C IS THERE A COMPLETED BUFR MESSAGE TO BE RETURNED? C ------------------------------------------------- IF(MSGLEN(LUN).GT.0) THEN IF(MSGLEN(LUN).GT.LMSGT) GOTO 904 MSGL = MSGLEN(LUN) DO N=1,MSGL MSGT(N) = MSGTXT(N,LUN) ENDDO MSGLEN(LUN) = 0 ELSE MSGL = 0 ENDIF IF(LUNXX.LT.0) GOTO 100 C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE C ---------------------------------------------- CALL WRTREE(LUN) IF( CCMF.EQ.'Y' ) THEN CALL WRCMPS(LUNIT) ELSE CALL MSGUPD(LUNIT,LUN) ENDIF C IF THE JUST-COMPLETED CALL TO WRCMPS OR MSGUPD FOR THIS SUBSET CAUSED C A PREVIOUS MESSAGE TO BE FLUSHED TO ABS(LUNXX), THEN RETRIEVE AND C RETURN THAT MESSAGE NOW. OTHERWISE, WE RUN THE RISK THAT THE NEXT C CALL TO OPENMB OR OPENMG MIGHT CAUSE A NEWER MESSAGE (WHICH WOULD C CONTAIN THE CURRENT SUBSET!) TO BE FLUSHED AND THUS OVERWRITE THE C PREVIOUS MESSAGE WITHIN ARRAY MSGTXT BEFORE WE HAD THE CHANCE TO C RETRIEVE IT DURING THE NEXT CALL TO WRITSA! C NOTE ALSO THAT, IF THE MOST RECENT CALL TO OPENMB OR OPENMG HAD C CAUSED A MESSAGE TO BE FLUSHED, IT WOULD HAVE DONE SO IN ORDER TO C CREATE A NEW MESSAGE TO HOLD THE CURRENT SUBSET. THUS, IN SUCH C CASES, IT SHOULD NOT BE POSSIBLE THAT THE JUST-COMPLETED CALL TO C WRCMPS OR MSGUPD (FOR THIS SAME SUBSET!) WOULD HAVE ALSO CAUSED A C MESSAGE TO BE FLUSHED, AND THUS IT SHOULD NOT BE POSSIBLE TO HAVE C TWO (2) SEPARATE BUFR MESSAGES RETURNED FROM ONE (1) CALL TO WRITSA! IF(MSGLEN(LUN).GT.0) THEN IF(MSGL.NE.0) GOTO 903 IF(MSGLEN(LUN).GT.LMSGT) GOTO 904 MSGL = MSGLEN(LUN) DO N=1,MSGL MSGT(N) = MSGTXT(N,LUN) ENDDO MSGLEN(LUN) = 0 ENDIF C EXITS C ----- 100 RETURN 900 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') 903 CALL BORT('BUFRLIB: WRITSA - TWO BUFR MESSAGES WERE RETRIEVED '// . 'BY ONE CALL TO THIS ROUTINE') 904 CALL BORT('BUFRLIB: WRITSA - OVERFLOW OF OUTPUT BUFR MESSAGE '// . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') END ./writsb.f0000644001370400056700000000565113440555365011453 0ustar jator2emc SUBROUTINE WRITSB(LUNIT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITSB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT C LUNIT HAS BEEN OPENED FOR OUTPUT OPERATIONS. IT PACKS UP THE C CURRENT SUBSET WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE C BUFR MESSAGE THAT IS CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT. C THE DETERMINATION AS TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO C THE MESSAGE IS MADE VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE C LIBRARY SUBROUTINES WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT C THE MESSAGE IS COMPRESSED. IF IT TURNS OUT THAT THE SUBSET CANNOT C BE ADDED TO THE CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS C FLUSHED TO LUNIT AND A NEW ONE IS CREATED IN ORDER TO HOLD THE C SUBSET. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 C 2005-03-09 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES C C USAGE: CALL WRITSB (LUNIT) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C C REMARKS: C THIS ROUTINE CALLS: BORT MSGUPD STATUS WRCMPS C WRTREE C THIS ROUTINE IS CALLED BY: COPYSB WRITCP C Also called by application programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ COMMON /MSGCMP/ CCMF CHARACTER*1 CCMF C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.EQ.0) GOTO 902 C PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE C ---------------------------------------------- CALL WRTREE(LUN) IF( CCMF.EQ.'Y' ) THEN CALL WRCMPS(LUNIT) ELSE CALL MSGUPD(LUNIT,LUN) ENDIF C EXITS C ----- RETURN 900 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS CLOSED, IT '// . 'MUST BE OPEN FOR OUTPUT') 901 CALL BORT('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS OPEN FOR '// . 'INPUT, IT MUST BE OPEN FOR OUTPUT') 902 CALL BORT('BUFRLIB: WRITSB - A MESSAGE MUST BE OPEN IN OUTPUT '// . 'BUFR FILE, NONE ARE') END ./wrtree.f0000644001370400056700000001174013440555365011445 0ustar jator2emc SUBROUTINE WRTREE(LUN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRTREE C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS C AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- 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 -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); UNIFIED/PORTABLE FOR C WRF; ADDED DOCUMENTATION (INCLUDING C HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))" C WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER C CAUSED PROBLEMS ON SOME FOREIGN MACHINES) C 2004-03-10 J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8 C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER C THAN 8 CHARACTERS; USE FUNCTION IBFMS C 2009-08-03 J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA C UFBCPY USING FILE POINTER STORED IN NEW C COMMON UFBCPL C 2012-03-02 J. ATOR -- USE IPKS TO HANDLE 2-03 OPERATOR CASES C 2012-06-04 J. ATOR -- ENSURE "MISSING" CHARACTER FIELDS ARE C PROPERLY ENCODED WITH ALL BITS SET TO 1 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL WRTREE (LUN) C INPUT ARGUMENT LIST: C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C C REMARKS: C THIS ROUTINE CALLS: IBFMS IPKM PKB PKC C IPKS READLC C THIS ROUTINE IS CALLED BY: WRITSA WRITSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_USRINT USE MODA_IVAL USE MODA_UFBCPL USE MODA_BITBUF USE MODA_TABLES INCLUDE 'bufrlib.prm' CHARACTER*120 LSTR CHARACTER*8 CVAL EQUIVALENCE (CVAL,RVAL) REAL*8 RVAL C----------------------------------------------------------------------- C CONVERT USER NUMBERS INTO SCALED INTEGERS C ----------------------------------------- DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN IVAL(N) = VAL(N,LUN) ELSEIF(TYP(NODE).EQ.'NUM') THEN IF(IBFMS(VAL(N,LUN)).EQ.0) THEN IVAL(N) = IPKS(VAL(N,LUN),NODE) ELSE IVAL(N) = -1 ENDIF ENDIF ENDDO C PACK THE USER ARRAY INTO THE SUBSET BUFFER C ------------------------------------------ IBIT = 16 DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).LT.3) THEN C The value to be packed is numeric. CALL PKB(IVAL(N),IBT(NODE),IBAY,IBIT) ELSE C The value to be packed is a character string. NCR=IBT(NODE)/8 IF ( NCR.GT.8 .AND. LUNCPY(LUN).NE.0 ) THEN C The string is longer than 8 characters and there was a C preceeding call to UFBCPY involving this output unit, so C read the long string with READLC and write it into the C output buffer using PKC. CALL READLC(LUNCPY(LUN),LSTR,TAG(NODE)) CALL PKC(LSTR,NCR,IBAY,IBIT) ELSE RVAL = VAL(N,LUN) IF(IBFMS(RVAL).NE.0) THEN C The value is "missing", so set all bits to 1 before C packing the field as a character string. NUMCHR = MIN(NCR,LEN(LSTR)) DO JJ = 1, NUMCHR CALL IPKM(LSTR(JJ:JJ),1,255) ENDDO CALL PKC(LSTR,NUMCHR,IBAY,IBIT) ELSE C The value is not "missing", so pack the equivalenced C character string. Note that a maximum of 8 characters C will be packed here, so a separate subsequent call to C BUFR archive library subroutine WRITLC will be needed to C fully encode any string longer than 8 characters. CALL PKC(CVAL,NCR,IBAY,IBIT) ENDIF ENDIF ENDIF ENDDO C RESET UFBCPY FILE POINTER C ------------------------- LUNCPY(LUN)=0 RETURN END ./wtstat.f0000644001370400056700000001123713440555365011464 0ustar jator2emc SUBROUTINE WTSTAT(LUNIT,LUN,IL,IM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WTSTAT C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE EITHER DISCONNECTS THE INPUT LOGICAL UNIT C NUMBER LUNIT (AND ITS ASSOCIATED BUFR FILE) FROM THE BUFR ARCHIVE C LIBRARY SOFTWARE OR IT CONNECTS IT AS EITHER AN INPUT OR OUPUT FILE C AND DEFINES A BUFR MESSAGE AS BEING EITHER OPENED OR CLOSED IN C MEMORY FOR THE BUFR FILE IN LUNIT. THIS INFORMATION IS STORED IN C THE INTERNAL ARRAYS IOLUN AND IOMSG IN MODULE STBFR. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" 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 -- CORRECTED A "TYPO" IN TEST FOR VALID VALUE C FOR "IM"; 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 C 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS C C USAGE: CALL WTSTAT (LUNIT, LUN, IL, IM) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C LUN - INTEGER: I/O STREAM INDEX ASSOCIATED WITH LOGICAL UNIT C LUNIT C IL - INTEGER: LOGICAL UNIT STATUS INDICATOR: C 0 = disconnect LUNIT w.r.t. BUFR Archive C Library software (all information C associated with LUNIT is deleted from C within internal arrays) C 1 = connect LUNIT as an output file w.r.t. to C BUFR Archive Library software C -1 = connect LUNIT as an input file w.r.t. to C BUFR Archive Library software C IM - INTEGER: DEFINES WHETHER THERE IS A BUFR MESSAGE C CURRENTLY OPEN WITHIN MEMORY FOR THIS LUNIT (IF IT IS C CONNECTED, I.E., IL .NE. ZERO): C 0 = no C 1 = yes C C REMARKS: C THIS ROUTINE CALLS: BORT C THIS ROUTINE IS CALLED BY: CLOSBF CLOSMG OPENBF OPENMB C OPENMG RDMEMM READERME REWNBF C READMG C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ USE MODA_STBFR INCLUDE 'bufrlib.prm' CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK ON THE ARGUMENTS C ---------------------- IF(LUNIT.LE.0) GOTO 900 IF(LUN .LE.0) GOTO 901 IF(IL.LT.-1 .OR. IL.GT.1) GOTO 902 IF(IM.LT. 0 .OR. IM.GT.1) GOTO 903 C CHECK ON LUNIT-LUN COMBINATION C ------------------------------ IF(ABS(IOLUN(LUN)).NE.LUNIT) THEN IF(IOLUN(LUN).NE.0) GOTO 905 ENDIF C RESET THE FILE STATUSES C ----------------------- IF(IL.NE.0) THEN IOLUN(LUN) = SIGN(LUNIT,IL) IOMSG(LUN) = IM ELSE IOLUN(LUN) = 0 IOMSG(LUN) = 0 ENDIF C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED '// . ' INTO FIRST ARGUMENT (INPUT) (=",I3,")")') LUNIT CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID I/O STREAM INDEX '// . 'PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') LUN CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS'// . ' INDICATOR PASSED INTO THIRD ARGUMENT (INPUT) (=",I4,")")') IL CALL BORT(BORT_STR) 903 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS'// . ' INDICATOR PASSED INTO FOURTH ARGUMENT (INPUT) (=",I4,")")') IM CALL BORT(BORT_STR) 905 WRITE(BORT_STR,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE '// . 'EXISTING FILE UNIT (LOGICAL UNIT NUMBER ",I3,")")') IOLUN(LUN) CALL BORT(BORT_STR) END ./getdefflags_F.sh0000755001370400056700000000265213475252466013053 0ustar jator2emc#!/bin/sh #------------------------------------------------------------------------------- # Determine the byte-ordering scheme used by the local machine. cat > endiantest.c << ENDIANTEST #include #define Order(x)\ fill((char *)&x, sizeof(x)); \ for (i=1; i<=sizeof(x); i++) { \ c=((x>>(byte_size*(sizeof(x)-i)))&mask); \ putchar(c==0 ? '?' : (char)c); \ } \ printf("\n"); void fill(p, size) char *p; int size; { char *ab= "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; int i; for (i=0; i