From f5dd41c6e9a388a5063462d227f1c8f014f057ab Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Fri, 3 Feb 2023 20:33:22 -0700 Subject: [PATCH 1/2] changed all tabs to spaces --- src/adn30.f | 2 +- src/arallocc.c | 30 +- src/arallocf.f | 736 +++++++++++++++++++++--------------------- src/ardllocf.f | 394 +++++++++++----------- src/atrcpt.f | 86 ++--- src/bfrini.f90.in | 40 +-- src/blocks.f | 16 +- src/bufr_interface.h | 68 ++-- src/bufrlib.h.in | 16 +- src/bvers.f.in | 14 +- src/cadn30.f | 12 +- src/ccbfl.c | 2 +- src/chrtrna.f | 4 +- src/cktaba.f | 22 +- src/closmg.f | 2 +- src/cmpia.c | 10 +- src/cmpmsg.f | 2 +- src/cmpstia1.c | 38 +-- src/cmpstia2.c | 18 +- src/cnved4.f | 148 ++++----- src/cobfl.c | 36 +-- src/codflg.f | 2 +- src/conwin.f | 14 +- src/copybf.f | 10 +- src/copymg.f | 2 +- src/cpdxmm.f | 126 ++++---- src/cpmstabs.c | 75 +++-- src/cpyupd.f | 4 +- src/crbmg.c | 88 ++--- src/cread.c | 4 +- src/cread.h | 2 +- src/cwbmg.c | 6 +- src/datelen.f | 4 +- src/dlloctbf.c | 4 +- src/drfini.f | 2 +- src/dumpbf.f | 4 +- src/dxdump.f | 46 +-- src/dxinit.f | 2 +- src/dxmini.f | 2 +- src/elemdx.f | 2 +- src/exitbufr.f | 54 ++-- src/fortran_close.f90 | 2 +- src/fortran_open.f90 | 2 +- src/fstag.f | 60 ++-- src/getabdb.f | 2 +- src/getcfmng.f | 248 +++++++------- src/getlens.f | 80 ++--- src/getntbe.f | 42 +-- src/gets1loc.f | 268 +++++++-------- src/gettagpr.f | 54 ++-- src/gettagre.f | 80 ++--- src/gettbh.f | 78 ++--- src/getvalnb.f | 72 ++--- src/getwin.f | 2 +- src/ibfms.f | 18 +- src/icbfms.f | 102 +++--- src/ichkstr.f | 34 +- src/icmpdx.f | 24 +- src/icopysb.f | 14 +- src/icvidx.c | 2 +- src/idxmsg.f | 40 +-- src/ifxy.f | 2 +- src/igetdate.f | 50 +-- src/igetfxy.f | 62 ++-- src/igetntbi.f | 38 +-- src/igetntbl.f | 24 +- src/igetprm.f | 170 +++++----- src/igetrfel.f | 414 ++++++++++++------------ src/igettdi.f | 44 +-- src/imrkopr.f | 8 +- src/inctab.f | 2 +- src/inittbf.c | 4 +- src/invcon.f | 4 +- src/invtag.f | 2 +- src/invwin.f | 2 +- src/iok2cpy.f | 6 +- src/iokoper.f | 18 +- src/ipks.f | 68 ++-- src/ireadmt.f | 326 +++++++++---------- src/ireadns.f | 2 +- src/ireadsb.f | 6 +- src/irev.F | 4 +- src/isetprm.f | 194 +++++------ src/ishrdx.f | 24 +- src/isize.f | 26 +- src/istdesc.f | 36 +-- src/iupbs01.f | 114 +++---- src/lcmgdf.f | 4 +- src/lstjpb.f | 6 +- src/makestab.f | 18 +- src/mesgbc.f | 6 +- src/mesgbf.f | 4 +- src/moda_bitbuf.F | 14 +- src/moda_bitmaps.F | 30 +- src/moda_bufrmg.F | 8 +- src/moda_bufrsr.F | 28 +- src/moda_comprs.F | 12 +- src/moda_comprx.F | 28 +- src/moda_dscach.F | 16 +- src/moda_h4wlc.F | 14 +- src/moda_idrdm.F | 6 +- src/moda_ival.F | 6 +- src/moda_ivttmp.F | 8 +- src/moda_lushr.F | 6 +- src/moda_mgwa.F | 6 +- src/moda_mgwb.F | 6 +- src/moda_msgcwd.F | 14 +- src/moda_msglim.F | 6 +- src/moda_msgmem.F | 34 +- src/moda_mstabs.F | 32 +- src/moda_nmikrp.F | 10 +- src/moda_nrv203.F | 22 +- src/moda_nulbfr.F | 6 +- src/moda_rdmtb.F | 12 +- src/moda_rlccmn.F | 12 +- src/moda_s01cm.F | 10 +- src/moda_sc3bfr.F | 8 +- src/moda_stbfr.F | 8 +- src/moda_stcode.F | 6 +- src/moda_tababd.F | 24 +- src/moda_tables.F | 40 +-- src/moda_ufbcpl.F | 6 +- src/moda_unptyp.F | 6 +- src/moda_usrbit.F | 8 +- src/moda_usrint.F | 12 +- src/moda_usrtmp.F | 4 +- src/moda_xtab.F | 6 +- src/modv_MAXJL.f | 6 +- src/modv_MAXMEM.f | 6 +- src/modv_MAXMSG.f | 6 +- src/modv_MAXNC.f90 | 2 +- src/modv_MAXSS.f | 6 +- src/modv_MAXTBA.f | 6 +- src/modv_MAXTBB.f | 6 +- src/modv_MAXTBD.f | 6 +- src/modv_MXBTM.f | 6 +- src/modv_MXBTMSE.f | 6 +- src/modv_MXCDV.f | 6 +- src/modv_MXCSB.f | 8 +- src/modv_MXDXTS.f | 6 +- src/modv_MXLCC.f | 6 +- src/modv_MXMSGL.f | 12 +- src/modv_MXMTBB.f | 6 +- src/modv_MXMTBD.f | 6 +- src/modv_MXMTBF.f | 6 +- src/modv_MXNRV.f | 6 +- src/modv_MXRST.f | 6 +- src/modv_MXS01V.f | 6 +- src/modv_MXTAMC.f | 6 +- src/modv_MXTCO.f | 6 +- src/modv_NFILES.f90 | 2 +- src/msgfull.f | 6 +- src/msgini.f | 2 +- src/msgupd.f | 2 +- src/msgwrt.f | 2 +- src/mstabs.h | 56 ++-- src/mtfnam.f | 144 ++++----- src/mtinfo.f | 4 +- src/mvb.f | 4 +- src/nemdefs.f | 60 ++-- src/nemspecs.f | 118 +++---- src/newwin.f | 4 +- src/nmwrd.f | 40 +-- src/numbck.f | 2 +- src/nummtb.c | 42 +-- src/numtbd.f | 2 +- src/nvnwin.f | 4 +- src/nwords.f | 2 +- src/nxtwin.f | 4 +- src/openbf.f | 8 +- src/pad.f | 4 +- src/padmsg.f | 34 +- src/parstr.f | 2 +- src/parusr.f | 2 +- src/parutg.f | 8 +- src/pkb8.f | 2 +- src/pkbs1.f | 82 ++--- src/pktdd.f | 2 +- src/posapx.f | 20 +- src/rbytes.c | 6 +- src/rcstpl.f | 4 +- src/rdbfdx.f | 100 +++--- src/rdcmps.f | 4 +- src/rdmemm.f | 64 ++-- src/rdmsgw.f | 4 +- src/rdmtbb.f | 116 +++---- src/rdmtbd.f | 112 +++---- src/rdmtbf.f | 88 ++--- src/rdtree.f | 10 +- src/rdusdx.f | 18 +- src/readdx.f | 4 +- src/readerme.f | 58 ++-- src/readmg.f | 4 +- src/reads3.f | 234 +++++++------- src/readsb.f | 4 +- src/restd.c | 110 +++---- src/rewnbf.f | 6 +- src/rsvfvm.f | 4 +- src/rtrcpt.f | 6 +- src/rtrcptb.f | 6 +- src/seqsdx.f | 2 +- src/setblock.f | 8 +- src/setbmiss.f | 2 +- src/setvalnb.f | 78 ++--- src/sntbbe.f | 184 +++++------ src/sntbde.f | 200 ++++++------ src/sntbfe.f | 248 +++++++------- src/sorttbf.c | 4 +- src/srchtbf.c | 172 +++++----- src/status.f | 2 +- src/stbfdx.f | 2 +- src/stdmsg.f | 6 +- src/stndrd.f | 6 +- src/stntbi.f | 18 +- src/stntbia.f | 66 ++-- src/strbtm.f | 62 ++-- src/strcpt.f | 14 +- src/string.f | 2 +- src/strtbfe.c | 2 +- src/stseq.c | 554 +++++++++++++++---------------- src/tabent.f | 2 +- src/tabsub.f | 6 +- src/trybump.f | 2 +- src/ufbcup.f | 4 +- src/ufbdmp.f | 4 +- src/ufbevn.f | 8 +- src/ufbget.f | 4 +- src/ufbint.f | 4 +- src/ufbinx.f | 4 +- src/ufbmem.f | 20 +- src/ufbmex.f | 6 +- src/ufbovr.f | 4 +- src/ufbpos.f | 6 +- src/ufbrp.f | 2 +- src/ufbrw.f | 2 +- src/ufbsp.f | 4 +- src/ufbtab.f | 8 +- src/ufdump.f | 16 +- src/upc.f | 6 +- src/upds3.f | 10 +- src/upftbv.f | 8 +- src/ups.f | 68 ++-- src/uptdd.f | 6 +- src/valx.f | 12 +- src/wrcmps.f | 158 ++++----- src/wrdesc.c | 10 +- src/wrdxtb.f | 10 +- src/writcp.f | 4 +- src/writdx.f | 18 +- src/writlc.f | 30 +- src/writsa.f | 4 +- src/writsb.f | 16 +- src/wrtree.f | 40 +-- src/wtstat.f | 14 +- src/x48.F | 2 +- src/x84.F | 4 +- 256 files changed, 4730 insertions(+), 4731 deletions(-) diff --git a/src/adn30.f b/src/adn30.f index b7b32e4f..042f7ca6 100644 --- a/src/adn30.f +++ b/src/adn30.f @@ -24,7 +24,7 @@ C> | 1998-07-08 | J. Woollen | Replaced call to CRAY library routine "ABORT" with call to new internal BUFRLIB routine bort() | C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies | C> | 2003-11-04 | D. Keyser | Unified/portable for WRF; added history documentation | - + FUNCTION ADN30(IDN,L30) COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) diff --git a/src/arallocc.c b/src/arallocc.c index fc743940..83037c7b 100644 --- a/src/arallocc.c +++ b/src/arallocc.c @@ -2,7 +2,7 @@ * @brief Dynamically allocate C language arrays within internal memory. * * ### Program History Log - * Date | Programmer | Comments + * Date | Programmer | Comments * -----|------------|---------- * 2014-12-04 | J. Ator | Original author. * 2021-05-17 | J. Ator | Allow up to 24 characters in cbunit. @@ -54,12 +54,12 @@ void arallocc( void ) nfiles = igetprm( "NFILES", 6 ); if ( ( pb = malloc( (nfiles+1) * sizeof(FILE *) ) ) == NULL ) { - strcat( brtstr, "PB" ); + strcat( brtstr, "PB" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( lstpos = malloc( (nfiles+1) * sizeof(fpos_t) ) ) == NULL ) { - strcat( brtstr, "LSTPOS" ); + strcat( brtstr, "LSTPOS" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } @@ -72,62 +72,62 @@ void arallocc( void ) maxcd = igetprm( "MAXCD", 5 ); if ( ( ibfxyn_c = malloc( mxmtbb * sizeof(f77int) ) ) == NULL ) { - strcat( brtstr, "IBFXYN" ); + strcat( brtstr, "IBFXYN" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbscl_c = malloc( mxmtbb * 4 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBSCL" ); + strcat( brtstr, "CBSCL" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbsref_c = malloc( mxmtbb * 12 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBSREF" ); + strcat( brtstr, "CBSREF" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbbw_c = malloc( mxmtbb * 4 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBBW" ); + strcat( brtstr, "CBBW" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbunit_c = malloc( mxmtbb * 24 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBUNIT" ); + strcat( brtstr, "CBUNIT" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbmnem_c = malloc( mxmtbb * 8 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBMNEM" ); + strcat( brtstr, "CBMNEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cbelem_c = malloc( mxmtbb * 120 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CBELEM" ); + strcat( brtstr, "CBELEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( idfxyn_c = malloc( mxmtbd * sizeof(f77int) ) ) == NULL ) { - strcat( brtstr, "IDFXYN" ); + strcat( brtstr, "IDFXYN" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cdseq_c = malloc( mxmtbd * 120 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CDSEQ" ); + strcat( brtstr, "CDSEQ" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( cdmnem_c = malloc( mxmtbd * 8 * sizeof(char) ) ) == NULL ) { - strcat( brtstr, "CDMNEM" ); + strcat( brtstr, "CDMNEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( ndelem_c = malloc( mxmtbd * sizeof(f77int) ) ) == NULL ) { - strcat( brtstr, "NDELEM" ); + strcat( brtstr, "NDELEM" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } if ( ( idefxy_c = malloc( mxmtbd * maxcd * sizeof(f77int) ) ) == NULL ) { - strcat( brtstr, "IDEFXY" ); + strcat( brtstr, "IDEFXY" ); bort( brtstr, ( f77int ) strlen( brtstr ) ); } diff --git a/src/arallocf.f b/src/arallocf.f index 9c156396..3e9bb2ad 100644 --- a/src/arallocf.f +++ b/src/arallocf.f @@ -1,7 +1,7 @@ C> @file C> @brief Dynamically allocate Fortran language arrays within internal C> memory. - + C> This subroutine is called internally during the first call to C> subroutine openbf() from an application program, in order to C> dynamically allocate internal Fortran language arrays based on @@ -32,7 +32,7 @@ C> | 2021-05-17 | J. Ator | Allow up to 24 characters in cbunit | C> | 2022-06-24 | J. Ator | Remove MODV references from MODA files and include explicitly where needed | C> - SUBROUTINE ARALLOCF + SUBROUTINE ARALLOCF USE MODV_MAXCD USE MODV_MAXJL @@ -58,528 +58,528 @@ SUBROUTINE ARALLOCF USE MODV_MXTCO USE MODV_NFILES - 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 - - CHARACTER*80 ERRSTR - CHARACTER*36 BRTSTR - - COMMON /QUIET/ IPRT + 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 + + 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 + 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 ' + BRTSTR = 'BUFRLIB: ARALLOCF FAILED ALLOCATING ' -C MODA_USRINT arrays. +C MODA_USRINT arrays. - ALLOCATE( NVAL(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NVAL' ) + 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( 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( 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' ) + ALLOCATE( VAL(MAXSS,NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VAL' ) -C MODA_USRBIT arrays. +C MODA_USRBIT arrays. - ALLOCATE( NBIT(MAXSS), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NBIT' ) + 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' ) + ALLOCATE( MBIT(MAXSS), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MBIT' ) -C MODA_IVAL arrays. +C MODA_IVAL arrays. - ALLOCATE( IVAL(MAXSS), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IVAL' ) + ALLOCATE( IVAL(MAXSS), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IVAL' ) -C MODA_MSGCWD arrays. +C MODA_MSGCWD arrays. - ALLOCATE( NMSG(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NMSG' ) + 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( 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( 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( 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' ) + ALLOCATE( IDATE(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDATE' ) -C MODA_STBFR arrays. +C MODA_STBFR arrays. - ALLOCATE( IOLUN(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IOLUN' ) + 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' ) + ALLOCATE( IOMSG(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IOMSG' ) -C MODA_UFBCPL arrays. +C MODA_UFBCPL arrays. - ALLOCATE( LUNCPY(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUNCPY' ) + ALLOCATE( LUNCPY(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUNCPY' ) -C MODA_SC3BFR arrays. +C MODA_SC3BFR arrays. - ALLOCATE( ISC3(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISC3' ) + 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' ) + ALLOCATE( TAMNEM(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAMNEM' ) -C MODA_UNPTYP arrays. +C MODA_UNPTYP arrays. - ALLOCATE( MSGUNP(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGUNP' ) + ALLOCATE( MSGUNP(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGUNP' ) -C MODA_LUSHR arrays. +C MODA_LUSHR arrays. - ALLOCATE( LUS(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUS' ) + ALLOCATE( LUS(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'LUS' ) -C MODA_NULBFR arrays. +C MODA_NULBFR arrays. - ALLOCATE( NULL(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NULL' ) + ALLOCATE( NULL(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NULL' ) -C MODA_STCODE arrays. +C MODA_STCODE arrays. - ALLOCATE( ISCODES(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISCODES' ) + ALLOCATE( ISCODES(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'ISCODES' ) -C MODA_IDRDM arrays. +C MODA_IDRDM arrays. - ALLOCATE( IDRDM(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDRDM' ) + ALLOCATE( IDRDM(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDRDM' ) -C MODA_XTAB arrays. +C MODA_XTAB arrays. - ALLOCATE( XTAB(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'XTAB' ) + ALLOCATE( XTAB(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'XTAB' ) -C MODA_MSGLIM arrays. +C MODA_MSGLIM arrays. - ALLOCATE( MSGLIM(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGLIM' ) + ALLOCATE( MSGLIM(NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGLIM' ) -C Calculate MXMSGLD4 from MXMSGL. +C Calculate MXMSGLD4 from MXMSGL. - IF ( MOD(MXMSGL,4) .eq. 0 ) THEN - MXMSGLD4 = MXMSGL/4 - ELSE - MXMSGLD4 = MXMSGL/4 + 1 - END IF + IF ( MOD(MXMSGL,4) .eq. 0 ) THEN + MXMSGLD4 = MXMSGL/4 + ELSE + MXMSGLD4 = MXMSGL/4 + 1 + END IF -C MODA_BITBUF arrays. +C MODA_BITBUF arrays. - ALLOCATE( IBAY(MXMSGLD4), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBAY' ) + 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( 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' ) + ALLOCATE( MBAY(MXMSGLD4,NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MBAY' ) -C MODA_MGWA arrays. +C MODA_MGWA arrays. - ALLOCATE( MGWA(MXMSGLD4), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWA' ) + ALLOCATE( MGWA(MXMSGLD4), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWA' ) -C MODA_MGWB arrays. +C MODA_MGWB arrays. - ALLOCATE( MGWB(MXMSGLD4), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWB' ) + ALLOCATE( MGWB(MXMSGLD4), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MGWB' ) -C MODA_BUFRMG arrays. +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' ) + 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. +C MODA_BUFRSR arrays. - ALLOCATE( JSR(NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JSR' ) + 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' ) + ALLOCATE( JBAY(MXMSGLD4), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JBAY' ) -C Calculate MXDXM and MXDXW from MXDXTS and MXMSGLD4. +C Calculate MXDXM and MXDXW from MXDXTS and MXMSGLD4. MXDXM = MXDXTS*3 MXDXW = MXDXM*MXMSGLD4 -C MODA_MSGMEM arrays. +C MODA_MSGMEM arrays. - ALLOCATE( MSGP(0:MAXMSG), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MSGP' ) + 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( 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( 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( 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( 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( 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' ) + ALLOCATE( IPMSGS(MXDXTS), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IPMSGS' ) -C MODA_TABABD arrays. +C MODA_TABABD arrays. - ALLOCATE( NTBA(0:NFILES), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NTBA' ) + 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( 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( 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( 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( 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( 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( 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( 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( 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' ) + ALLOCATE( TABD(MAXTBD,NFILES), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TABD' ) -C MODA_TABLES arrays. +C MODA_TABLES arrays. - ALLOCATE( TAG(MAXJL), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAG' ) + 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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( 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' ) + ALLOCATE( JSEQ(MAXJL), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'JSEQ' ) -C MODA_USRTMP arrays. +C MODA_USRTMP arrays. - ALLOCATE( IUTMP(MAXJL,MAXRCR), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IUTMP' ) + 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' ) + ALLOCATE( VUTMP(MAXJL,MAXRCR), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VUTMP' ) -C MODA_IVTTMP arrays. +C MODA_IVTTMP arrays. - ALLOCATE( TTMP(MAXJL), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TTMP' ) + 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( 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' ) + ALLOCATE( VTMP(MAXJL), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'VTMP' ) -C MODA_COMPRX arrays. +C MODA_COMPRX arrays. - ALLOCATE( KMIN(MXCDV), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KMIN' ) + 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( 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( 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( 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( 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( 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' ) + ALLOCATE( CHARACTER*(MXLCC) :: CSTR(MXCDV), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CSTR' ) -C MODA_COMPRS arrays. +C MODA_COMPRS arrays. - ALLOCATE( MATX(MXCDV,MXCSB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'MATX' ) + 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' ) + ALLOCATE( CHARACTER*(MXLCC) :: CATX(MXCDV,MXCSB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CATX' ) -C MODA_MSTABS arrays. +C MODA_MSTABS arrays. - ALLOCATE( IBFXYN(MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBFXYN' ) + ALLOCATE( IBFXYN(MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBFXYN' ) - ALLOCATE( CBSCL(4,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSCL' ) + ALLOCATE( CBSCL(4,MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSCL' ) - ALLOCATE( CBSREF(12,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSREF' ) + ALLOCATE( CBSREF(12,MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBSREF' ) - ALLOCATE( CBBW(4,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBBW' ) + ALLOCATE( CBBW(4,MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBBW' ) - ALLOCATE( CBUNIT(24,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBUNIT' ) + ALLOCATE( CBUNIT(24,MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBUNIT' ) - ALLOCATE( CBMNEM(8,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBMNEM' ) + ALLOCATE( CBMNEM(8,MXMTBB), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBMNEM' ) - ALLOCATE( CBELEM(120,MXMTBB), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CBELEM' ) + ALLOCATE( CBELEM(120,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( IDFXYN(MXMTBD), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDFXYN' ) - ALLOCATE( CDSEQ(120,MXMTBD), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CDSEQ' ) + ALLOCATE( CDSEQ(120,MXMTBD), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CDSEQ' ) - ALLOCATE( CDMNEM(8,MXMTBD), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CDMNEM' ) + ALLOCATE( CDMNEM(8,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( 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' ) + ALLOCATE( IDEFXY(MXMTBD*MAXCD), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IDEFXY' ) -C MODA_RDMTB arrays. +C MODA_RDMTB arrays. - ALLOCATE( IEFXYN(MXMTBD,MAXCD), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IEFXYN' ) + 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( 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( 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' ) + ALLOCATE( CEELEM(MXMTBD,MAXCD), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CEELEM' ) -C MODA_NMIKRP arrays. +C MODA_NMIKRP arrays. - ALLOCATE( NEM(MAXCD,10), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'NEM' ) + 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( 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' ) + ALLOCATE( KRP(MAXCD,10), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'KRP' ) -C MODA_S01CM arrays. +C MODA_S01CM arrays. - ALLOCATE( IVMNEM(MXS01V), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IVMNEM' ) + 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' ) + ALLOCATE( CMNEM(MXS01V), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CMNEM' ) -C MODA_BITMAPS arrays. +C MODA_BITMAPS arrays. - ALLOCATE( INODTAMC(MXTAMC), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'INODTAMC' ) + 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( 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( 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( 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( 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( 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( 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' ) + ALLOCATE( IBTMSE(MXBTM,MXBTMSE), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IBTMSE' ) -C MODA_NRV203 arrays. +C MODA_NRV203 arrays. - ALLOCATE( TAGNRV(MXNRV), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'TAGNRV' ) + 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( 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( 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( 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' ) + ALLOCATE( IENRV(MXNRV), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IENRV' ) -C MODA_RLCCMN arrays. +C MODA_RLCCMN arrays. - ALLOCATE( IRNCH(MXRST), STAT=iost ) - IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'IRNCH' ) + 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( 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' ) + ALLOCATE( CRTAG(MXRST), STAT=iost ) + IF ( iost .ne. 0 ) CALL BORT( BRTSTR // 'CRTAG' ) - RETURN - END + RETURN + END diff --git a/src/ardllocf.f b/src/ardllocf.f index 5eb64753..c52c6ecf 100644 --- a/src/ardllocf.f +++ b/src/ardllocf.f @@ -3,9 +3,9 @@ C> Fortran language arrays. C> C> ### Program History -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- -C> 2014-12-04 | J. Ator | Original author +C> 2014-12-04 | J. Ator | Original author C> C> @author J. Ator @date 2014-12-04 @@ -13,262 +13,262 @@ C> during a previous call to subroutine arallocf(). C> C> @author J. Ator @date 2014-12-04 - SUBROUTINE ARDLLOCF - - 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 + SUBROUTINE ARDLLOCF + + 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. +C MODA_USRINT arrays. - DEALLOCATE( NVAL ) - DEALLOCATE( INV ) - DEALLOCATE( NRFELM ) - DEALLOCATE( VAL ) + DEALLOCATE( NVAL ) + DEALLOCATE( INV ) + DEALLOCATE( NRFELM ) + DEALLOCATE( VAL ) -C MODA_USRBIT arrays. +C MODA_USRBIT arrays. - DEALLOCATE( NBIT ) - DEALLOCATE( MBIT ) + DEALLOCATE( NBIT ) + DEALLOCATE( MBIT ) -C MODA_IVAL arrays. +C MODA_IVAL arrays. - DEALLOCATE( IVAL ) + DEALLOCATE( IVAL ) -C MODA_MSGCWD arrays. +C MODA_MSGCWD arrays. - DEALLOCATE( NMSG ) - DEALLOCATE( NSUB ) - DEALLOCATE( MSUB ) - DEALLOCATE( INODE ) - DEALLOCATE( IDATE ) + DEALLOCATE( NMSG ) + DEALLOCATE( NSUB ) + DEALLOCATE( MSUB ) + DEALLOCATE( INODE ) + DEALLOCATE( IDATE ) -C MODA_STBFR arrays. +C MODA_STBFR arrays. - DEALLOCATE( IOLUN ) - DEALLOCATE( IOMSG ) + DEALLOCATE( IOLUN ) + DEALLOCATE( IOMSG ) -C MODA_UFBCPL arrays. +C MODA_UFBCPL arrays. - DEALLOCATE( LUNCPY ) + DEALLOCATE( LUNCPY ) -C MODA_SC3BFR arrays. +C MODA_SC3BFR arrays. - DEALLOCATE( ISC3 ) - DEALLOCATE( TAMNEM ) + DEALLOCATE( ISC3 ) + DEALLOCATE( TAMNEM ) -C MODA_UNPTYP arrays. +C MODA_UNPTYP arrays. - DEALLOCATE( MSGUNP ) + DEALLOCATE( MSGUNP ) -C MODA_LUSHR arrays. +C MODA_LUSHR arrays. - DEALLOCATE( LUS ) + DEALLOCATE( LUS ) -C MODA_NULBFR arrays. +C MODA_NULBFR arrays. - DEALLOCATE( NULL ) + DEALLOCATE( NULL ) -C MODA_STCODE arrays. +C MODA_STCODE arrays. - DEALLOCATE( ISCODES ) + DEALLOCATE( ISCODES ) -C MODA_IDRDM arrays. +C MODA_IDRDM arrays. - DEALLOCATE( IDRDM ) + DEALLOCATE( IDRDM ) -C MODA_XTAB arrays. +C MODA_XTAB arrays. - DEALLOCATE( XTAB ) + DEALLOCATE( XTAB ) -C MODA_MSGLIM arrays. +C MODA_MSGLIM arrays. - DEALLOCATE( MSGLIM ) + DEALLOCATE( MSGLIM ) -C MODA_BITBUF arrays. +C MODA_BITBUF arrays. - DEALLOCATE( IBAY ) - DEALLOCATE( MBYT ) - DEALLOCATE( MBAY ) + DEALLOCATE( IBAY ) + DEALLOCATE( MBYT ) + DEALLOCATE( MBAY ) -C MODA_MGWA arrays. +C MODA_MGWA arrays. - DEALLOCATE( MGWA ) + DEALLOCATE( MGWA ) -C MODA_MGWB arrays. +C MODA_MGWB arrays. - DEALLOCATE( MGWB ) + DEALLOCATE( MGWB ) -C MODA_BUFRMG arrays. +C MODA_BUFRMG arrays. - DEALLOCATE( MSGLEN ) - DEALLOCATE( MSGTXT ) + DEALLOCATE( MSGLEN ) + DEALLOCATE( MSGTXT ) -C MODA_BUFRSR arrays. +C MODA_BUFRSR arrays. - DEALLOCATE( JSR ) - DEALLOCATE( JBAY ) + DEALLOCATE( JSR ) + DEALLOCATE( JBAY ) -C MODA_MSGMEM arrays. +C MODA_MSGMEM arrays. - DEALLOCATE( MSGP ) - DEALLOCATE( MSGS ) - DEALLOCATE( MDX ) - DEALLOCATE( IPDXM ) - DEALLOCATE( IFDXTS ) - DEALLOCATE( ICDXTS ) - DEALLOCATE( IPMSGS ) + DEALLOCATE( MSGP ) + DEALLOCATE( MSGS ) + DEALLOCATE( MDX ) + DEALLOCATE( IPDXM ) + DEALLOCATE( IFDXTS ) + DEALLOCATE( ICDXTS ) + DEALLOCATE( IPMSGS ) -C MODA_TABABD arrays. +C MODA_TABABD arrays. - DEALLOCATE( NTBA ) - DEALLOCATE( NTBB ) - DEALLOCATE( NTBD ) - DEALLOCATE( MTAB ) - DEALLOCATE( IDNA ) - DEALLOCATE( IDNB ) - DEALLOCATE( IDND ) - DEALLOCATE( TABA ) - DEALLOCATE( TABB ) - DEALLOCATE( TABD ) + DEALLOCATE( NTBA ) + DEALLOCATE( NTBB ) + DEALLOCATE( NTBD ) + DEALLOCATE( MTAB ) + DEALLOCATE( IDNA ) + DEALLOCATE( IDNB ) + DEALLOCATE( IDND ) + DEALLOCATE( TABA ) + DEALLOCATE( TABB ) + DEALLOCATE( TABD ) -C MODA_TABLES arrays. +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 ) + 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. +C MODA_USRTMP arrays. - DEALLOCATE( IUTMP ) - DEALLOCATE( VUTMP ) + DEALLOCATE( IUTMP ) + DEALLOCATE( VUTMP ) -C MODA_IVTTMP arrays. +C MODA_IVTTMP arrays. - DEALLOCATE( TTMP ) - DEALLOCATE( ITMP ) - DEALLOCATE( VTMP ) + DEALLOCATE( TTMP ) + DEALLOCATE( ITMP ) + DEALLOCATE( VTMP ) -C MODA_COMPRX arrays. +C MODA_COMPRX arrays. - DEALLOCATE( KMIN ) - DEALLOCATE( KMAX ) - DEALLOCATE( KMIS ) - DEALLOCATE( KBIT ) - DEALLOCATE( ITYP ) - DEALLOCATE( IWID ) - DEALLOCATE( CSTR ) + DEALLOCATE( KMIN ) + DEALLOCATE( KMAX ) + DEALLOCATE( KMIS ) + DEALLOCATE( KBIT ) + DEALLOCATE( ITYP ) + DEALLOCATE( IWID ) + DEALLOCATE( CSTR ) -C MODA_COMPRS arrays. +C MODA_COMPRS arrays. - DEALLOCATE( MATX ) - DEALLOCATE( CATX ) + DEALLOCATE( MATX ) + DEALLOCATE( CATX ) -C MODA_MSTABS arrays. +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 ) + 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. +C MODA_RDMTB arrays. - DEALLOCATE( IEFXYN ) - DEALLOCATE( CMDSCB ) - DEALLOCATE( CMDSCD ) - DEALLOCATE( CEELEM ) + DEALLOCATE( IEFXYN ) + DEALLOCATE( CMDSCB ) + DEALLOCATE( CMDSCD ) + DEALLOCATE( CEELEM ) -C MODA_NMIKRP arrays. +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( 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 ) + DEALLOCATE( IRNCH ) + DEALLOCATE( IRBIT ) + DEALLOCATE( CRTAG ) -C C language arrays. - - CALL ARDLLOCC +C C language arrays. + + CALL ARDLLOCC - RETURN - END + RETURN + END diff --git a/src/atrcpt.f b/src/atrcpt.f index 3c59006e..dc7f7cf8 100644 --- a/src/atrcpt.f +++ b/src/atrcpt.f @@ -2,10 +2,10 @@ C> @brief Add a tank receipt time to a BUFR message. C> C> ### Program History -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----------|------------|---------------------- -C> 2009-03-23 | J. Ator | Original author -C> 2022-08-04 | J. Woollen | Added 8-byte wrapper +C> 2009-03-23 | J. Ator | Original author +C> 2022-08-04 | J. Woollen | Added 8-byte wrapper C> C> @author J. Ator @date 2009-03-23 @@ -33,16 +33,16 @@ C> C> @author J. Ator @date 2009-03-23 - RECURSIVE SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) + RECURSIVE SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) USE MODV_IM8B - DIMENSION MSGIN(*), MSGOT(*) + DIMENSION MSGIN(*), MSGOT(*) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /TNKRCP/ ITRYR,ITRMO,ITRDY,ITRHR,ITRMI,CTRT - CHARACTER*1 CTRT + CHARACTER*1 CTRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- @@ -59,55 +59,55 @@ RECURSIVE SUBROUTINE ATRCPT(MSGIN,LMSGOT,MSGOT) RETURN ENDIF -C Get some section lengths and addresses from the input message. +C Get some section lengths and addresses from the input message. - CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5) + CALL GETLENS(MSGIN,1,LEN0,LEN1,L2,L3,L4,L5) - IAD1 = LEN0 - IAD2 = IAD1 + LEN1 + IAD1 = LEN0 + IAD2 = IAD1 + LEN1 - LENM = IUPBS01(MSGIN,'LENM') + 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. +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 + LENMOT = LENM + 6 + IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 - LEN1OT = LEN1 + 6 + LEN1OT = LEN1 + 6 -C Write Section 0 of the new message into the output array. +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 ) + 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. +C Store the length of the new Section 1. - IBIT = IAD1*8 - CALL PKB ( LEN1OT, 24, MSGOT, IBIT ) + 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. +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 ) + CALL MVB ( MSGIN, IAD1+4, MSGOT, (IBIT/8)+1, LEN1-3 ) -C Append the tank receipt time data to the new Section 1. +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. + 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 ) - CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LENM-IAD2 ) +C Copy Sections 2, 3, 4 and 5 from the input array to the +C output array. - RETURN -900 CALL BORT('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE '// + 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 + END diff --git a/src/bfrini.f90.in b/src/bfrini.f90.in index 27f3b937..091079be 100644 --- a/src/bfrini.f90.in +++ b/src/bfrini.f90.in @@ -2,27 +2,27 @@ !> @brief Initialize global variables and arrays within internal memory. !> !> ### Program History Log -!> Date | Programmer | Comments +!> Date | Programmer | Comments !> -----|------------|---------- -!> 1994-01-06 | J. Woollen | Original author -!> 1995-06-28 | J. Woollen | Increased the size of internal BUFR table arrays in order to handle bigger files -!> 1998-07-08 | J. Woollen | Modified to make Y2K-compliant -!> 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 (necessary in order to process multiple BUFR files under the MPI) -!> 2000-09-19 | J. Woollen | Maximum message length increased from 10,000 to 20,000 bytes -!> 2003-11-04 | J. Ator | Added documentation -!> 2003-11-04 | S. Bender | Added remarks and routine interdependencies -!> 2003-11-04 | D. Keyser | MAXJL increased from 15000 to 16000; initialize variable JSR to zero in new COMMON block /BUFRSR/; unified/portable for WRF; added documentation -!> 2004-08-18 | J. Ator | Added initialization of COMMON /MSGSTD/; maximum message length increased from 20,000 to 50,000 bytes -!> 2005-11-29 | J. Ator | Added initialization of COMMON /MSGCMP/ and calls to pkvs1 and pkvs01() -!> 2009-03-23 | J. Ator | Added initialization of COMMON /DSCACH/, COMMON /MSTINF/ and COMMON /TNKRCP/ -!> 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface, added initialization of COMMON blocks /ENDORD/ and /BUFRBMISS/ -!> 2014-09-15 | J. Ator | Change default location of MTDIR -!> 2014-11-18 | J. Ator | Added initialization of modules MSGLIM and USRINT; remove S01CM initialization -!> 2016-11-29 | J. Ator | Explicitly initialize BMISS as 10E10_8 -!> 2017-10-13 | J. Ator | Added initialization of COMMON /TABLEF/ -!> 2019-05-03 | J. Ator | Change default location of MTDIR -!> 2019-05-09 | J. Ator | Added dimensions for MSGLEN -!> 2021-03-23 | J. Ator | Use mtinfo() with MASTER_TABLE_DIR macro from CMake +!> 1994-01-06 | J. Woollen | Original author +!> 1995-06-28 | J. Woollen | Increased the size of internal BUFR table arrays in order to handle bigger files +!> 1998-07-08 | J. Woollen | Modified to make Y2K-compliant +!> 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 (necessary in order to process multiple BUFR files under the MPI) +!> 2000-09-19 | J. Woollen | Maximum message length increased from 10,000 to 20,000 bytes +!> 2003-11-04 | J. Ator | Added documentation +!> 2003-11-04 | S. Bender | Added remarks and routine interdependencies +!> 2003-11-04 | D. Keyser | MAXJL increased from 15000 to 16000; initialize variable JSR to zero in new COMMON block /BUFRSR/; unified/portable for WRF; added documentation +!> 2004-08-18 | J. Ator | Added initialization of COMMON /MSGSTD/; maximum message length increased from 20,000 to 50,000 bytes +!> 2005-11-29 | J. Ator | Added initialization of COMMON /MSGCMP/ and calls to pkvs1 and pkvs01() +!> 2009-03-23 | J. Ator | Added initialization of COMMON /DSCACH/, COMMON /MSTINF/ and COMMON /TNKRCP/ +!> 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface, added initialization of COMMON blocks /ENDORD/ and /BUFRBMISS/ +!> 2014-09-15 | J. Ator | Change default location of MTDIR +!> 2014-11-18 | J. Ator | Added initialization of modules MSGLIM and USRINT; remove S01CM initialization +!> 2016-11-29 | J. Ator | Explicitly initialize BMISS as 10E10_8 +!> 2017-10-13 | J. Ator | Added initialization of COMMON /TABLEF/ +!> 2019-05-03 | J. Ator | Change default location of MTDIR +!> 2019-05-09 | J. Ator | Added dimensions for MSGLEN +!> 2021-03-23 | J. Ator | Use mtinfo() with MASTER_TABLE_DIR macro from CMake !> !> @authors J. Woollen J. Ator @date 1994-01-06 diff --git a/src/blocks.f b/src/blocks.f index d6017e8c..6223c2ef 100644 --- a/src/blocks.f +++ b/src/blocks.f @@ -4,7 +4,7 @@ C> This subroutine encapsulates a BUFR message with IEEE Fortran C> control words as specified via the most recent call to -C> subroutine setblock(). +C> subroutine setblock(). C> C>

A previous call to subroutine setblock() is required in C> order to activate encapsulation with control words, and to @@ -67,13 +67,13 @@ SUBROUTINE BLOCKS(MBAY,MWRD) 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 + do i=1,4 + if(cint(1).eq.char(01)) then iordbe(i)=4-i+1 - iordle(i)=i + iordle(i)=i else iordle(i)=4-i+1 - iordbe(i)=i + iordbe(i)=i endif enddo ifirst=1 @@ -85,15 +85,15 @@ SUBROUTINE BLOCKS(MBAY,MWRD) if(nbytw.eq.8) mwrd=mwrd*2 do m=mwrd,1,-1 - mbay(m+1) = mbay(m) + mbay(m+1) = mbay(m) enddo c store the endianized control word in bytes in dint/jint c ------------------------------------------------------- - iint=mwrd*4 + iint=mwrd*4 - do i=1,4 + do i=1,4 if(iblock.eq.+1) dint(i)=cint(iordbe(i)) if(iblock.eq.-1) dint(i)=cint(iordle(i)) enddo diff --git a/src/bufr_interface.h b/src/bufr_interface.h index 56929476..e271a0b2 100644 --- a/src/bufr_interface.h +++ b/src/bufr_interface.h @@ -1,13 +1,13 @@ /** @file - @brief Define signatures to enable a number of BUFRLIB + @brief Define signatures to enable a number of BUFRLIB subprograms to be called via wrapper functions from C and C++ application programs. - + This header file defines the signatures for the functions in bufr_interface.f90 which wrap a number of native Fortran subroutines in the BUFRLIB. - + @author Ronald Mclaren @date 2020-07-29 */ @@ -23,7 +23,7 @@ extern "C" { @param unit - the integer to use as the fortran file unit. @param filepath - path to the file we want to open. - + @author Ronald Mclaren @date 2020-07-29 */ void open_f(int unit, const char* filepath); @@ -191,7 +191,7 @@ extern "C" { @param reference - reference of element. @param bits - number of bits representing the element. @param iret - 0 indicates success -1 indicates failure. - + @author Ronald Mclaren @date 2022-08-08 */ void nemspecs_f(int file_unit, @@ -205,13 +205,13 @@ extern "C" { /** Wraps BUFRLIB nemtab() subroutine. - + @param bufr_unit - the bufr file pointer. @param mnemonic - mnemonic. @param descriptor - the binary descriptor for the mnemonic. @param table_type - 'A', 'B', 'C', or 'D', depending on table type. @param table_idx - the table index, or 0 if not found. - + @author Ronald Mclaren @date 2022-08-16 */ void nemtab_f(int bufr_unit, @@ -221,9 +221,9 @@ extern "C" { int* table_idx); -/** +/** Wraps BUFRLIB nemtbb() subroutine. - + @param bufr_unit - the bufr file pointer. @param table_idx - Table B index. @param unit_str - unit str. @@ -231,9 +231,9 @@ extern "C" { @param scale - scale of element. @param reference - reference of element. @param bits - bits of element. - + @author Ronald McLaren @date 2022-08-16 - + */ void nemtbb_f(int bufr_unit, int table_idx, @@ -246,76 +246,76 @@ extern "C" { /** Get copy of the moda_tables ISC array. - + @param isc_ptr - pointer to a pointer to the ISC array. @param isc_size - size of the ISC array. - - @author Ronald McLaren @date 2022-03-23 + + @author Ronald McLaren @date 2022-03-23 */ void get_isc_f(int** isc_ptr, int* isc_size); -/** +/** Get copy of the moda_tables LINK array. - + @param link_ptr - pointer to a pointer to the LINK array. @param link_size - size of the LINK array. - - @author Ronald McLaren @date 2022-03-23 + + @author Ronald McLaren @date 2022-03-23 */ void get_link_f(int** link_ptr, int* link_size); -/** +/** Get copy of the moda_tables ITP array. @param itp_ptr - pointer to a pointer to the ITP array. @param itp_size - size of the ITP array. - + @author Ronald McLaren @date 2022-03-23 - + */ void get_itp_f(int** itp_ptr, int* itp_size); -/** +/** Get copy of the moda_tables TYP array. @param typ_ptr - pointer to a pointer to the TYP array. @param typ_len - size of each string within the TYP array. @param mem_size - size of the TYP array. - + @author Ronald McLaren @date 2022-03-23 */ void get_typ_f(char** typ_ptr, int* typ_len, int* mem_size); -/** +/** Get copy of the moda_tables TAG array. @param tag_ptr - pointer to a pointer to the TAG array. @param tag_len - size of each string within the TAG array. @param mem_size - size of the TAG array. - + @author Ronald McLaren @date 2022-03-23 - + */ void get_tag_f(char** tag_ptr, int* tag_len, int* mem_size); -/** +/** Get copy of the moda_tables JMPB array. @param jmpb_ptr - pointer to a pointer to the JMPB array. @param jmpb_size - size of the JMPB array. - + @author Ronald McLaren @date 2022-03-23 */ void get_jmpb_f(int** jmpb_ptr, int* jmpb_size); // Data -/** +/** Get the bufr node idx for the start node of the subset. @param lun - pointer for the file stream. @@ -326,7 +326,7 @@ extern "C" { void get_inode_f(int lun, int* start_node); -/** +/** Get the number of values in the current subset @param lun - pointer for the file stream. @@ -337,7 +337,7 @@ extern "C" { void get_nval_f(int lun, int* num_nodes); -/** +/** Get pointer to the moda_usrint VAL array. @param lun - pointer for the file stream. @@ -349,19 +349,19 @@ extern "C" { void get_val_f(int lun, double** val_ptr, int* val_size); -/** +/** Get pointer to the moda_usrint INV array. @param lun - pointer for the file stream. @param inv_ptr - pointer to a pointer to the INV array. @param inv_size - size of the INV array. - + @author Ronald McLaren @date 2022-03-23 */ void get_inv_f(int lun, int** inv_ptr, int* inv_size); -/** +/** Deletes the copies of the moda_tables arrays. @author Ronald McLaren @date 2022-03-23 diff --git a/src/bufrlib.h.in b/src/bufrlib.h.in index eed7eab6..a058132f 100644 --- a/src/bufrlib.h.in +++ b/src/bufrlib.h.in @@ -91,13 +91,13 @@ /** * In order to ensure that the C <-> FORTRAN interface works properly (and - * portably!), the default size of an "INTEGER" declared in FORTRAN must be + * 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. */ + * of an "INTEGER" in FORTRAN. */ #ifdef F77_INTSIZE_8 typedef long f77int; #else @@ -106,7 +106,7 @@ /** Define the C object type that is equivalent to a REAL*8 in * Fortran. */ -typedef double f77r8; +typedef double f77r8; /* ** Declare prototypes for ANSI C compatibility. This should be done for any @@ -187,7 +187,7 @@ void elemdx( char *card, f77int *lun, size_t s1 ); * Wraps BUFRLIB gets1loc() subroutine. * * @param s1mnem - Value whose location within Section 1 is to be determined. - * @param iben - BUFR edition number. + * @param iben - BUFR edition number. * @param isbyt - Number of starting byte within Section 1 for s1mnem. * @param iwid - Bit width for s1mnem. * @param iret - Return code. @@ -489,8 +489,8 @@ void stseq( f77int *lun, f77int *irepct, f77int *idn, char *nemo, char *cseq, f7 * * @param lunit - Fortran logical unit number for BUFR file. * @param usr - Data values. - * @param i1 - First dimension of usr. - * @param i2 - Second dimension of usr. + * @param i1 - First dimension of usr. + * @param i2 - Second dimension of usr. * @param iret - Number of replications of str read or written. * @param str - Mnemonic string. * @param s1 - Extra C-Fortran interface argument containing length of str variable. @@ -504,8 +504,8 @@ void ufbint( f77int *lunit, f77r8 *usr, f77int *i1, f77int *i2, f77int *iret, ch * * @param lunit - Fortran logical unit number for BUFR file. * @param usr - Data values. - * @param i1 - First dimension of usr. - * @param i2 - Second dimension of usr. + * @param i1 - First dimension of usr. + * @param i2 - Second dimension of usr. * @param iret - Number of replications of str read or written. * @param str - Mnemonic string. * @param s1 - Extra C-Fortran interface argument containing length of str variable. diff --git a/src/bvers.f.in b/src/bvers.f.in index 2419e993..f64e8c4a 100644 --- a/src/bvers.f.in +++ b/src/bvers.f.in @@ -30,18 +30,18 @@ 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> | 2020-10-21 | J. Ator | Updated to use PROJECT_VERSION macro from CMake | C> - SUBROUTINE BVERS (CVERSTR) + SUBROUTINE BVERS (CVERSTR) - CHARACTER*(*) CVERSTR + CHARACTER*(*) CVERSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IF (LEN(CVERSTR).LT.8) GOTO 900 + IF (LEN(CVERSTR).LT.8) GOTO 900 - CVERSTR = '@PROJECT_VERSION@' + CVERSTR = '@PROJECT_VERSION@' - RETURN -900 CALL BORT('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE '// + RETURN +900 CALL BORT('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE '// . 'FOR AT LEAST 8 CHARACTERS') - END + END diff --git a/src/cadn30.f b/src/cadn30.f index 19a05da3..2a55c24c 100644 --- a/src/cadn30.f +++ b/src/cadn30.f @@ -20,12 +20,12 @@ C> | -----|------------|----------| C> | 2004-08-18 | J. Ator | Original author | C> - SUBROUTINE CADN30( IDN, ADN ) + SUBROUTINE CADN30( IDN, ADN ) - CHARACTER*(*) ADN - CHARACTER*6 ADN30 + CHARACTER*(*) ADN + CHARACTER*6 ADN30 - ADN = ADN30( IDN, 6 ) + ADN = ADN30( IDN, 6 ) - RETURN - END + RETURN + END diff --git a/src/ccbfl.c b/src/ccbfl.c index 073fd47f..22eec904 100644 --- a/src/ccbfl.c +++ b/src/ccbfl.c @@ -14,7 +14,7 @@ /** * This subroutine closes all system files that were opened via - * previous calls to subroutine cobfl(). + * previous calls to subroutine cobfl(). * * @author J. Ator @date 2005-11-29 */ diff --git a/src/chrtrna.f b/src/chrtrna.f index 80316ad2..add5ce76 100644 --- a/src/chrtrna.f +++ b/src/chrtrna.f @@ -1,13 +1,13 @@ C> @file C> @brief Copy a specified number of characters from an array into C> a string. -C> +C> C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | Original author. C> 2003-11-04 | J. Ator | Added documentation. -C> +C> C> @author J. Woollen @date 1994-01-06 C> This subroutine copies a specified number of characters from an diff --git a/src/cktaba.f b/src/cktaba.f index fb9ddd7c..787c0ffd 100644 --- a/src/cktaba.f +++ b/src/cktaba.f @@ -1,7 +1,7 @@ C> @file C> @brief Parse the Table A mnemonic and date out of Section 1 of a C> BUFR message. -C> +C> C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|---------- @@ -15,7 +15,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 2000-09-19 - + C> This subroutine parses the Table A mnemonic and date C> out of Section 1 of a BUFR message that was previously read from lun C> using one of the [message-reading subroutines](@ref hierarchy). @@ -24,7 +24,7 @@ C> @param[out] SUBSET - character*8: Table A mnemonic C> - returned as a string of all blank characters C> if IRET is equal to 11 (see below) and if Section 3 -C> isn't being used for decoding +C> isn't being used for decoding C> @param[out] JDATE - integer: date-time stored within Section 1 of BUFR C> in format of either YYMMDDHH or C> YYYYMMDDHH, depending on datelen() value. @@ -103,15 +103,15 @@ SUBROUTINE CKTABA(LUN,SUBSET,JDATE,IRET) C -------------------------------------------------------- IF(ISC3(LUN).NE.0) THEN - SUBSET = TAMNEM(LUN) + 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 + 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 diff --git a/src/closmg.f b/src/closmg.f index 26c433f1..d6bae95d 100644 --- a/src/closmg.f +++ b/src/closmg.f @@ -19,7 +19,7 @@ C> 2022-08-04 | J. Woollen | Added 8-byte wrapper. C> C> @author J. Woollen, D. Keyser @date 1994-01-06 - + C> This subroutine closes the BUFR message that is currently open for C> writing within internal arrays associated with logical unit C> ABS(LUNIN), and it then writes the message to that logical unit. diff --git a/src/cmpia.c b/src/cmpia.c index 5680ce46..eeec3263 100644 --- a/src/cmpia.c +++ b/src/cmpia.c @@ -19,7 +19,7 @@ * @param pf1 - first integer to be compared. * @param pf2 - second integer to be compared. * - * @return + * @return * - -1 PF1 is less than PF2 * - 0 PF1 is equal to PF2 * - 1 PF1 is greater than PF2 @@ -28,10 +28,10 @@ */ int cmpia( const void *pf1, const void *pf2 ) { - f77int *mypf1 = ( f77int * ) pf1; - f77int *mypf2 = ( f77int * ) pf2; + f77int *mypf1 = ( f77int * ) pf1; + f77int *mypf2 = ( f77int * ) pf2; - if ( *mypf1 == *mypf2 ) return 0; + if ( *mypf1 == *mypf2 ) return 0; - return ( *mypf1 < *mypf2 ? -1 : 1 ); + return ( *mypf1 < *mypf2 ? -1 : 1 ); } diff --git a/src/cmpmsg.f b/src/cmpmsg.f index 3ab21b9b..ea4c01d4 100644 --- a/src/cmpmsg.f +++ b/src/cmpmsg.f @@ -50,7 +50,7 @@ SUBROUTINE CMPMSG(CF) CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CCMF = CF + CCMF = CF C EXITS C ----- diff --git a/src/cmpstia1.c b/src/cmpstia1.c index c26988db..2739d58a 100644 --- a/src/cmpstia1.c +++ b/src/cmpstia1.c @@ -33,24 +33,24 @@ */ 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; + 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 ); - } + 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 ); + } } diff --git a/src/cmpstia2.c b/src/cmpstia2.c index 8b19152d..0e387c6d 100644 --- a/src/cmpstia2.c +++ b/src/cmpstia2.c @@ -33,14 +33,14 @@ */ 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; + 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 ); - } + 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 ); + } } diff --git a/src/cnved4.f b/src/cnved4.f index 2747069c..7d76ad82 100644 --- a/src/cnved4.f +++ b/src/cnved4.f @@ -34,112 +34,112 @@ C> | 2009-08-12 | J. Ator | Allow silent return (instead of bort() return) if MSGIN is already encoded using edition 4 | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT) + RECURSIVE SUBROUTINE CNVED4(MSGIN,LMSGOT,MSGOT) - USE MODV_IM8B + USE MODV_IM8B - DIMENSION MSGIN(*), MSGOT(*) + DIMENSION MSGIN(*), MSGOT(*) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84 ( LMSGOT, MY_LMSGOT, 1 ) - CALL CNVED4 ( MSGIN, MY_LMSGOT*2, MSGOT ) + CALL X84 ( LMSGOT, MY_LMSGOT, 1 ) + CALL CNVED4 ( MSGIN, MY_LMSGOT*2, MSGOT ) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IF(IUPBS01(MSGIN,'BEN').EQ.4) THEN + 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. +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 + 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. +C Get some section lengths and addresses from the input message. - CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5) + CALL GETLENS(MSGIN,3,LEN0,LEN1,LEN2,LEN3,L4,L5) - IAD2 = LEN0 + LEN1 - IAD4 = IAD2 + LEN2 + LEN3 + IAD2 = LEN0 + LEN1 + IAD4 = IAD2 + LEN2 + LEN3 - LENM = IUPBS01(MSGIN,'LENM') + 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). +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 + LENMOT = LENM + 3 + IF(LENMOT.GT.(LMSGOT*NBYTW)) GOTO 900 - LEN1OT = LEN1 + 4 - LEN3OT = LEN3 - 1 + LEN1OT = LEN1 + 4 + LEN3OT = LEN3 - 1 -C Write Section 0 of the new message into the output array. +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 ) + 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. +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 ) + 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. +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 ) + 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. +C Set a default of 0 for the second. - CALL PKB ( 0, 8, MSGOT, IBIT ) + 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. +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 ) + CALL MVB ( MSGIN, IAD2+1, MSGOT, (IBIT/8)+1, LEN2+LEN3-1 ) -C Store the length of the new Section 3. +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 = ( LEN0 + LEN1OT + LEN2 ) * 8 + CALL PKB ( LEN3OT, 24, MSGOT, IBIT ) - IBIT = IBIT + ( LEN3OT * 8 ) - 24 - CALL MVB ( MSGIN, IAD4+1, MSGOT, (IBIT/8)+1, LENM-IAD4 ) +C Copy Section 4 and Section 5 from the input array to the +C output array. - RETURN -900 CALL BORT('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) '// + 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 + END diff --git a/src/cobfl.c b/src/cobfl.c index d4638556..5f844b43 100644 --- a/src/cobfl.c +++ b/src/cobfl.c @@ -23,7 +23,7 @@ * messages via a C language interface. * * This subroutine is designed to be easily callable from - * application program written in either C or Fortran. + * application program written in either C or Fortran. * It is functionally equivalent to subroutine * openbf(); however, there are some important differences: * - When using openbf(), the underlying file must already be @@ -70,12 +70,12 @@ * Any errors encountered when using this subroutine are * automatically logged to standard output, or to an alternate * location previously specified via a call to subroutine errwrt(). - * + * * @param bfl - System file to be opened. Inclusion of directory * prefixes or other local filesystem notation is allowed, up to 200 * total characters. * @param io - Flag indicating how bfl is to be opened: - * - 'r' input (for reading BUFR messages) + * - 'r' input (for reading BUFR messages) * - 'w' output (for writing BUFR messages) * * @author J. Ator @date 2005-11-29 @@ -97,27 +97,27 @@ void cobfl( char *bfl, char *io ) ** NULL character. */ for ( i = 0; ( ! isspace( bfl[i] ) && ! iscntrl( bfl[i] ) ); i++ ) { - if ( i == MXFNLEN ) { - sprintf( errstr, "BUFRLIB: COBFL - INPUT FILENAME CONTAINS" - " MORE THAN %hu CHARACTERS", - ( unsigned short ) MXFNLEN ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } - lbf[i] = bfl[i]; + if ( i == MXFNLEN ) { + sprintf( errstr, "BUFRLIB: COBFL - INPUT FILENAME CONTAINS" + " MORE THAN %hu CHARACTERS", + ( unsigned short ) 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; + j = 0; } else if ( foparg[0] == 'w' ) { - j = 1; + j = 1; } else { - sprintf( errstr, "BUFRLIB: COBFL - SECOND ARGUMENT WAS (%c)," - " WHICH IS AN ILLEGAL VALUE", lio ); - bort( errstr, ( f77int ) strlen( errstr ) ); + sprintf( errstr, "BUFRLIB: COBFL - SECOND ARGUMENT WAS (%c)," + " WHICH IS AN ILLEGAL VALUE", lio ); + bort( errstr, ( f77int ) strlen( errstr ) ); } /* @@ -129,8 +129,8 @@ void cobfl( char *bfl, char *io ) ** 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 ) ); + sprintf( errstr, "BUFRLIB: COBFL - COULD NOT OPEN FILE %s", lbf ); + bort( errstr, ( f77int ) strlen( errstr ) ); } /* @@ -138,6 +138,6 @@ void cobfl( char *bfl, char *io ) ** local machine, just in case it hasn't already been called. */ wrdlen( ); - + return; } diff --git a/src/codflg.f b/src/codflg.f index 26713f69..1b4adbe4 100644 --- a/src/codflg.f +++ b/src/codflg.f @@ -54,7 +54,7 @@ SUBROUTINE CODFLG(CF) CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CDMF = CF + CDMF = CF C EXITS C ----- diff --git a/src/conwin.f b/src/conwin.f index eaf706a6..0d053444 100644 --- a/src/conwin.f +++ b/src/conwin.f @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> This subroutine searches consecutive subset buffer segments for an C> element identified in the user string as a conditional node. A conditional C> node is an element which must meet a condition in order to be read @@ -22,11 +22,11 @@ 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> C> The four conditions which can be exercised are: C> - '<' - less than C> - '>' - greater than -C> - '=' - equal +C> - '=' - equal C> - '!' - not equal C> C> Each condition in a string is applied to one element, and all @@ -37,15 +37,15 @@ C> C> See getwin() for an explanation of "windows" within the context of a C> BUFR data subset. -C> +C> C> Function conwin() works with function invcon() to identify subset C> buffer segments which conform to the set of conditions. -C> +C> C> @param[in] LUN integer I/O stream index into internal memory arrays. -C> @param[out] INC1 integer subset buffer start index +C> @param[out] INC1 integer subset buffer start index C> @param[inout] INC2 integer subset buffer ending index C> -C> @author Woollen @date 1994-01-06 +C> @author Woollen @date 1994-01-06 SUBROUTINE CONWIN(LUN,INC1,INC2) USE MODA_USRINT diff --git a/src/copybf.f b/src/copybf.f index 27630947..64b88630 100644 --- a/src/copybf.f +++ b/src/copybf.f @@ -8,9 +8,9 @@ C> @date 1994-01-06 C> C> @param[in] LUNIN -- integer: Fortran logical unit number for -C> source BUFR file +C> source BUFR file C> @param[in] LUNOT -- integer: Fortran logical unit number for -C> target BUFR file +C> target BUFR file C> C>

The logical unit numbers LUNIN and LUNOT must already be C> associated with actual filenames on the local system, typically @@ -70,7 +70,7 @@ RECURSIVE SUBROUTINE COPYBF(LUNIN,LUNOT) 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 CONNECT THE FILES FOR READING/WRITING TO THE C-I-O INTERFACE C ------------------------------------------------------------ CALL OPENBF(LUNIN,'INX',LUNIN) @@ -80,7 +80,7 @@ RECURSIVE SUBROUTINE COPYBF(LUNIN,LUNOT) C ----------------------------------------------------- 1 CALL RDMSGW(LUNIN,MGWA,IER) - IF(IER.EQ.0) THEN + IF(IER.EQ.0) THEN CALL MSGWRT(LUNOT,MGWA,IUPBS01(MGWA,'LENM')) GOTO 1 ENDIF @@ -89,7 +89,7 @@ RECURSIVE SUBROUTINE COPYBF(LUNIN,LUNOT) C ---------------------------------------------- CALL CLOSBF(LUNIN) - CALL CLOSBF(LUNOT) + CALL CLOSBF(LUNOT) C EXITS C ----- diff --git a/src/copymg.f b/src/copymg.f index ba6c02cc..c3d982cb 100644 --- a/src/copymg.f +++ b/src/copymg.f @@ -75,7 +75,7 @@ RECURSIVE SUBROUTINE COPYMG(LUNIN,LUNOT) CALL X84(LUNOT,MY_LUNOT,1) CALL COPYMG(MY_LUNIN,MY_LUNOT) - IM8B=.TRUE. + IM8B=.TRUE. RETURN ENDIF diff --git a/src/cpdxmm.f b/src/cpdxmm.f index c4004e0d..ac4f493a 100644 --- a/src/cpdxmm.f +++ b/src/cpdxmm.f @@ -18,112 +18,112 @@ C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE CPDXMM( LUNIT ) + RECURSIVE SUBROUTINE CPDXMM( LUNIT ) USE MODV_MXDXTS USE MODV_IM8B - USE MODA_MGWA - USE MODA_MSGMEM + USE MODA_MGWA + USE MODA_MSGMEM - COMMON /QUIET/ IPRT + COMMON /QUIET/ IPRT - CHARACTER*128 ERRSTR + CHARACTER*128 ERRSTR - LOGICAL DONE + LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers +C Check for I8 integers - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LUNIT,MY_LUNIT,1) - CALL CPDXMM(MY_LUNIT) + CALL X84(LUNIT,MY_LUNIT,1) + CALL CPDXMM(MY_LUNIT) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IF ( NDXTS .GE. MXDXTS ) GOTO 900 + IF ( NDXTS .GE. MXDXTS ) GOTO 900 - ICT = 0 - DONE = .FALSE. + 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. +C Read a complete dictionary table from LUNIT, as a set of one or +C more DX dictionary messages. - DO WHILE ( .NOT. DONE ) + 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. +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. + CALL BACKBUFR(LUN) + DONE = .TRUE. ELSE IF ( IER .EQ. -2 ) THEN - GOTO 901 - ELSE IF ( IDXMSG(MGWA) .NE. 1 ) 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. +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 + 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. +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 + DONE = .TRUE. + ELSE -C Store this message into MODULE MSGMEM. +C Store this message into MODULE MSGMEM. ICT = ICT + 1 - IF ( ( NDXM + ICT ) .GT. MXDXM ) GOTO 902 + IF ( ( NDXM + ICT ) .GT. MXDXM ) GOTO 902 IPDXM(NDXM+ICT) = LDXM + 1 LMEM = NMWRD(MGWA) - IF ( ( LDXM + LMEM ) .GT. MXDXW ) GOTO 903 + IF ( ( LDXM + LMEM ) .GT. MXDXW ) GOTO 903 DO J = 1, LMEM MDX(LDXM+J) = MGWA(J) ENDDO LDXM = LDXM + LMEM ENDIF - ENDDO + ENDDO -C Update the table information within MODULE MSGMEM. +C Update the table information within MODULE MSGMEM. - IF ( ICT .GT. 0 ) THEN + 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('+++++++++++++++++++++++++++++++++++++++++++++') + 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 + 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 diff --git a/src/cpmstabs.c b/src/cpmstabs.c index c2a50f42..59e9b270 100644 --- a/src/cpmstabs.c +++ b/src/cpmstabs.c @@ -42,54 +42,53 @@ * @author J. Ator @date 2014-12-04 */ void cpmstabs( f77int *pnmtb, - f77int *pibfxyn, char (*pcbscl)[4], - char (*pcbsref)[12], char (*pcbbw)[4], - char (*pcbunit)[24], char (*pcbmnem)[8], - char (*pcbelem)[120], - f77int *pnmtd, - f77int *pidfxyn, char (*pcdseq)[120], - char (*pcdmnem)[8], f77int *pndelem, - f77int *pidefxy, f77int *maxcd ) + f77int *pibfxyn, char (*pcbscl)[4], + char (*pcbsref)[12], char (*pcbbw)[4], + char (*pcbunit)[24], 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; nmtb_c = *pnmtb; for ( ii = 0; ii < *pnmtb; ii++ ) { - ibfxyn_c[ii] = pibfxyn[ii]; - for ( jj = 0; jj < 4; jj++ ) { - cbscl_c[ii][jj] = pcbscl[ii][jj]; - cbbw_c[ii][jj] = pcbbw[ii][jj]; - } - for ( jj = 0; jj < 8; jj++ ) { - cbmnem_c[ii][jj] = pcbmnem[ii][jj]; - } - for ( jj = 0; jj < 12; jj++ ) { - cbsref_c[ii][jj] = pcbsref[ii][jj]; - } - for ( jj = 0; jj < 24; jj++ ) { - cbunit_c[ii][jj] = pcbunit[ii][jj]; - } - for ( jj = 0; jj < 120; jj++ ) { - cbelem_c[ii][jj] = pcbelem[ii][jj]; - } + ibfxyn_c[ii] = pibfxyn[ii]; + for ( jj = 0; jj < 4; jj++ ) { + cbscl_c[ii][jj] = pcbscl[ii][jj]; + cbbw_c[ii][jj] = pcbbw[ii][jj]; + } + for ( jj = 0; jj < 8; jj++ ) { + cbmnem_c[ii][jj] = pcbmnem[ii][jj]; + } + for ( jj = 0; jj < 12; jj++ ) { + cbsref_c[ii][jj] = pcbsref[ii][jj]; + } + for ( jj = 0; jj < 24; jj++ ) { + cbunit_c[ii][jj] = pcbunit[ii][jj]; + } + for ( jj = 0; jj < 120; jj++ ) { + cbelem_c[ii][jj] = pcbelem[ii][jj]; + } } nmtd_c = *pnmtd; for ( ii = 0; ii < *pnmtd; ii++ ) { - idfxyn_c[ii] = pidfxyn[ii]; - ndelem_c[ii] = pndelem[ii]; - for ( jj = 0; jj < pndelem[ii]; jj++ ) { - idx = icvidx( &ii, &jj, maxcd ); - idefxy_c[idx] = pidefxy[idx]; - } - for ( jj = 0; jj < 8; jj++ ) { - cdmnem_c[ii][jj] = pcdmnem[ii][jj]; - } - for ( jj = 0; jj < 120; jj++ ) { - cdseq_c[ii][jj] = pcdseq[ii][jj]; - } + idfxyn_c[ii] = pidfxyn[ii]; + ndelem_c[ii] = pndelem[ii]; + for ( jj = 0; jj < pndelem[ii]; jj++ ) { + idx = icvidx( &ii, &jj, maxcd ); + idefxy_c[idx] = pidefxy[idx]; + } + for ( jj = 0; jj < 8; jj++ ) { + cdmnem_c[ii][jj] = pcdmnem[ii][jj]; + } + for ( jj = 0; jj < 120; jj++ ) { + cdseq_c[ii][jj] = pcdseq[ii][jj]; + } } } - diff --git a/src/cpyupd.f b/src/cpyupd.f index 0a4cf793..2c17f685 100644 --- a/src/cpyupd.f +++ b/src/cpyupd.f @@ -1,6 +1,6 @@ C> @file C> @brief Copy a BUFR data subset. -C> pointers. +C> pointers. C> C> ### Program History Log C> Date | Programmer | Comments @@ -20,7 +20,7 @@ C> 2015-09-24 | D. Stokes | Fix missing declaration OF COMMON QUIET. C> C> @author Woollen @date 1994-01-06 - + C> This subroutine copies a BUFR data subset from one unit C> to another within internal memory and resets the pointers. C> If the subset will not fit into the output message, or diff --git a/src/crbmg.c b/src/crbmg.c index 1722170c..764d59b1 100644 --- a/src/crbmg.c +++ b/src/crbmg.c @@ -1,7 +1,7 @@ /** @file * @brief Read the next message from a BUFR file that was * previously opened for reading via a C language interface. - * + * * ### Program history log * Date | Programmer | Comments * -----|------------|--------- @@ -12,7 +12,7 @@ #include "bufrlib.h" #include "cobfl.h" -/** +/** * This subroutine reads the next BUFR message from the system * file that was opened via the most recent call to subroutine * cobfl() with io = 'r'. @@ -27,7 +27,7 @@ * - 0 = normal return * - 1 = overflow of bmg array * - 2 = "7777" indicator not found in - * expected location + * expected location * - -1 = end-of-file encountered while * reading * - -2 = I/O error encountered while reading @@ -42,7 +42,7 @@ * Any messages read that were encoded according to BUFR edition 0 * or BUFR edition 1 are automatically converted to BUFR edition 2 * before being returned by this subroutine. - * + * * @author J. Ator @date 2005-11-29 */ void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) @@ -53,21 +53,21 @@ void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) char errstr[129]; - unsigned short i, nsecs; + 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" ); + 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; + *iret = 1; + return; } strncpy( bmg, " ", 4); /* @@ -75,7 +75,7 @@ void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) */ while ( ichkstr( "BUFR", bmg, &i4, 4, 4 ) != 0 ) { memmove( bmg, &bmg[1], 3 ); - if ( ( *iret = rbytes( bmg, mxmb, 3, 1 ) ) != 0 ) return; + if ( ( *iret = rbytes( bmg, mxmb, 3, 1 ) ) != 0 ) return; } /* ** Read the next 4 bytes and determine the BUFR edition number that was used @@ -87,62 +87,62 @@ void crbmg( char *bmg, f77int *mxmb, f77int *nmb, f77int *iret ) if ( iben >= 2 ) { /* -** Get the length of the BUFR message. +** Get the length of the BUFR message. */ *nmb = iupbs01( wkint, "LENM", 4 ); /* -** Read the remainder of the BUFR message. +** Read the remainder of the BUFR message. */ - if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; + 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. +** 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 */ + lsec = 4; /* length of Section 0 */ /* -** Get the length of Section 1 and add it to the total. +** 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 ); + 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. +** Read up through the end of Section 1. */ - if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; + if ( ( *iret = rbytes( bmg, mxmb, 8, *nmb-8 ) ) != 0 ) return; /* -** Is there a Section 2? +** Is there a Section 2? */ - gets1loc( "ISC2", &iben, &isbyt, &iwid, &wkint[0], 4 ); - nsecs = iupm( &bmg[lsec+isbyt-1], &iwid, 1 ) + 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. +** 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; - } + 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. +** Read Section 5. */ - if ( ( *iret = rbytes( bmg, mxmb, *nmb, 4 ) ) != 0 ) return; - *nmb += 4; + 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. +** 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; + 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 ); + 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. diff --git a/src/cread.c b/src/cread.c index 95965de1..d18e4d9e 100644 --- a/src/cread.c +++ b/src/cread.c @@ -15,7 +15,7 @@ * ### Program History * Date | Programmer | Comments * -----|------------|---------- - * 2012-09-15 | J. Woollen | Original author + * 2012-09-15 | J. Woollen | Original author * 2014-11-07 | J. Ator | Allow dynamic allocation of pb array * * @author J. Woollen @date 2012-09-15 @@ -122,7 +122,7 @@ f77int *nfile; f77int *mxbyt; char *bufr; * * @author J. Woollen @date 2012-09-15 */ -void cwrbufr (nfile,bufr,nwrd) +void cwrbufr (nfile,bufr,nwrd) f77int *nfile; f77int *nwrd; f77int *bufr; { f77int nb; nb = sizeof(*bufr); fwrite(bufr,nb,*nwrd,pb[*nfile]); diff --git a/src/cread.h b/src/cread.h index 073b8939..976608e7 100644 --- a/src/cread.h +++ b/src/cread.h @@ -1,7 +1,7 @@ /** @file * @brief Define signatures and declare variables for reading or writing BUFR * messages via a C language interface. - * + * * These signatures and variables are used by the C language interface which * encompasses subroutines openrb(), openwb(), openab(), backbufr(), cewind(), * closfb(), crdbufr() and cwrbufr(). diff --git a/src/cwbmg.c b/src/cwbmg.c index 3510c98a..f32c4160 100644 --- a/src/cwbmg.c +++ b/src/cwbmg.c @@ -5,11 +5,11 @@ #include "bufrlib.h" #include "cobfl.h" -/** +/** * This subroutine writes a BUFR message to the system * file that was opened via the most recent call to subroutine * cobfl() with io = 'w'. - * + * * @author J. Ator * @date 2005-11-29 * @@ -40,7 +40,7 @@ void cwbmg( char *bmg, f77int *nmb, f77int *iret ) ** Make sure that a file is open for writing. */ if ( pbf[1] == NULL ) { - sprintf( errstr, "BUFRLIB: CWBMG - NO FILE IS OPEN FOR WRITING" ); + sprintf( errstr, "BUFRLIB: CWBMG - NO FILE IS OPEN FOR WRITING" ); bort( errstr, ( f77int ) strlen( errstr ) ); } /* diff --git a/src/datelen.f b/src/datelen.f index cceb216d..f475c436 100644 --- a/src/datelen.f +++ b/src/datelen.f @@ -10,7 +10,7 @@ C> | 2003-11-04 | J. Ator | Added documentation | C> | 2004-12-20 | D. Keyser | Calls wrdlen() to initialize local machine information, in case it has not yet been called | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | -C> +C> C> @author J. Woollen @date 1998-07-08 C> This subroutine is used to specify the format of Section 1 @@ -24,7 +24,7 @@ C> subroutine to reset the value of LEN again. If this subroutine is C> never called, a default value of 8 is used for LEN, as set within C> subroutine bfrini(). -C> +C> C> @param[in] LEN -- integer: Length of Section 1 date-time C> values to be output by all future calls C> to message-reading subroutines diff --git a/src/dlloctbf.c b/src/dlloctbf.c index d9a9febe..ea7be090 100644 --- a/src/dlloctbf.c +++ b/src/dlloctbf.c @@ -8,10 +8,10 @@ /** * This subroutine frees any memory that was dynamically allocated * during a previous call to subroutine inittbf(). - * + * * @author J. Ator * @date 2017-11-03 - * + * * Program history log: * | Date | Programmer | Comments | * | -----|------------|----------| diff --git a/src/drfini.f b/src/drfini.f index 12ef5ac4..6a9c8821 100644 --- a/src/drfini.f +++ b/src/drfini.f @@ -44,7 +44,7 @@ C> ufbint() or ufbrep() are to be called to store data values C> for a delayed replication sequence which only occurs one time C> within an overall subset definition, because in that case the -C> same type of initialization and space allocation functionality +C> same type of initialization and space allocation functionality C> will be automatically handled internally within subroutine C> ufbint() or ufbrep(). C> diff --git a/src/dumpbf.f b/src/dumpbf.f index 6f749629..ea6b3ee0 100644 --- a/src/dumpbf.f +++ b/src/dumpbf.f @@ -116,7 +116,7 @@ RECURSIVE SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) 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)) @@ -128,7 +128,7 @@ RECURSIVE SUBROUTINE DUMPBF(LUNIT,JDATE,JDUMP) 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)) diff --git a/src/dxdump.f b/src/dxdump.f index a13befcc..198fcbeb 100644 --- a/src/dxdump.f +++ b/src/dxdump.f @@ -7,7 +7,7 @@ C> This subroutine is especially useful for learning the structure C> of existing BUFR files which contain DX BUFR table information C> embedded as BUFR messages within those files. -C> The DX BUFR table is printed using the same ASCII format +C> The DX BUFR table is printed using the same ASCII format C> described in the documentation for C> [DX BUFR Tables](@ref dfbftab), so the output file is suitable C> for use as Fortran logical unit LUNDX in subsequent calls to @@ -30,7 +30,7 @@ C> @remarks C> - This subroutine only prints the DX BUFR table that is currently C> in scope for logical unit LUNIT. Therefore, if logical unit LUNIT -C> contains multiple embedded DX BUFR tables, then multiple calls to +C> contains multiple embedded DX BUFR tables, then multiple calls to C> this subroutine must be made to print out all of the tables, C> once while each table is in scope for a data subset defined C> within that particular table. @@ -121,8 +121,8 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) WRITE (LDXOT,'(A)') CARDI4 CARD=CARDI1 - CARD( 3:10)='MNEMONIC' - CARD(14:19)='NUMBER' + CARD( 3:10)='MNEMONIC' + CARD(14:19)='NUMBER' CARD(23:33)='DESCRIPTION' WRITE (LDXOT,'(A)') CARD @@ -140,8 +140,8 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) 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( 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. @@ -173,8 +173,8 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) 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( 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 @@ -188,8 +188,8 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) WRITE (LDXOT,'(A)') CARDI4 CARD=CARDI2 - CARD( 3:10)='MNEMONIC' - CARD(14:21)='SEQUENCE' + CARD( 3:10)='MNEMONIC' + CARD(14:21)='SEQUENCE' WRITE (LDXOT,'(A)') CARD CARD=CARDI4 @@ -204,13 +204,13 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) DO N=1,NTBD(LUN) IF(.NOT.TDSKIP(TABD(N,LUN)(1:6))) THEN CARD=CARDI2 - CARD( 3:10)=TABD(N,LUN)( 7:14) + 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 @@ -252,7 +252,7 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) IF(IC.GT.(79-ICMS)) THEN WRITE (LDXOT,'(A)') CARD CARD=CARDI2 - CARD( 3:10)=TABD(N,LUN)( 7:14) + CARD( 3:10)=TABD(N,LUN)( 7:14) IC = 14 END IF CARD(IC:IC+ICMS-1)=CMSTR(1:ICMS) @@ -275,11 +275,11 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) 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' + 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 @@ -298,25 +298,25 @@ RECURSIVE SUBROUTINE DXDUMP(LUNIT,LDXOT) 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) + 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 + 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 + 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 + CARD(37-NCH+1:37)=WRK2 WRITE (LDXOT,'(A)') CARD END IF END DO diff --git a/src/dxinit.f b/src/dxinit.f index 4f19e7e9..eba9c1ba 100644 --- a/src/dxinit.f +++ b/src/dxinit.f @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks C> C> @author Woollen @date 1994-01-06 - + C> This subroutine initializes the internal arrays C> (in module tababd) holding the DX BUFR table. It then C> initializes the table with apriori Table B and D entries diff --git a/src/dxmini.f b/src/dxmini.f index be29cce9..4ee55e67 100644 --- a/src/dxmini.f +++ b/src/dxmini.f @@ -17,7 +17,7 @@ C> 2021-05-14 | J. Ator | Changed default master table version to 36. C> C> @author Woollen @date 1994-01-06 - + C> This subroutine initializes a DX BUFR tables (dictionary) C> message, writing all the preliminary information into Sections 0, C> 1, 3, 4. Subroutine wrdxtb() will write the diff --git a/src/elemdx.f b/src/elemdx.f index 74dce1f1..794eb36a 100644 --- a/src/elemdx.f +++ b/src/elemdx.f @@ -17,7 +17,7 @@ C> 2021-09-30 | J. Ator | Replace jstchr with Fortran intrinsic adjustl. C> C> @author Woollen @date 1994-01-06 - + C> 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 DX BUFR diff --git a/src/exitbufr.f b/src/exitbufr.f index faa8496e..fd1c231f 100644 --- a/src/exitbufr.f +++ b/src/exitbufr.f @@ -6,7 +6,7 @@ C> closes all logical units that are open within the C> BUFRLIB software, and resets the library to all of its C> default settings as though it had never been called. -C> +C> C> @author J. Ator C> @date 2015-03-02 C> @@ -36,49 +36,49 @@ C> | 2015-03-02 | J. Ator | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE SUBROUTINE EXITBUFR + RECURSIVE SUBROUTINE EXITBUFR - USE MODV_IM8B - USE MODV_IFOPBF + USE MODV_IM8B + USE MODV_IFOPBF USE MODV_NFILES - USE MODA_STBFR - USE MODA_S01CM + USE MODA_STBFR + USE MODA_S01CM - COMMON /TABLEF/ CDMF + COMMON /TABLEF/ CDMF - CHARACTER*1 CDMF + CHARACTER*1 CDMF C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF (IM8B) THEN - IM8B = .FALSE. + IF (IM8B) THEN + IM8B = .FALSE. - CALL EXITBUFR + CALL EXITBUFR - IM8B = .TRUE. - RETURN - END IF + IM8B = .TRUE. + RETURN + END IF -C Close any logical units that are open to the library. +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 + DO JJ = 1, NFILES + IF ( IOLUN(JJ) .NE. 0 ) CALL CLOSBF( ABS(IOLUN(JJ)) ) + END DO -C Deallocate all allocated memory. +C Deallocate all allocated memory. - CALL ARDLLOCF + CALL ARDLLOCF - IF ( CDMF .EQ. 'Y' ) CALL DLLOCTBF + IF ( CDMF .EQ. 'Y' ) CALL DLLOCTBF -C Reset the library. +C Reset the library. - NS01V = 0 - IFOPBF = 0 + NS01V = 0 + IFOPBF = 0 - RETURN - END + RETURN + END diff --git a/src/fortran_close.f90 b/src/fortran_close.f90 index e1799f4e..8dbcd09e 100644 --- a/src/fortran_close.f90 +++ b/src/fortran_close.f90 @@ -2,7 +2,7 @@ !> @brief Close a Fortran file on the local system. !> !> ### Program History -!> Date | Programmer | Comments +!> Date | Programmer | Comments !> -----|------------|---------- !> 2015-08-30 | J. Whitaker | Original author !> 2022-09-01 | J. Ator | Added 8-byte wrapper diff --git a/src/fortran_open.f90 b/src/fortran_open.f90 index ea690c65..90689421 100644 --- a/src/fortran_open.f90 +++ b/src/fortran_open.f90 @@ -2,7 +2,7 @@ !> @brief Open a Fortran file on the local system !> !> ### Program History -!> Date | Programmer | Comments +!> Date | Programmer | Comments !> -----|------------|---------- !> 2015-08-30 | J. Whitaker | Original author !> 2022-08-04 | J. Woollen | Added 8-byte wrapper diff --git a/src/fstag.f b/src/fstag.f index 70898678..184bc178 100644 --- a/src/fstag.f +++ b/src/fstag.f @@ -9,7 +9,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author J Ator @date 2014-10-02 - + C> 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 @@ -28,44 +28,44 @@ C> - -1 Requested mnemonic could not be found, or some other error occurred. C> C> @author J Ator @date 2014-10-02 - SUBROUTINE FSTAG ( LUN, UTAG, NUTAG, NIN, NOUT, IRET ) + SUBROUTINE FSTAG ( LUN, UTAG, NUTAG, NIN, NOUT, IRET ) - USE MODA_USRINT - USE MODA_TABLES + USE MODA_USRINT + USE MODA_TABLES - CHARACTER*10 TGS(15) + CHARACTER*10 TGS(15) - CHARACTER*(*) UTAG + CHARACTER*(*) UTAG - DATA MAXTG /15/ + DATA MAXTG /15/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- - IRET = -1 + IRET = -1 + +C Confirm that there is only one mnemonic in the input string. -C Confirm that there is only one mnemonic in the input string. + CALL PARSTR( UTAG, TGS, MAXTG, NTG, ' ', .TRUE. ) + IF ( NTG .NE .1 ) RETURN - 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. -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 - 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 + RETURN + END diff --git a/src/getabdb.f b/src/getabdb.f index cc685d43..965694d8 100644 --- a/src/getabdb.f +++ b/src/getabdb.f @@ -1,7 +1,7 @@ C> @file C> @brief Get Table B and Table D information from the internal DX BUFR C> tables - + C> This subroutine reads Table B and Table D information from the C> internal DX BUFR tables for a specified Fortran logical unit, then C> returns this information in a pre-defined ASCII format. diff --git a/src/getcfmng.f b/src/getcfmng.f index c9204571..fcfcd5cc 100644 --- a/src/getcfmng.f +++ b/src/getcfmng.f @@ -33,7 +33,7 @@ C> indeed depends on one or more other possible C> second mnemonics, then those possible second C. mnemonics are returned within this string, as a -C> series of IRET successive 8-byte substrings. +C> series of IRET successive 8-byte substrings. C> An example of this scenario is included below C> within the Remarks. C> @param[out] LNMNG -- integer: Length (in bytes) of string returned in @@ -107,151 +107,151 @@ C> | 2018-02-08 | J. Ator | Add special handling for data types and subtypes in Section 1 | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE GETCFMNG + RECURSIVE SUBROUTINE GETCFMNG . ( LUNIT, NEMOI, IVALI, NEMOD, IVALD, CMEANG, LNMNG, IRET ) - USE MODA_TABABD + USE MODA_TABABD USE MODV_IM8B - COMMON /TABLEF/ CDMF + COMMON /TABLEF/ CDMF - CHARACTER*(*) NEMOI, NEMOD, CMEANG + CHARACTER*(*) NEMOI, NEMOD, CMEANG - CHARACTER*128 BORT_STR - CHARACTER*8 NEMO - CHARACTER*1 CDMF, TAB + CHARACTER*128 BORT_STR + CHARACTER*8 NEMO + CHARACTER*1 CDMF, TAB - DIMENSION IFXYD(10) + DIMENSION IFXYD(10) C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C* Check for I8 integers. +C* Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LUNIT,MY_LUNIT,1) - CALL X84(IVALI,MY_IVALI,1) - CALL X84(IVALD,MY_IVALD,1) - CALL GETCFMNG(MY_LUNIT,NEMOI,MY_IVALI,NEMOD,MY_IVALD,CMEANG, - . LNMNG,IRET) - CALL X48(LNMNG,LNMNG,1) - CALL X48(IRET,IRET,1) + CALL X84(LUNIT,MY_LUNIT,1) + CALL X84(IVALI,MY_IVALI,1) + CALL X84(IVALD,MY_IVALD,1) + CALL GETCFMNG(MY_LUNIT,NEMOI,MY_IVALI,NEMOD,MY_IVALD,CMEANG, + . LNMNG,IRET) + CALL X48(LNMNG,LNMNG,1) + CALL X48(IRET,IRET,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - CALL STATUS ( LUNIT, LUN, IL, IM ) - IF ( IL .EQ. 0 ) GOTO 900 - IF ( IL .GT. 0 ) GOTO 901 - IF ( IM .EQ. 0 ) GOTO 902 + 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. +C* Make sure the appropriate code/flag information has already been +C* read into internal memory. - IF ( CDMF .NE. 'Y' ) GOTO 903 + IF ( CDMF .NE. 'Y' ) GOTO 903 - ITMP = IREADMT ( LUN ) + 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. +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 ) + 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 + 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. +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 + 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. +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 + 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 + 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 '// @@ -260,10 +260,10 @@ RECURSIVE SUBROUTINE GETCFMNG . '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,'// +904 WRITE(BORT_STR,'("BUFRLIB: GETCFMNG - MNEMONIC ",A,'// . '" NOT FOUND IN TABLE B")') NEMO - CALL BORT(BORT_STR) + 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 + CALL BORT(BORT_STR) + END diff --git a/src/getlens.f b/src/getlens.f index 827238a0..6a8bef00 100644 --- a/src/getlens.f +++ b/src/getlens.f @@ -37,61 +37,61 @@ C> | 2005-11-29 | J. Ator | Original author | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE GETLENS - . (MBAY,LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) + RECURSIVE SUBROUTINE GETLENS + . (MBAY,LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) - USE MODV_IM8B + USE MODV_IM8B - DIMENSION MBAY(*) + DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LL,MY_LL,1) - CALL GETLENS(MBAY,MY_LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) - CALL X48(LEN0,LEN0,1) - CALL X48(LEN1,LEN1,1) - CALL X48(LEN2,LEN2,1) - CALL X48(LEN3,LEN3,1) - CALL X48(LEN4,LEN4,1) - CALL X48(LEN5,LEN5,1) + CALL X84(LL,MY_LL,1) + CALL GETLENS(MBAY,MY_LL,LEN0,LEN1,LEN2,LEN3,LEN4,LEN5) + CALL X48(LEN0,LEN0,1) + CALL X48(LEN1,LEN1,1) + CALL X48(LEN2,LEN2,1) + CALL X48(LEN3,LEN3,1) + CALL X48(LEN4,LEN4,1) + CALL X48(LEN5,LEN5,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - LEN0 = -1 - LEN1 = -1 - LEN2 = -1 - LEN3 = -1 - LEN4 = -1 - LEN5 = -1 + LEN0 = -1 + LEN1 = -1 + LEN2 = -1 + LEN3 = -1 + LEN4 = -1 + LEN5 = -1 - IF(LL.LT.0) RETURN - LEN0 = IUPBS01(MBAY,'LEN0') + IF(LL.LT.0) RETURN + LEN0 = IUPBS01(MBAY,'LEN0') - IF(LL.LT.1) RETURN - LEN1 = IUPBS01(MBAY,'LEN1') + 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.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.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.4) RETURN + IAD4 = IAD3 + LEN3 + LEN4 = IUPB(MBAY,IAD4+1,24) - IF(LL.LT.5) RETURN - LEN5 = 4 + IF(LL.LT.5) RETURN + LEN5 = 4 - RETURN - END + RETURN + END diff --git a/src/getntbe.f b/src/getntbe.f index 5e12203b..1429787c 100644 --- a/src/getntbe.f +++ b/src/getntbe.f @@ -1,7 +1,7 @@ C> @file C> @brief Read the first line of the next entry from a master C> table B, table D or Code/Flag table file - + C> This subroutine reads the first line of the next entry from C> the specified ASCII master table B, table D or table F (Code/Flag) C> file. This line contains, among other things, the FXY number @@ -10,7 +10,7 @@ C> @author J. Ator C> @date 2007-01-19 C> -C> @param[in] LUNT -- integer: Fortran logical unit number of +C> @param[in] LUNT -- integer: Fortran logical unit number of C> master table B, table D or Code/Flag table file C> @param[out] IFXYN -- integer: Bit-wise representation of FXY number C> for next table entry @@ -27,38 +27,38 @@ C> | -----|------------|----------| C> | 2007-01-19 | J. Ator | Original author | C> - SUBROUTINE GETNTBE ( LUNT, IFXYN, LINE, IRET ) + SUBROUTINE GETNTBE ( LUNT, IFXYN, LINE, IRET ) - CHARACTER*(*) LINE - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*20 TAGS(4) - CHARACTER*6 ADSC + 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. +C Get the first line of the next entry in the file. - IRET = IGETNTBL ( LUNT, LINE ) - IF ( IRET .EQ. 0 ) THEN + IRET = IGETNTBL ( LUNT, LINE ) + IF ( IRET .EQ. 0 ) THEN -C The first field within this line should contain the -C FXY number. +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 + 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. +C Store the bit-wise representation of the FXY number. - IFXYN = IFXY ( ADSC ) - ENDIF + IFXYN = IFXY ( ADSC ) + ENDIF - RETURN + 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) + CALL BORT2(BORT_STR1,BORT_STR2) - END + END diff --git a/src/gets1loc.f b/src/gets1loc.f index cdd22ce2..c2069bbb 100644 --- a/src/gets1loc.f +++ b/src/gets1loc.f @@ -60,153 +60,153 @@ C> | 2006-04-14 | D. Keyser | Added options for 'YCEN' and 'CENT' | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) + RECURSIVE SUBROUTINE GETS1LOC(S1MNEM,IBEN,ISBYT,IWID,IRET) - USE MODV_IM8B + USE MODV_IM8B - CHARACTER*(*) S1MNEM + CHARACTER*(*) S1MNEM C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(IBEN,MY_IBEN,1) - CALL GETS1LOC(S1MNEM,MY_IBEN,ISBYT,IWID,IRET) - CALL X48(ISBYT,ISBYT,1) - CALL X48(IWID,IWID,1) - CALL X48(IRET,IRET,1) + CALL X84(IBEN,MY_IBEN,1) + CALL GETS1LOC(S1MNEM,MY_IBEN,ISBYT,IWID,IRET) + CALL X48(ISBYT,ISBYT,1) + CALL X48(IWID,IWID,1) + CALL X48(IRET,IRET,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = 0 - IWID = 8 + 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 + 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 + 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 + RETURN + END diff --git a/src/gettagpr.f b/src/gettagpr.f index 976a5bca..799121b8 100644 --- a/src/gettagpr.f +++ b/src/gettagpr.f @@ -39,47 +39,47 @@ C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE GETTAGPR - . ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET ) + RECURSIVE SUBROUTINE GETTAGPR + . ( LUNIT, TAGCH, NTAGCH, TAGPR, IRET ) - USE MODA_USRINT - USE MODA_MSGCWD - USE MODA_TABLES + USE MODA_USRINT + USE MODA_MSGCWD + USE MODA_TABLES USE MODV_IM8B - CHARACTER*(*) TAGCH, TAGPR + CHARACTER*(*) TAGCH, TAGPR C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84 ( LUNIT, MY_LUNIT, 1 ) - CALL X84 ( NTAGCH, MY_NTAGCH, 1 ) - CALL GETTAGPR ( MY_LUNIT, TAGCH, MY_NTAGCH, TAGPR, IRET ) - CALL X48 ( IRET, IRET, 1 ) + CALL X84 ( LUNIT, MY_LUNIT, 1 ) + CALL X84 ( NTAGCH, MY_NTAGCH, 1 ) + CALL GETTAGPR ( MY_LUNIT, TAGCH, MY_NTAGCH, TAGPR, IRET ) + CALL X48 ( IRET, IRET, 1 ) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = -1 + IRET = -1 -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS( LUNIT, LUN, IL, IM ) - IF ( IL .EQ. 0 ) RETURN - IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN + 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. +C Get TAGPR from the (NTAGCH)th occurrence of TAGCH. - CALL FSTAG( LUN, TAGCH, NTAGCH, 1, NCH, IRET ) - IF ( IRET .NE. 0 ) RETURN + CALL FSTAG( LUN, TAGCH, NTAGCH, 1, NCH, IRET ) + IF ( IRET .NE. 0 ) RETURN - TAGPR = TAG(JMPB(INV(NCH,LUN))) + TAGPR = TAG(JMPB(INV(NCH,LUN))) - RETURN - END + RETURN + END diff --git a/src/gettagre.f b/src/gettagre.f index 1cf2bec9..ae927f4f 100644 --- a/src/gettagre.f +++ b/src/gettagre.f @@ -40,60 +40,60 @@ C> | 2016-06-07 | J. Ator | Original author | C> | 2022-08-04 | J. Woollen | Added 8-byte wrapper | - RECURSIVE SUBROUTINE GETTAGRE - . ( LUNIT, TAGI, NTAGI, TAGRE, NTAGRE, IRET ) + RECURSIVE SUBROUTINE GETTAGRE + . ( LUNIT, TAGI, NTAGI, TAGRE, NTAGRE, IRET ) - USE MODA_USRINT - USE MODA_MSGCWD - USE MODA_TABLES + USE MODA_USRINT + USE MODA_MSGCWD + USE MODA_TABLES USE MODV_IM8B - CHARACTER*(*) TAGI, TAGRE + CHARACTER*(*) TAGI, TAGRE - CHARACTER*10 TAGTMP + CHARACTER*10 TAGTMP C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LUNIT,MY_LUNIT,1) - CALL X84(NTAGI,MY_NTAGI,1) - CALL GETTAGRE(MY_LUNIT,TAGI,MY_NTAGI,TAGRE,NTAGRE,IRET) - CALL X48(NTAGRE,NTAGRE,1) - CALL X48(IRET,IRET,1) + CALL X84(LUNIT,MY_LUNIT,1) + CALL X84(NTAGI,MY_NTAGI,1) + CALL GETTAGRE(MY_LUNIT,TAGI,MY_NTAGI,TAGRE,NTAGRE,IRET) + CALL X48(NTAGRE,NTAGRE,1) + CALL X48(IRET,IRET,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = -1 + IRET = -1 -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS( LUNIT, LUN, IL, IM ) - IF ( IL .EQ. 0 ) RETURN - IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN + 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. +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 + 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 + RETURN + END diff --git a/src/gettbh.f b/src/gettbh.f index 5c877a99..89a9c3f9 100644 --- a/src/gettbh.f +++ b/src/gettbh.f @@ -37,57 +37,57 @@ C> | -----|------------|----------| C> | 2007-01-19 | J. Ator | Original author | C> - SUBROUTINE GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) + SUBROUTINE GETTBH ( LUNS, LUNL, TAB, IMT, IMTV, IOGCE, ILTV ) - CHARACTER*128 BORT_STR - CHARACTER*40 HEADER - CHARACTER*30 TAGS(5), LABEL - CHARACTER*3 CFTYP - CHARACTER*2 CTTYP - CHARACTER*1 TAB + CHARACTER*128 BORT_STR + CHARACTER*40 HEADER + CHARACTER*30 TAGS(5), LABEL + CHARACTER*3 CFTYP + CHARACTER*2 CTTYP + CHARACTER*1 TAB - LOGICAL BADLABEL + LOGICAL BADLABEL C----------------------------------------------------------------------- -C Statement function to check for bad header line label: +C Statement function to check for bad header line label: - BADLABEL ( LABEL ) = ( ( INDEX ( LABEL, CTTYP ) .EQ. 0 ) .OR. - . ( INDEX ( LABEL, CFTYP ) .EQ. 0 ) ) + BADLABEL ( LABEL ) = ( ( INDEX ( LABEL, CTTYP ) .EQ. 0 ) .OR. + . ( INDEX ( LABEL, CFTYP ) .EQ. 0 ) ) C----------------------------------------------------------------------- - CTTYP = TAB // ' ' + CTTYP = TAB // ' ' -C Read and parse the header line of the standard file. +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 = '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) ) - 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. +C Read and parse the header line of the local file. - IF ( IMT .NE. IMT2 ) GOTO 901 + 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) ) - RETURN +C Verify that both files are for the same master table. - 900 WRITE(BORT_STR,'("BUFRLIB: GETTBH - BAD OR MISSING HEADER '// + 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 '// + 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 + CALL BORT(BORT_STR) + END diff --git a/src/getvalnb.f b/src/getvalnb.f index e86154cb..6e3da108 100644 --- a/src/getvalnb.f +++ b/src/getvalnb.f @@ -55,59 +55,59 @@ C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION GETVALNB - . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB ) - . RESULT ( R8VAL ) + RECURSIVE FUNCTION GETVALNB + . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB ) + . RESULT ( R8VAL ) USE MODV_BMISS - USE MODV_IM8B + USE MODV_IM8B - USE MODA_USRINT - USE MODA_MSGCWD - USE MODA_TABLES + USE MODA_USRINT + USE MODA_MSGCWD + USE MODA_TABLES - CHARACTER*(*) TAGPV, TAGNB + CHARACTER*(*) TAGPV, TAGNB - REAL*8 R8VAL + REAL*8 R8VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LUNIT,MY_LUNIT,1) - CALL X84(NTAGPV,MY_NTAGPV,1) - CALL X84(NTAGNB,MY_NTAGNB,1) - R8VAL=GETVALNB(MY_LUNIT,TAGPV,MY_NTAGPV,TAGNB,MY_NTAGNB) + CALL X84(LUNIT,MY_LUNIT,1) + CALL X84(NTAGPV,MY_NTAGPV,1) + CALL X84(NTAGNB,MY_NTAGNB,1) + R8VAL=GETVALNB(MY_LUNIT,TAGPV,MY_NTAGPV,TAGNB,MY_NTAGNB) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - R8VAL = BMISS + R8VAL = BMISS -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS (LUNIT, LUN, IL, IM ) - IF ( IL .GE. 0 ) RETURN - IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN + 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. +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 + 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. +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 + CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IRET ) + IF ( IRET .NE. 0 ) RETURN - R8VAL = VAL(NNB,LUN) - - RETURN - END + R8VAL = VAL(NNB,LUN) + + RETURN + END diff --git a/src/getwin.f b/src/getwin.f index eae0df11..51a31647 100644 --- a/src/getwin.f +++ b/src/getwin.f @@ -16,7 +16,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/ibfms.f b/src/ibfms.f index af6821f7..3798f898 100644 --- a/src/ibfms.f +++ b/src/ibfms.f @@ -35,20 +35,20 @@ C> | 2009-03-23 | J. Ator | Increased value of BDIFD for better test accuracy | C> | 2012-10-05 | J. Ator | Modified to reflect the fact that the "missing" value is now configurable by users (may be something other than 10E10) | C> - INTEGER FUNCTION IBFMS ( R8VAL ) + INTEGER FUNCTION IBFMS ( R8VAL ) USE MODV_BMISS - REAL*8 R8VAL + REAL*8 R8VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- - IF ( R8VAL .EQ. BMISS ) THEN - IBFMS = 1 - ELSE - IBFMS = 0 - ENDIF + IF ( R8VAL .EQ. BMISS ) THEN + IBFMS = 1 + ELSE + IBFMS = 0 + ENDIF - RETURN - END + RETURN + END diff --git a/src/icbfms.f b/src/icbfms.f index b255a57e..f871b041 100644 --- a/src/icbfms.f +++ b/src/icbfms.f @@ -29,75 +29,75 @@ C> | 2016-02-12 | J. Ator | Modified for CRAYFTN compatibility | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION ICBFMS ( STR, LSTR ) RESULT ( IRET ) + RECURSIVE FUNCTION ICBFMS ( STR, LSTR ) RESULT ( IRET ) - USE MODV_IM8B + USE MODV_IM8B - CHARACTER*(*) STR + CHARACTER*(*) STR - CHARACTER*8 STRZ - REAL*8 RL8Z + CHARACTER*8 STRZ + REAL*8 RL8Z - CHARACTER*16 ZZ + CHARACTER*16 ZZ - CHARACTER*16 ZM_BE - PARAMETER ( ZM_BE = '202020E076483742' ) -C* 10E10 stored as hexadecimal on a big-endian system. + 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. + CHARACTER*16 ZM_LE + PARAMETER ( ZM_LE = '42374876E8000000' ) +C* 10E10 stored as hexadecimal on a little-endian system. - EQUIVALENCE(STRZ,RL8Z) + EQUIVALENCE(STRZ,RL8Z) C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF ( IM8B ) THEN - IM8B = .FALSE. + IF ( IM8B ) THEN + IM8B = .FALSE. - CALL X84 ( LSTR, MY_LSTR, 1 ) - IRET = ICBFMS ( STR, MY_LSTR ) + CALL X84 ( LSTR, MY_LSTR, 1 ) + IRET = ICBFMS ( STR, MY_LSTR ) - IM8B = .TRUE. - RETURN - END IF + IM8B = .TRUE. + RETURN + END IF - IRET = 0 + IRET = 0 - NUMCHR = MIN(LSTR,LEN(STR)) + 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. +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 - IRET = 1 - RETURN - END IF - END IF + 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 + IRET = 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. +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 + DO I=1,NUMCHR + IF ( IUPM(STR(I:I),8).NE.255 ) RETURN + ENDDO - IRET = 1 + IRET = 1 - RETURN - END + RETURN + END diff --git a/src/ichkstr.f b/src/ichkstr.f index 25757a7c..63a59c52 100644 --- a/src/ichkstr.f +++ b/src/ichkstr.f @@ -2,7 +2,7 @@ C> @brief Check for equivalence between a character array and a C> character string. C> @author Ator @date 2005-11-29 - + C> 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 @@ -20,29 +20,29 @@ C> - 1 STR(1:N) and (CHR(I),I=1,N) are not equivalent. C> C> @author Ator @date 2005-11-29 - FUNCTION ICHKSTR(STR,CHR,N) + FUNCTION ICHKSTR(STR,CHR,N) - CHARACTER*(*) STR + CHARACTER*(*) STR - CHARACTER*80 CSTR - CHARACTER*1 CHR(N) + 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. +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) + CALL CHRTRNA(CSTR,CHR,N) -C Compare CSTR to STR. +C Compare CSTR to STR. - IF(CSTR(1:N).EQ.STR(1:N)) THEN - ICHKSTR = 0 - ELSE - ICHKSTR = 1 - ENDIF + IF(CSTR(1:N).EQ.STR(1:N)) THEN + ICHKSTR = 0 + ELSE + ICHKSTR = 1 + ENDIF - RETURN - END + RETURN + END diff --git a/src/icmpdx.f b/src/icmpdx.f index 7d0d6cbc..2d721136 100644 --- a/src/icmpdx.f +++ b/src/icmpdx.f @@ -17,7 +17,7 @@ C> with first BUFR file C> @param[in] LUN -- integer: Internal I/O stream index associated C> with second BUFR file -C> @returns icmpdx -- integer: Flag indicating whether the +C> @returns icmpdx -- integer: Flag indicating whether the C> BUFR file associated with LUD and the BUFR C> file associated with LUN have the same DX C> BUFR table information @@ -47,25 +47,25 @@ INTEGER FUNCTION ICMPDX(LUD,LUN) C all identical between the two units. IF ( ( NTBA(LUD) .EQ. 0 ) .OR. - . ( NTBA(LUN) .NE. NTBA(LUD) ) ) RETURN + . ( 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 + 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 + 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 + 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 + . ( 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 + IF ( IDND(I,LUN) .NE. IDND(I,LUD) ) RETURN + IF ( TABD(I,LUN) .NE. TABD(I,LUD) ) RETURN ENDDO ICMPDX = 1 diff --git a/src/icopysb.f b/src/icopysb.f index a3443d06..df0b7a38 100644 --- a/src/icopysb.f +++ b/src/icopysb.f @@ -1,6 +1,6 @@ C> @file C> @brief Copy a BUFR data subset. - + C> This function calls BUFRLIB subroutine copysb() and passes C> back its return code as the function value. C> @@ -33,14 +33,14 @@ RECURSIVE FUNCTION ICOPYSB(LUNIN,LUNOT) RESULT(IRET) USE MODV_IM8B IF(IM8B) THEN - IM8B=.FALSE. + IM8B=.FALSE. - CALL X84(LUNIN,MY_LUNIN,1) - CALL X84(LUNOT,MY_LUNOT,1) - IRET=ICOPYSB(MY_LUNIN,MY_LUNOT) + CALL X84(LUNIN,MY_LUNIN,1) + CALL X84(LUNOT,MY_LUNOT,1) + IRET=ICOPYSB(MY_LUNIN,MY_LUNOT) - IM8B=.TRUE. - RETURN + IM8B=.TRUE. + RETURN ENDIF CALL COPYSB(LUNIN,LUNOT,IRET) diff --git a/src/icvidx.c b/src/icvidx.c index 80a28bc9..3ffdb390 100644 --- a/src/icvidx.c +++ b/src/icvidx.c @@ -23,5 +23,5 @@ */ f77int icvidx( f77int *ii, f77int *jj, f77int *numjj ) { - return ( *numjj * (*ii) ) + *jj; + return ( *numjj * (*ii) ) + *jj; } diff --git a/src/idxmsg.f b/src/idxmsg.f index f6dd05ef..aab3d95f 100644 --- a/src/idxmsg.f +++ b/src/idxmsg.f @@ -21,38 +21,38 @@ C> | 2009-03-23 | J. Ator | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION IDXMSG( MESG ) RESULT( IRET ) + RECURSIVE FUNCTION IDXMSG( MESG ) RESULT( IRET ) - USE MODV_IM8B + USE MODV_IM8B - DIMENSION MESG(*) + DIMENSION MESG(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - IRET = IDXMSG( MESG ) + IRET = IDXMSG( MESG ) - IM8B=.TRUE. - RETURN - END IF + IM8B=.TRUE. + RETURN + END IF -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. +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. + 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 - IRET = 1 - ELSE - IRET = 0 - END IF + IRET = 1 + ELSE + IRET = 0 + END IF - RETURN - END + RETURN + END diff --git a/src/ifxy.f b/src/ifxy.f index 204bcbde..02ac16a5 100644 --- a/src/ifxy.f +++ b/src/ifxy.f @@ -29,7 +29,7 @@ C> = ( 2**13 + 2**12 + 2**11 + 2**10 + 2**9 + 2**8 + C> 2**4 + 2**2 + 2**1 ) C> -C> = 16150 +C> = 16150 C> C> Program History Log: C> | Date | Programmer | Comments | diff --git a/src/igetdate.f b/src/igetdate.f index fcd9a17b..a8e132f0 100644 --- a/src/igetdate.f +++ b/src/igetdate.f @@ -32,40 +32,40 @@ C> | 2005-11-29 | J. Ator | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION IGETDATE(MBAY,IYR,IMO,IDY,IHR) RESULT(IRET) + RECURSIVE FUNCTION IGETDATE(MBAY,IYR,IMO,IDY,IHR) RESULT(IRET) - USE MODV_IM8B + USE MODV_IM8B - COMMON /DATELN/ LENDAT + COMMON /DATELN/ LENDAT - DIMENSION MBAY(*) + DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - IRET=IGETDATE(MBAY,IYR,IMO,IDY,IHR) - CALL X48(IYR,IYR,1) - CALL X48(IMO,IMO,1) - CALL X48(IDY,IDY,1) - CALL X48(IHR,IHR,1) + IRET=IGETDATE(MBAY,IYR,IMO,IDY,IHR) + CALL X48(IYR,IYR,1) + CALL X48(IMO,IMO,1) + CALL X48(IDY,IDY,1) + CALL X48(IHR,IHR,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - 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 - IRET = (IYR*1000000) + (IMO*10000) + (IDY*100) + IHR + 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 + IRET = (IYR*1000000) + (IMO*10000) + (IDY*100) + IHR - RETURN - END + RETURN + END diff --git a/src/igetfxy.f b/src/igetfxy.f index 60b0b6ee..42084263 100644 --- a/src/igetfxy.f +++ b/src/igetfxy.f @@ -8,7 +8,7 @@ C> 2021-09-30 | J. Ator | Replace jstchr with Fortran intrinsic adjustl. C> C> @author Ator @date 2007-01-19 - + C> 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 @@ -22,47 +22,47 @@ C> - -1 could not find a valid FXY number in STR. C> C> @author Ator @date 2007-01-19 - FUNCTION IGETFXY ( STR, CFXY ) + FUNCTION IGETFXY ( STR, CFXY ) - CHARACTER*(*) STR - CHARACTER*6 CFXY + CHARACTER*(*) STR + CHARACTER*6 CFXY - PARAMETER ( LSTR2 = 120 ) - CHARACTER*(LSTR2) STR2 + PARAMETER ( LSTR2 = 120 ) + CHARACTER*(LSTR2) STR2 C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IGETFXY = -1 + IGETFXY = -1 - LSTR = LEN ( STR ) - IF ( LSTR .LT. 6 ) RETURN + LSTR = LEN ( STR ) + IF ( LSTR .LT. 6 ) RETURN -C Left-justify a copy of the input string. +C Left-justify a copy of the input string. - IF ( LSTR .GT. LSTR2 ) THEN - STR2(1:LSTR2) = STR(1:LSTR2) - ELSE - STR2 = STR - ENDIF - STR2 = ADJUSTL ( STR2 ) - IF ( STR2 .EQ. ' ' ) RETURN + IF ( LSTR .GT. LSTR2 ) THEN + STR2(1:LSTR2) = STR(1:LSTR2) + ELSE + STR2 = STR + ENDIF + STR2 = ADJUSTL ( STR2 ) + IF ( STR2 .EQ. ' ' ) RETURN -C Look for an FXY number. +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 + 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. +C Check that the FXY number is valid. - IF ( NUMBCK ( CFXY ) .EQ. 0 ) IGETFXY = 0 + IF ( NUMBCK ( CFXY ) .EQ. 0 ) IGETFXY = 0 - RETURN - END + RETURN + END diff --git a/src/igetntbi.f b/src/igetntbi.f index 371fbae8..9b0ae370 100644 --- a/src/igetntbi.f +++ b/src/igetntbi.f @@ -24,30 +24,30 @@ C> | 2009-03-23 | J. Ator | Original author | C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks | C> - FUNCTION IGETNTBI ( LUN, CTB ) + FUNCTION IGETNTBI ( LUN, CTB ) - USE MODA_TABABD + USE MODA_TABABD - CHARACTER*128 BORT_STR - CHARACTER*1 CTB + 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 + 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' + RETURN +900 WRITE(BORT_STR,'("BUFRLIB: IGETNTBI - NUMBER OF INTERNAL TABLE' . //'",A1," ENTRIES EXCEEDS THE LIMIT (",I4,")")') CTB, IMAX - CALL BORT(BORT_STR) - END + CALL BORT(BORT_STR) + END diff --git a/src/igetntbl.f b/src/igetntbl.f index 5dd29b6c..a20f336a 100644 --- a/src/igetntbl.f +++ b/src/igetntbl.f @@ -25,24 +25,24 @@ C> | -----|------------|----------| C> | 2007-01-19 | J. Ator | Original author | C> - FUNCTION IGETNTBL ( LUNT, LINE ) + FUNCTION IGETNTBL ( LUNT, LINE ) - CHARACTER*(*) LINE + 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 + 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 + IGETNTBL = 0 + RETURN - 100 IGETNTBL = -1 - RETURN + 100 IGETNTBL = -1 + RETURN - 200 IGETNTBL = -2 - RETURN + 200 IGETNTBL = -2 + RETURN - END + END diff --git a/src/igetprm.f b/src/igetprm.f index 50e455e2..6e72102d 100644 --- a/src/igetprm.f +++ b/src/igetprm.f @@ -80,95 +80,95 @@ C> | -----|------------|----------| C> | 2014-12-04 | J. Ator | Original author | C> - INTEGER FUNCTION IGETPRM ( CPRMNM ) + INTEGER FUNCTION IGETPRM ( CPRMNM ) - 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 + 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 - CHARACTER*(*) CPRMNM - CHARACTER*64 ERRSTR + 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 + 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 + RETURN + END diff --git a/src/igetrfel.f b/src/igetrfel.f index da71a1d5..0ebb1fef 100644 --- a/src/igetrfel.f +++ b/src/igetrfel.f @@ -9,7 +9,7 @@ C> 2017-04-03 | J. Ator | Add a dimension to all tco arrays so each subset definition in the jump/link table has its own set of table c operators. C> C> @author J Ator @date 2016-05-27 - + C> 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 @@ -25,219 +25,219 @@ C> element not found. C> C> @author J Ator @date 2016-05-27 - INTEGER FUNCTION IGETRFEL ( N, LUN ) + INTEGER FUNCTION IGETRFEL ( N, LUN ) - USE MODA_MSGCWD - USE MODA_USRINT - USE MODA_TABLES - USE MODA_BITMAPS - USE MODA_NRV203 + USE MODA_MSGCWD + USE MODA_USRINT + USE MODA_TABLES + USE MODA_BITMAPS + USE MODA_NRV203 - CHARACTER*128 BORT_STR - CHARACTER*6 CFLWOPR,ADN30,FXY - CHARACTER*1 TAB + CHARACTER*128 BORT_STR + CHARACTER*6 CFLWOPR,ADN30,FXY + CHARACTER*1 TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IGETRFEL = 0 + IGETRFEL = 0 - NODE = INV( N, LUN ) + 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 + 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 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 + 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 diff --git a/src/igettdi.f b/src/igettdi.f index e5e5890c..5db3de94 100644 --- a/src/igettdi.f +++ b/src/igettdi.f @@ -8,7 +8,7 @@ C> 2009-03-23 | J. Ator | Original author. C> C> @author Ator @date 2009-03-23 - + C> 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 @@ -26,35 +26,35 @@ C> current master table C> C> @author Ator @date 2009-03-23 - FUNCTION IGETTDI ( IFLAG ) + FUNCTION IGETTDI ( IFLAG ) - PARAMETER ( IDXMIN = 62976 ) -C* = IFXY('354000') + PARAMETER ( IDXMIN = 62976 ) +C* = IFXY('354000') - PARAMETER ( IDXMAX = 63231 ) -C* = IFXY('354255') + PARAMETER ( IDXMAX = 63231 ) +C* = IFXY('354255') - CHARACTER*128 BORT_STR + CHARACTER*128 BORT_STR - SAVE IDX + SAVE IDX C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IF ( IFLAG .EQ. 0 ) THEN + 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. +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 + 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 + RETURN + 900 CALL BORT('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') + END diff --git a/src/imrkopr.f b/src/imrkopr.f index b56c37ac..316a165e 100644 --- a/src/imrkopr.f +++ b/src/imrkopr.f @@ -28,10 +28,10 @@ INTEGER FUNCTION IMRKOPR(NEMO) 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 + + .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 diff --git a/src/inctab.f b/src/inctab.f index 21d955fb..9cc6fe96 100644 --- a/src/inctab.f +++ b/src/inctab.f @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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, diff --git a/src/inittbf.c b/src/inittbf.c index 610da9c3..3eb86063 100644 --- a/src/inittbf.c +++ b/src/inittbf.c @@ -28,11 +28,11 @@ void inittbf( void ) ** allocated yet? */ if ( cfe == NULL ) { - + mxmtbf = igetprm( "MXMTBF", 6 ); if ( ( cfe = malloc( mxmtbf * sizeof(struct code_flag_entry) ) ) - == NULL ) { + == NULL ) { bort( brtstr, ( f77int ) strlen( brtstr ) ); } } diff --git a/src/invcon.f b/src/invcon.f index 7d9cdd2f..1e252170 100644 --- a/src/invcon.f +++ b/src/invcon.f @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> This function searches a "window" (see below remarks) for an C> element identified in the user string as a conditional node. C> A conditional node is an element which must meet a condition in order to be @@ -25,7 +25,7 @@ C> C> @note: See getwin() for an explanation of "windows" within the context C> of a bufr data subset. -C> +C> C> @param[in] NC - integer: condition code: C> - 1 '=' (equal) C> - 2 '!' (not equal) diff --git a/src/invtag.f b/src/invtag.f index 504af4ca..bc294b55 100644 --- a/src/invtag.f +++ b/src/invtag.f @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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(), diff --git a/src/invwin.f b/src/invwin.f index a7c2ba52..c093da96 100644 --- a/src/invwin.f +++ b/src/invwin.f @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/iok2cpy.f b/src/iok2cpy.f index c946f6d4..5a762cb0 100644 --- a/src/iok2cpy.f +++ b/src/iok2cpy.f @@ -49,10 +49,10 @@ INTEGER FUNCTION IOK2CPY(LUI,LUO) C Do both logical units have the same internal table information? IF ( ICMPDX(LUI,LUO) .EQ. 1 ) THEN - IOK2CPY = 1 - RETURN + 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. diff --git a/src/iokoper.f b/src/iokoper.f index 0bda2757..1277e150 100644 --- a/src/iokoper.f +++ b/src/iokoper.f @@ -34,18 +34,18 @@ INTEGER FUNCTION IOKOPER(NEMO) 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 + + .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. + 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 + + THEN IOKOPER = 1 ELSE IOKOPER = IMRKOPR(NEMO) diff --git a/src/ipks.f b/src/ipks.f index c6806648..42d04a29 100644 --- a/src/ipks.f +++ b/src/ipks.f @@ -27,53 +27,53 @@ C> - This function is the logical inverse of function ups(). C> C> @author J. Ator @date 2012-03-02 - FUNCTION IPKS(VAL,NODE) + FUNCTION IPKS(VAL,NODE) - USE MODA_TABLES - USE MODA_NRV203 + USE MODA_TABLES + USE MODA_NRV203 integer(8) imask, ipks - REAL*8 TEN,VAL + REAL*8 TEN,VAL - DATA TEN /10./ + DATA TEN /10./ C----------------------------------------------------------------------- - IPKS = VAL * TEN**ISC(NODE) - IRF(NODE) + .5 + IPKS = VAL * TEN**ISC(NODE) - IRF(NODE) + .5 - IF ( NNRV .GT. 0 ) THEN + 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. +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 + 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. +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_8**(IBT(NODE)-1) - IPKS = IOR(ABS(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 + NRV(JJ) = NINT(VAL) + IF ( NRV(JJ) .LT. 0 ) THEN + IMASK = 2_8**(IBT(NODE)-1) + IPKS = IOR(ABS(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. +C The corresponding redefinded reference value needs to +C be used when encoding this value. - IPKS = VAL * TEN**ISC(NODE) - NRV(JJ) + .5 - RETURN - END IF - END DO + IPKS = VAL * TEN**ISC(NODE) - NRV(JJ) + .5 + RETURN + END IF + END DO - END IF + END IF - RETURN - END + RETURN + END diff --git a/src/ireadmt.f b/src/ireadmt.f index 9ceca2eb..18d6eaa1 100644 --- a/src/ireadmt.f +++ b/src/ireadmt.f @@ -24,7 +24,7 @@ C> - 0 = No C> - 1 = Yes C> -C>

Information about the location of master BUFR tables on the +C>

Information about the location of master BUFR tables on the C> local file system is obtained from the most recent call to C> subroutine mtinfo(), or else from subroutine bfrini() if C> subroutine mtinfo() was never called, and in which case Fortran @@ -39,208 +39,208 @@ C> | 2017-10-13 | J. Ator | Add functionality to check whether new master tables need to be read (this functionality was previously part of subroutine reads3()) | C> | 2018-04-09 | J. Ator | Only read master B and D tables when Section 3 is being used for decoding | C> - INTEGER FUNCTION IREADMT ( LUN ) + INTEGER FUNCTION IREADMT ( LUN ) USE MODV_MAXNC USE MODV_MAXCD USE MODV_MXMTBB USE MODV_MXMTBD - USE MODA_MSTABS - USE MODA_BITBUF - USE MODA_RDMTB - USE MODA_SC3BFR + USE MODA_MSTABS + USE MODA_BITBUF + USE MODA_RDMTB + USE MODA_SC3BFR - COMMON /QUIET/ IPRT - COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR - COMMON /TABLEF/ CDMF + 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 + 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/ + DATA LMT /-99/ - SAVE LMT, LMTV, LOGCE, LMTVL + 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 + 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 + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + CALL ERRWRT('BUFRLIB: IREADMT - OPENING/READING MASTER TABLES') + ENDIF - IF ( ISC3(LUN) .NE. 0 ) THEN + 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. +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 + 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. +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 ) + 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. +C* Close the master Table B files. - CLOSE ( UNIT = LUN1 ) - CLOSE ( UNIT = LUN2 ) + 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. +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 + 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. +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 + 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. +C* Close the master Table D files. - CLOSE ( UNIT = LUN1 ) - CLOSE ( UNIT = LUN2 ) + CLOSE ( UNIT = LUN1 ) + CLOSE ( UNIT = LUN2 ) -C* Copy master table B and D information into internal C arrays. +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 + CALL CPMSTABS ( NMTB, IBFXYN, CBSCL, CBSREF, CBBW, CBUNIT, + . CBMNEM, CBELEM, NMTD, IDFXYN, CDSEQ, CDMNEM, + . NDELEM, IDEFXY, MAXCD ) + ENDIF - IF ( CDMF .EQ. 'Y' ) THEN + 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. +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 + 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. +C* Read the master code and flag table files. - CALL RDMTBF ( LUN1, LUN2 ) + CALL RDMTBF ( LUN1, LUN2 ) -C* Close the master code and flag table files. +C* Close the master code and flag table files. - CLOSE ( UNIT = LUN1 ) - CLOSE ( UNIT = LUN2 ) + CLOSE ( UNIT = LUN1 ) + CLOSE ( UNIT = LUN2 ) - ENDIF + ENDIF - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') + 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 + 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 diff --git a/src/ireadns.f b/src/ireadns.f index db8fe29f..73dde339 100644 --- a/src/ireadns.f +++ b/src/ireadns.f @@ -18,7 +18,7 @@ C> BUFR message containing data subset that C> was read, in format of either C> YYMMDDHH or YYYYMMDDHH, depending on the most -C> recent call to subroutine datelen() +C> recent call to subroutine datelen() C> @returns ireadns -- integer: C> - 0 = new BUFR data subset was successfully C> read into internal arrays diff --git a/src/ireadsb.f b/src/ireadsb.f index 76acf216..2bd96ccc 100644 --- a/src/ireadsb.f +++ b/src/ireadsb.f @@ -11,8 +11,8 @@ C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | C> C> @author J. Woollen @date 1994-01-06 - -C> This function calls BUFRLIB subroutine readsb() and + +C> This function calls BUFRLIB subroutine readsb() and C> passes back its return code as the function value. C> C> @remarks @@ -35,7 +35,7 @@ RECURSIVE FUNCTION IREADSB(LUNIT) RESULT(IRET) C----------------------------------------------------------------------- C----------------------------------------------------------------------- - + C Check for I8 integers. IF(IM8B) THEN diff --git a/src/irev.F b/src/irev.F index c2e6dca2..321acb38 100644 --- a/src/irev.F +++ b/src/irev.F @@ -1,6 +1,6 @@ C> @file C> @brief Return a copy of an input integer word with -C> the bytes reversed. +C> the bytes reversed. C> C> ### Program History Log C> Date | Programmer | Comments @@ -12,7 +12,7 @@ C> 2007-01-19 | J. Ator | Big-endian vs. little-endian determined at compile time. C> C> @author Woollen @date 1994-01-06 - + C> This function will, when the local machine is "little-endian" (i.e., C> when it uses a right to left scheme for numbering the bytes C> within a machine word), return a copy of an input integer word with diff --git a/src/isetprm.f b/src/isetprm.f index a003de96..77487b60 100644 --- a/src/isetprm.f +++ b/src/isetprm.f @@ -66,9 +66,9 @@ C> overwritten within an output BUFR C> message C> - 'MXBTM' = Maximum number of bitmaps that can be -C> stored internally for a BUFR subset +C> stored internally for a BUFR subset C> - 'MXBTMSE' = Maximum number of entries that can -C> be set within a bitmap +C> be set within a bitmap C> - 'MXTAMC' = Maximum number of Table A mnemonics C> in the internal jump/link table which C> contain at least one Table C operator @@ -77,7 +77,7 @@ C> with XX >= 21 in the subset definition C> of a Table A mnemonic C> - 'MXNRV' = Maximum number of 2-03 reference -C> values in the internal jump/link +C> values in the internal jump/link C> table C> - 'MXRST' = Maximum number of long character C> strings that can be read from a @@ -97,109 +97,109 @@ C> | 2017-10-17 | J. Ator | Add MXMTBF | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION ISETPRM ( CPRMNM, IPVAL ) RESULT ( IRET ) + RECURSIVE FUNCTION ISETPRM ( CPRMNM, IPVAL ) RESULT ( IRET ) - 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 - USE MODV_IM8B + 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 + USE MODV_IM8B - CHARACTER*(*) CPRMNM - CHARACTER*128 ERRSTR + CHARACTER*(*) CPRMNM + CHARACTER*128 ERRSTR C----------------------------------------------------------------------- C----------------------------------------------------------------------- C Check for I8 integers. - IF ( IM8B ) THEN - IM8B = .FALSE. + IF ( IM8B ) THEN + IM8B = .FALSE. - CALL X84 ( IPVAL, MY_IPVAL, 1 ) - IRET = ISETPRM ( CPRMNM, MY_IPVAL ) + CALL X84 ( IPVAL, MY_IPVAL, 1 ) + IRET = ISETPRM ( CPRMNM, MY_IPVAL ) - IM8B = .TRUE. - RETURN - ENDIF + IM8B = .TRUE. + RETURN + ENDIF - IRET = 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 - IRET = -1 - CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') - ERRSTR = 'BUFRLIB: ISETPRM - UNKNOWN INPUT PARAMETER '// - . CPRMNM // ' -- NO ACTION WAS TAKEN' - CALL ERRWRT(ERRSTR) - CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') - ENDIF + IRET = 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 + IRET = -1 + CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') + ERRSTR = 'BUFRLIB: ISETPRM - UNKNOWN INPUT PARAMETER '// + . CPRMNM // ' -- NO ACTION WAS TAKEN' + CALL ERRWRT(ERRSTR) + CALL ERRWRT('++++++++++++++++++WARNING+++++++++++++++++++') + ENDIF - RETURN - END + RETURN + END diff --git a/src/ishrdx.f b/src/ishrdx.f index 3a5a8da8..d27b152f 100644 --- a/src/ishrdx.f +++ b/src/ishrdx.f @@ -41,19 +41,19 @@ INTEGER FUNCTION ISHRDX(LUD,LUN) 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 + + ( 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 + ISHRDX = 0 ENDIF RETURN diff --git a/src/isize.f b/src/isize.f index f6040a4c..2efe4bff 100644 --- a/src/isize.f +++ b/src/isize.f @@ -9,7 +9,7 @@ C> 2016-02-12 | J. Ator | Modified for crayftn compatibility. C> C> @author Ator @date 2009-03-23 - + C> 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 @@ -21,21 +21,21 @@ C> as a string C> C> @author Ator @date 2009-03-23 - INTEGER FUNCTION ISIZE (NUM) + INTEGER FUNCTION ISIZE (NUM) - CHARACTER*128 BORT_STR + 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) + 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 + RETURN + END diff --git a/src/istdesc.f b/src/istdesc.f index 6989db43..68ae3db8 100644 --- a/src/istdesc.f +++ b/src/istdesc.f @@ -22,29 +22,29 @@ C> | -----|------------|----------| C> | 2004-08-18 | J. Ator | Original author | C> - FUNCTION ISTDESC( IDN ) + FUNCTION ISTDESC( IDN ) - CHARACTER*6 ADSC, ADN30 + CHARACTER*6 ADSC, ADN30 - ADSC = ADN30( IDN, 6 ) + ADSC = ADN30( IDN, 6 ) - READ(ADSC,'(I1,I2,I3)') IF,IX,IY - IF ( IF .EQ. 1 ) THEN + 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. +C ADSC IS A REPLICATION DESCRIPTOR AND THEREFORE STANDARD +C BY DEFAULT. - ISTDESC = 1 - ELSE IF ( IF .EQ. 2 ) THEN + ISTDESC = 1 + ELSE IF ( IF .EQ. 2 ) THEN -C ADSC IS AN OPERATOR DESCRIPTOR +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 + ISTDESC = IOKOPER( ADSC ) + ELSE IF ( ( IX .LT. 48 ) .AND. ( IY .LT. 192 ) ) THEN + ISTDESC = 1 + ELSE + ISTDESC = 0 + END IF - RETURN - END + RETURN + END diff --git a/src/iupbs01.f b/src/iupbs01.f index b4af2486..b6dd6257 100644 --- a/src/iupbs01.f +++ b/src/iupbs01.f @@ -67,106 +67,106 @@ C> - 'SECO' = Second C> @returns iupbs01 -- integer: Value corresponding to S01MNEM C> - -1 = S01MNEM was invalid for the edition of BUFR -C> message in MBAY, or some other error +C> message in MBAY, or some other error C> occurred C> C> @author J. Ator @date 2005-11-29 - RECURSIVE FUNCTION IUPBS01(MBAY,S01MNEM) RESULT(IRET) + RECURSIVE FUNCTION IUPBS01(MBAY,S01MNEM) RESULT(IRET) - USE MODV_IM8B + USE MODV_IM8B - DIMENSION MBAY(*) + DIMENSION MBAY(*) - CHARACTER*(*) S01MNEM + CHARACTER*(*) S01MNEM - LOGICAL OK4CENT + LOGICAL OK4CENT C----------------------------------------------------------------------- -C This statement function checks whether its input value contains +C This statement function checks whether its input value contains C a valid century value. - OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21)) + OK4CENT(IVAL) = ((IVAL.GE.19).AND.(IVAL.LE.21)) C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - IRET = IUPBS01(MBAY,S01MNEM) + IRET = IUPBS01(MBAY,S01MNEM) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF -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. +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 + CALL WRDLEN -C Handle some simple requests that do not depend on the BUFR +C Handle some simple requests that do not depend on the BUFR C edition number. - IF(S01MNEM.EQ.'LENM') THEN - IRET = IUPB(MBAY,5,24) - RETURN - ENDIF + IF(S01MNEM.EQ.'LENM') THEN + IRET = IUPB(MBAY,5,24) + RETURN + ENDIF - LEN0 = 8 - IF(S01MNEM.EQ.'LEN0') THEN - IRET = LEN0 - RETURN - ENDIF + LEN0 = 8 + IF(S01MNEM.EQ.'LEN0') THEN + IRET = LEN0 + RETURN + ENDIF -C Get the BUFR edition number. +C Get the BUFR edition number. - IBEN = IUPB(MBAY,8,8) - IF(S01MNEM.EQ.'BEN') THEN - IRET = IBEN - RETURN - ENDIF + IBEN = IUPB(MBAY,8,8) + IF(S01MNEM.EQ.'BEN') THEN + IRET = IBEN + RETURN + ENDIF -C Use the BUFR edition number to handle any other requests. +C Use the BUFR edition number to handle any other requests. - CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRETGS) - IF(IRETGS.EQ.0) THEN - IRET = IUPB(MBAY,LEN0+ISBYT,IWID) - IF(S01MNEM.EQ.'CENT') THEN + CALL GETS1LOC(S01MNEM,IBEN,ISBYT,IWID,IRETGS) + IF(IRETGS.EQ.0) THEN + IRET = IUPB(MBAY,LEN0+ISBYT,IWID) + IF(S01MNEM.EQ.'CENT') THEN -C Test whether the returned value was a valid -C century value. +C Test whether the returned value was a valid +C century value. - IF(.NOT.OK4CENT(IRET)) IRET = -1 + IF(.NOT.OK4CENT(IRET)) IRET = -1 ENDIF ELSE IF( (S01MNEM.EQ.'YEAR') .AND. (IBEN.LT.4) ) THEN -C Calculate the 4-digit year. +C Calculate the 4-digit year. - IYOC = IUPB(MBAY,21,8) - ICEN = IUPB(MBAY,26,8) + IYOC = IUPB(MBAY,21,8) + ICEN = IUPB(MBAY,26,8) -C Does ICEN contain a valid century value? +C Does ICEN contain a valid century value? - IF(OK4CENT(ICEN)) THEN + 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 - IRET = (ICEN-1)*100 + IYOC - ELSE + IRET = (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. - IRET = I4DY(MOD(IYOC,100)*1000000)/10**6 - ENDIF - ELSE - IRET = -1 - ENDIF + IRET = I4DY(MOD(IYOC,100)*1000000)/10**6 + ENDIF + ELSE + IRET = -1 + ENDIF - RETURN - END + RETURN + END diff --git a/src/lcmgdf.f b/src/lcmgdf.f index 99ac3030..764df0c5 100644 --- a/src/lcmgdf.f +++ b/src/lcmgdf.f @@ -13,7 +13,7 @@ C> BUFR file C> @param[in] SUBSET -- character*8: Table A mnemonic of message C> type to be checked -C> @returns lcmgdf -- integer: +C> @returns lcmgdf -- integer: C> - 0 = SUBSET does not contain any long C> character strings C> - 1 = SUBSET contains at least one long @@ -69,7 +69,7 @@ RECURSIVE FUNCTION LCMGDF(LUNIT,SUBSET) RESULT(IRET) 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) diff --git a/src/lstjpb.f b/src/lstjpb.f index c046f058..a7bc5123 100644 --- a/src/lstjpb.f +++ b/src/lstjpb.f @@ -14,18 +14,18 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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> same node. C> C> @note See tabsub() for an C> explanation of the various node types present within an internal -C> jump/link table. +C> jump/link table. C> C> @param[in] NODE - integer: jump/link table index of entry to begin C> searching backwards from diff --git a/src/makestab.f b/src/makestab.f index 03f3fd50..bfdd9fdb 100644 --- a/src/makestab.f +++ b/src/makestab.f @@ -117,7 +117,7 @@ SUBROUTINE MAKESTAB C logical unit IOLUN(LUS(LUN)). IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN - XTAB(LUN) = .FALSE. + XTAB(LUN) = .FALSE. CALL CPBFDX(LUS(LUN),LUN) ELSE LUS(LUN) = (-1)*LUS(LUN) @@ -131,7 +131,7 @@ SUBROUTINE MAKESTAB C information at one point in the past, allow them to do C so again. - XTAB(LUN) = .FALSE. + XTAB(LUN) = .FALSE. LUS(LUN) = ABS(LUS(LUN)) CALL CPBFDX(LUS(LUN),LUN) ENDIF @@ -145,7 +145,7 @@ SUBROUTINE MAKESTAB IF(IOLUN(LUS(LUN)).EQ.0) THEN LUS(LUN) = 0 ELSE IF( XTAB(LUS(LUN)) .AND. - + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN + + (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 @@ -192,14 +192,14 @@ SUBROUTINE MAKESTAB ENDDO ENDIF - IF(LUS(LUN).LE.0) THEN + 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) + CALL CHEKSTAB(LUN) + DO ITBA=1,NTBA(LUN) INOD = NTAB+1 NEMO = TABA(ITBA,LUN)(4:11) CALL TABSUB(LUN,NEMO) @@ -207,7 +207,7 @@ SUBROUTINE MAKESTAB ISC(INOD) = NTAB ENDDO ELSE IF( XTAB(LUS(LUN)) .AND. - + (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN + + (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 @@ -218,10 +218,10 @@ SUBROUTINE MAKESTAB C itself with a copy of the new table information. LUNIT = ABS(IOLUN(LUN)) - IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT) + IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT) CALL CPBFDX(LUS(LUN),LUN) LUNDX = ABS(IOLUN(LUS(LUN))) - CALL WRDXTB(LUNDX,LUNIT) + CALL WRDXTB(LUNDX,LUNIT) ENDIF ENDIF diff --git a/src/mesgbc.f b/src/mesgbc.f index 21ac0657..b4a88bbe 100644 --- a/src/mesgbc.f +++ b/src/mesgbc.f @@ -100,7 +100,7 @@ RECURSIVE SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) IREC = 0 -C CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET +C CALL OPENBF SINCE FILE IS NOT OPEN TO THE C INTERFACE YET C --------------------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) @@ -114,7 +114,7 @@ RECURSIVE SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) IREC = IREC + 1 - MESGTYP = IUPBS01(MGWA,'MTYP') + MESGTYP = IUPBS01(MGWA,'MTYP') IF((IDXMSG(MGWA).EQ.1).OR.(IUPBS3(MGWA,'NSUB').EQ.0)) GOTO 1 @@ -129,7 +129,7 @@ RECURSIVE SUBROUTINE MESGBC(LUNIN,MESGTYP,ICOMP) MGWA(I) = MBAY(I,LUN) ENDDO - MESGTYP = IUPBS01(MGWA,'MTYP') + MESGTYP = IUPBS01(MGWA,'MTYP') END IF diff --git a/src/mesgbf.f b/src/mesgbf.f index 4a30484c..4134dc78 100644 --- a/src/mesgbf.f +++ b/src/mesgbf.f @@ -66,7 +66,7 @@ RECURSIVE SUBROUTINE MESGBF(LUNIT,MESGTYP) MESGTYP = -1 -C SINCE OPENBF HAS NOT YET BEEN CALLED, CALL IT +C SINCE OPENBF HAS NOT YET BEEN CALLED, CALL IT C --------------------------------------------- CALL OPENBF(LUNIT,'INX',LUNIT) @@ -82,7 +82,7 @@ RECURSIVE SUBROUTINE MESGBF(LUNIT,MESGTYP) C CLOSE THE FILE C -------------- - + CALL CLOSBF(LUNIT) C EXIT diff --git a/src/moda_bitbuf.F b/src/moda_bitbuf.F index 5da79ae8..38163b26 100644 --- a/src/moda_bitbuf.F +++ b/src/moda_bitbuf.F @@ -8,18 +8,18 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODA_BITBUF + MODULE MODA_BITBUF C> Maximum length of an output BUFR message. - INTEGER :: MAXBYT + INTEGER :: MAXBYT C> Bit pointer within IBAY. - INTEGER :: IBIT + INTEGER :: IBIT C> Current data subset. - INTEGER, ALLOCATABLE :: IBAY(:) + INTEGER, ALLOCATABLE :: IBAY(:) C> Length (in bytes) of current BUFR message for each internal C> I/O stream. - INTEGER, ALLOCATABLE :: MBYT(:) + INTEGER, ALLOCATABLE :: MBYT(:) C> Current BUFR message for each internal I/O stream. - INTEGER, ALLOCATABLE :: MBAY(:,:) + INTEGER, ALLOCATABLE :: MBAY(:,:) - END MODULE + END MODULE diff --git a/src/moda_bitmaps.F b/src/moda_bitmaps.F index 556faf34..bd813fe4 100644 --- a/src/moda_bitmaps.F +++ b/src/moda_bitmaps.F @@ -11,11 +11,11 @@ C> @author J. Ator C> @date 2016-05-27 - MODULE MODA_BITMAPS + MODULE MODA_BITMAPS C> Number of stored bitmaps for the current data subset C> (up to a maximum of MXBTM). - INTEGER :: NBTM + INTEGER :: NBTM C> 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 XX value of 21 or greater in their data @@ -23,40 +23,40 @@ MODULE MODA_BITMAPS C> value of 21 or greater are tracked within this module, C> since all others are automatically processed within C> subroutines tabsub() and tabent(). - INTEGER :: NTAMC + INTEGER :: NTAMC C> Most recent jump/link table entry that was processed by C> function igetrfel() and whose corresponding value type C> was either numeric or CCITT IA5. - INTEGER :: LSTNOD + INTEGER :: LSTNOD C> Current count of consecutive occurrences of lstnod. - INTEGER :: LSTNODCT + INTEGER :: LSTNODCT C> TRUE if a bitmap is in the process of being read for C> the current data subset. - LOGICAL :: LINBTM + LOGICAL :: LINBTM C> Entries within jump/link table which contain Table A C> mnemonics. - INTEGER, ALLOCATABLE :: INODTAMC(:) + INTEGER, ALLOCATABLE :: INODTAMC(:) C> Number of Table C operators (with an XX value of 21 or C> greater) within the data subset definition of the C> corresponding Table A mnemonic in inodtamc. - INTEGER, ALLOCATABLE :: NTCO(:) + INTEGER, ALLOCATABLE :: NTCO(:) C> Table C operators corresponding to inodtco. - CHARACTER*6, ALLOCATABLE :: CTCO(:,:) + CHARACTER*6, ALLOCATABLE :: CTCO(:,:) C> Entries within jump/link table which contain Table C C> operators. - INTEGER, ALLOCATABLE :: INODTCO(:,:) + INTEGER, ALLOCATABLE :: INODTCO(:,:) C> Number of "set" entries (set to a value of 0) C> in the bitmap. - INTEGER, ALLOCATABLE :: NBTMSE(:) + INTEGER, ALLOCATABLE :: NBTMSE(:) C> Ordinal position in data subset definition corresponding C> to the first entry of the bitmap. - INTEGER, ALLOCATABLE :: ISTBTM(:) + INTEGER, ALLOCATABLE :: ISTBTM(:) C> Size of bitmap (total number of entries, whether C> "set" (set to a value of 0) or not). - INTEGER, ALLOCATABLE :: ISZBTM(:) + INTEGER, ALLOCATABLE :: ISZBTM(:) C> Ordinal positions in bitmap of bits that were "set" (set C> to a value of 0); these ordinal positions can range in C> value from 1 to iszbtm for each stored bitmap. - INTEGER, ALLOCATABLE :: IBTMSE(:,:) + INTEGER, ALLOCATABLE :: IBTMSE(:,:) - END MODULE + END MODULE diff --git a/src/moda_bufrmg.F b/src/moda_bufrmg.F index 909bcd68..31a66744 100644 --- a/src/moda_bufrmg.F +++ b/src/moda_bufrmg.F @@ -8,11 +8,11 @@ C> C> @author J. Ator @date 2014-12-10 - MODULE MODA_BUFRMG + MODULE MODA_BUFRMG C> Length (in integers) of BUFR message most recently written to each output I/O stream. - INTEGER, ALLOCATABLE :: MSGLEN(:) + INTEGER, ALLOCATABLE :: MSGLEN(:) C> BUFR message most recently written to each output I/O stream. - INTEGER, ALLOCATABLE :: MSGTXT(:,:) + INTEGER, ALLOCATABLE :: MSGTXT(:,:) - END MODULE + END MODULE diff --git a/src/moda_bufrsr.F b/src/moda_bufrsr.F index 4f70c593..b497b064 100644 --- a/src/moda_bufrsr.F +++ b/src/moda_bufrsr.F @@ -11,33 +11,33 @@ C> C> @author J. Ator @date 2014-12-10 - MODULE MODA_BUFRSR + MODULE MODA_BUFRSR C> Internal I/O stream index of BUFR file. - INTEGER :: JUNN + INTEGER :: JUNN C> File status indicator of BUFR file. - INTEGER :: JILL + INTEGER :: JILL C> Message status indicator of BUFR file. - INTEGER :: JIMM + INTEGER :: JIMM C> Bit pointer within BUFR message. - INTEGER :: JBIT + INTEGER :: JBIT C> Length (in bytes) of BUFR message. - INTEGER :: JBYT + INTEGER :: JBYT C> Sequential number of BUFR message, counting from the beginning of the file. - INTEGER :: JMSG + INTEGER :: JMSG C> Sequential number of BUFR data subset, counting from the beginning of the C> current BUFR message. - INTEGER :: JSUB + INTEGER :: JSUB C> Bit-wise (integer) representation of FXY value associated with Table A C> mnemonic for BUFR message. - INTEGER :: KSUB + INTEGER :: KSUB C> Positional index of Table A mnemonic within internal Table A. - INTEGER :: JNOD + INTEGER :: JNOD C> Section 1 date-time of BUFR message. - INTEGER :: JDAT + INTEGER :: JDAT C> Indicator of stack status when entering subroutine rewnbf(). - INTEGER, ALLOCATABLE :: JSR(:) + INTEGER, ALLOCATABLE :: JSR(:) C> BUFR message. - INTEGER, ALLOCATABLE :: JBAY(:) + INTEGER, ALLOCATABLE :: JBAY(:) - END MODULE + END MODULE diff --git a/src/moda_comprs.F b/src/moda_comprs.F index 59ec3d45..59f17964 100644 --- a/src/moda_comprs.F +++ b/src/moda_comprs.F @@ -12,15 +12,15 @@ C> C> @author J. Woollen @date 2002-05-14 - MODULE MODA_COMPRS + MODULE MODA_COMPRS C> Number of data subsets in message. - INTEGER :: NCOL + INTEGER :: NCOL C> Increment used when compressing non-character data values. - INTEGER(8) :: INCR + INTEGER(8) :: INCR C> Non-character data values for all data subsets in message. - INTEGER(8) , ALLOCATABLE :: MATX(:,:) + INTEGER(8) , ALLOCATABLE :: MATX(:,:) C> Character data values for all data subsets in message. - CHARACTER*(:), ALLOCATABLE :: CATX(:,:) + CHARACTER*(:), ALLOCATABLE :: CATX(:,:) - END MODULE + END MODULE diff --git a/src/moda_comprx.F b/src/moda_comprx.F index 65f75682..805772f5 100644 --- a/src/moda_comprx.F +++ b/src/moda_comprx.F @@ -12,43 +12,43 @@ C> C> @author J. Woollen @date 2002-05-14 - MODULE MODA_COMPRX + MODULE MODA_COMPRX C> Number of data values for each data subset in message. - INTEGER :: NROW + INTEGER :: NROW C> I/O stream index into internal arrays for output file. - INTEGER :: LUNC + INTEGER :: LUNC C> Number of bytes required to store Sections 0, 1, 2, and 3 of C> message. - INTEGER :: KBYT + INTEGER :: KBYT C> Flush flag. Set to .true. if a subroutine call was made to C> force the writing of the message to the corresponding output file, C> even if there may still be room in the message for additional C> data subsets. Otherwise set to .false. - LOGICAL :: FLUSH + LOGICAL :: FLUSH C> Write-out flag. Set to .true. if the message needs to be C> written to the corresponding output file. Otherwise set to .false. - LOGICAL :: WRIT1 + LOGICAL :: WRIT1 C> Minimum of each data value across all data subsets in message. - INTEGER(8), ALLOCATABLE :: KMIN(:) + INTEGER(8), ALLOCATABLE :: KMIN(:) C> Maximum of each data value across all data subsets in message. - INTEGER(8), ALLOCATABLE :: KMAX(:) + INTEGER(8), ALLOCATABLE :: KMAX(:) C> "Missing" values flag. Set to .true. if at least one occurrence C> of this data value is "missing" within any data subset of the C> message. Otherwise set to .false. - LOGICAL , ALLOCATABLE :: KMIS(:) + LOGICAL , ALLOCATABLE :: KMIS(:) C> Number of bits needed to hold the increments for this data value C> within each data subset of the message. - INTEGER , ALLOCATABLE :: KBIT(:) + INTEGER , ALLOCATABLE :: KBIT(:) C> Type of each data value. C> - 1 Delayed descriptor replication factor. C> - 2 Other non-character data. C> - 3 Character data. - INTEGER , ALLOCATABLE :: ITYP(:) + INTEGER , ALLOCATABLE :: ITYP(:) C> Bit width of underlying data descriptor as defined within Table B C> for each data value. - INTEGER , ALLOCATABLE :: IWID(:) + INTEGER , ALLOCATABLE :: IWID(:) C> Character data value, if corresponding ITYP value is set to 3. - CHARACTER*(:), ALLOCATABLE :: CSTR(:) + CHARACTER*(:), ALLOCATABLE :: CSTR(:) - END MODULE + END MODULE diff --git a/src/moda_dscach.F b/src/moda_dscach.F index e1c89c68..624d1119 100644 --- a/src/moda_dscach.F +++ b/src/moda_dscach.F @@ -12,21 +12,21 @@ C> @author J. Ator C> @date 2012-03-02 - MODULE MODA_DSCACH + MODULE MODA_DSCACH - USE MODV_MAXNC - USE MODV_MXCNEM + USE MODV_MAXNC + USE MODV_MXCNEM C> Number of entries in the internal Table A mnemonic C> cache (up to a maximum of MXCNEM). - INTEGER :: NCNEM + INTEGER :: NCNEM C> Table A mnemonics. - CHARACTER*8 :: CNEM(MXCNEM) + CHARACTER*8 :: CNEM(MXCNEM) C> Number of child descriptors for the corresponding C> Table A mnemonic in cnem. - INTEGER :: NDC(MXCNEM) + INTEGER :: NDC(MXCNEM) C> Bit-wise representations of the child descriptors C> for the corresponding Table A mnemonic in cnem. - INTEGER :: IDCACH(MXCNEM,MAXNC) + INTEGER :: IDCACH(MXCNEM,MAXNC) - END MODULE + END MODULE diff --git a/src/moda_h4wlc.F b/src/moda_h4wlc.F index 4d5e7af8..7a129c75 100644 --- a/src/moda_h4wlc.F +++ b/src/moda_h4wlc.F @@ -10,17 +10,17 @@ C> C> @author J. Ator @date 2014-02-05 - MODULE MODA_H4WLC + MODULE MODA_H4WLC - USE MODV_MXH4WLC + USE MODV_MXH4WLC C> Number of long character strings being stored. - INTEGER :: NH4WLC + INTEGER :: NH4WLC C> I/O stream index into internal arrays for associated output file. - INTEGER :: LUH4WLC(MXH4WLC) + INTEGER :: LUH4WLC(MXH4WLC) C> Table B mnemonics associated with long character strings. - CHARACTER*14 :: STH4WLC(MXH4WLC) + CHARACTER*14 :: STH4WLC(MXH4WLC) C> Long character strings. - CHARACTER*120 :: CHH4WLC(MXH4WLC) + CHARACTER*120 :: CHH4WLC(MXH4WLC) - END MODULE + END MODULE diff --git a/src/moda_idrdm.F b/src/moda_idrdm.F index 13df1c8e..219e7b77 100644 --- a/src/moda_idrdm.F +++ b/src/moda_idrdm.F @@ -9,12 +9,12 @@ C> C> @author J. Ator @date 2009-03-23 - MODULE MODA_IDRDM + MODULE MODA_IDRDM C> DX BUFR tables message count for each I/O internal stream index. Set to C> a value of zero unless a new DX dictionary table is in the process of being C> read in by subroutine readerme() for the associated logical unit, and in C> which case it keeps track of how many such messages have been read in so far. - INTEGER, ALLOCATABLE :: IDRDM(:) + INTEGER, ALLOCATABLE :: IDRDM(:) - END MODULE + END MODULE diff --git a/src/moda_ival.F b/src/moda_ival.F index 7a173e4e..985266df 100644 --- a/src/moda_ival.F +++ b/src/moda_ival.F @@ -10,9 +10,9 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_IVAL + MODULE MODA_IVAL C> BUFR data subset values. - INTEGER(8), ALLOCATABLE :: IVAL(:) + INTEGER(8), ALLOCATABLE :: IVAL(:) - END MODULE + END MODULE diff --git a/src/moda_ivttmp.F b/src/moda_ivttmp.F index df2d5095..a7e1e4cc 100644 --- a/src/moda_ivttmp.F +++ b/src/moda_ivttmp.F @@ -6,18 +6,18 @@ C> These arrays provide working space in several subprograms (usrtpl() and C> ufbcup()) which manipulate the contents of the internal subset buffers -C> where the contents of an evolving BUFR message are sccumulated and +C> where the contents of an evolving BUFR message are sccumulated and C> stored under user control prior to being written out. C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_IVTTMP + MODULE MODA_IVTTMP C> TAG array elements for new sections of a growing subset buffer. CHARACTER*10, ALLOCATABLE :: TTMP(:) C> INV array elements for new sections of a growing subset buffer. - INTEGER, ALLOCATABLE :: ITMP(:) + INTEGER, ALLOCATABLE :: ITMP(:) C> VAL array elements for new sections of a growing subset buffer. REAL*8, ALLOCATABLE :: VTMP(:) - END MODULE + END MODULE diff --git a/src/moda_lushr.F b/src/moda_lushr.F index 94d7bd6e..3aca40c6 100644 --- a/src/moda_lushr.F +++ b/src/moda_lushr.F @@ -9,12 +9,12 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_LUSHR + MODULE MODA_LUSHR C> Tracking index for each I/O internal stream index. Set to a value C> of zero if the corresponding logical unit does not share DX BUFR C> table information with any other logical unit. Otherwise set to a C> non-zero value within subroutine makestab(). - INTEGER, ALLOCATABLE :: LUS(:) + INTEGER, ALLOCATABLE :: LUS(:) - END MODULE + END MODULE diff --git a/src/moda_mgwa.F b/src/moda_mgwa.F index b7b41425..d1da1058 100644 --- a/src/moda_mgwa.F +++ b/src/moda_mgwa.F @@ -9,9 +9,9 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_MGWA + MODULE MODA_MGWA C> Temporary working copy of BUFR message. - INTEGER, ALLOCATABLE :: MGWA(:) + INTEGER, ALLOCATABLE :: MGWA(:) - END MODULE + END MODULE diff --git a/src/moda_mgwb.F b/src/moda_mgwb.F index 18a68ac5..fc3ec8eb 100644 --- a/src/moda_mgwb.F +++ b/src/moda_mgwb.F @@ -9,9 +9,9 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_MGWB + MODULE MODA_MGWB C> Temporary working copy of BUFR message. - INTEGER, ALLOCATABLE :: MGWB(:) + INTEGER, ALLOCATABLE :: MGWB(:) - END MODULE + END MODULE diff --git a/src/moda_msgcwd.F b/src/moda_msgcwd.F index 0916f41c..d35a3691 100644 --- a/src/moda_msgcwd.F +++ b/src/moda_msgcwd.F @@ -10,17 +10,17 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_MSGCWD + MODULE MODA_MSGCWD C> Current message pointer within logical unit. - INTEGER, ALLOCATABLE :: NMSG(:) + INTEGER, ALLOCATABLE :: NMSG(:) C> Current subset pointer within message. - INTEGER, ALLOCATABLE :: NSUB(:) + INTEGER, ALLOCATABLE :: NSUB(:) C> Total number of data subsets in message. - INTEGER, ALLOCATABLE :: MSUB(:) + INTEGER, ALLOCATABLE :: MSUB(:) C> Table A mnemonic for type of BUFR message. - INTEGER, ALLOCATABLE :: INODE(:) + INTEGER, ALLOCATABLE :: INODE(:) C> Section 1 date-time of message. - INTEGER, ALLOCATABLE :: IDATE(:) + INTEGER, ALLOCATABLE :: IDATE(:) - END MODULE + END MODULE diff --git a/src/moda_msglim.F b/src/moda_msglim.F index 5d8835f1..39aea1bd 100644 --- a/src/moda_msglim.F +++ b/src/moda_msglim.F @@ -13,13 +13,13 @@ C> C> @author D. Keyser @date 2005-05-26 - MODULE MODA_MSGLIM + MODULE MODA_MSGLIM C> Tracking index for each I/O stream index. Initialized to a value of 3 C> within subroutine bfrini(), and then reset to a value of 0 within C> subroutine closmg() if the corresponding logical unit should not have C> any empty (zero data subset) BUFR messages written to it. C> - INTEGER, ALLOCATABLE :: MSGLIM(:) + INTEGER, ALLOCATABLE :: MSGLIM(:) - END MODULE + END MODULE diff --git a/src/moda_msgmem.F b/src/moda_msgmem.F index 0c6ab429..10851fb7 100644 --- a/src/moda_msgmem.F +++ b/src/moda_msgmem.F @@ -11,69 +11,69 @@ C> C> @author J. Ator @date 2014-12-10 - MODULE MODA_MSGMEM + MODULE MODA_MSGMEM C> Fortran logical unit number for use in accessing C> contents of BUFR files within internal memory. - INTEGER :: MUNIT + INTEGER :: MUNIT C> Number of array elements filled within msgs (up C> to a maximum of MAXMEM). - INTEGER :: MLAST + INTEGER :: MLAST C> Number of array elements filled within mdx (up C> to a maximum of MXDXW). - INTEGER :: LDXM + INTEGER :: LDXM C> Number of DX BUFR table messages stored within mdx C> (up to a maximum of MXDXM). - INTEGER :: NDXM + INTEGER :: NDXM C> Number of DX BUFR table that is currently in scope, C> depending on which BUFR message within msgs is C> currently in scope from the most recent call to C> subroutine rdmemm() or readmm(). - INTEGER :: LDXTS + INTEGER :: LDXTS C> Number of DX BUFR tables represented by the C> messages within mdx (up to a maximum of MXDXTS). - INTEGER :: NDXTS + INTEGER :: NDXTS C> Maximum number of DX BUFR table messages that can C> be stored within mdx. - INTEGER :: MXDXM + INTEGER :: MXDXM C> Maximum number of entries that can be stored C> within mdx. - INTEGER :: MXDXW + INTEGER :: MXDXW C> Pointers to the beginning of each message within C> msgs (up to a maximum of MAXMSG, and where array C> element 0 contains the actual number of messages C> stored within msgs). - INTEGER, ALLOCATABLE :: MSGP(:) + INTEGER, ALLOCATABLE :: MSGP(:) C> BUFR messages read from one or more BUFR files. - INTEGER, ALLOCATABLE :: MSGS(:) + INTEGER, ALLOCATABLE :: MSGS(:) C> DX BUFR table messages read from one or more BUFR C> files, for use in decoding the messages in msgs. - INTEGER, ALLOCATABLE :: MDX(:) + INTEGER, ALLOCATABLE :: MDX(:) C> Pointers to the beginning of each message within mdx. - INTEGER, ALLOCATABLE :: IPDXM(:) + INTEGER, ALLOCATABLE :: IPDXM(:) C> Pointers to the beginning of each DX BUFR table C> within mdx. - INTEGER, ALLOCATABLE :: IFDXTS(:) + INTEGER, ALLOCATABLE :: IFDXTS(:) C> Number of consecutive messages within mdx which C> constitute each DX BUFR table, beginning with the C> corresponding ifdxts. - INTEGER, ALLOCATABLE :: ICDXTS(:) + INTEGER, ALLOCATABLE :: ICDXTS(:) C> Pointers to first message within msgs for which each C> DX BUFR table applies. - INTEGER, ALLOCATABLE :: IPMSGS(:) + INTEGER, ALLOCATABLE :: IPMSGS(:) - END MODULE + END MODULE diff --git a/src/moda_mstabs.F b/src/moda_mstabs.F index efea1b68..bb54a798 100644 --- a/src/moda_mstabs.F +++ b/src/moda_mstabs.F @@ -13,49 +13,49 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODA_MSTABS + MODULE MODA_MSTABS C> Number of master Table B entries (up to a maximum of MXMTBB). - INTEGER :: NMTB + INTEGER :: NMTB C> C> Number of master Table D entries (up to a maximum of MXMTBD). - INTEGER :: NMTD + INTEGER :: NMTD C> C> Bit-wise representations of FXY numbers for master Table B. - INTEGER, ALLOCATABLE :: IBFXYN(:) + INTEGER, ALLOCATABLE :: IBFXYN(:) C> C> Scale factors corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBSCL(:,:) + CHARACTER, ALLOCATABLE :: CBSCL(:,:) C> C> Reference values corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBSREF(:,:) + CHARACTER, ALLOCATABLE :: CBSREF(:,:) C> C> Bit widths corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBBW(:,:) + CHARACTER, ALLOCATABLE :: CBBW(:,:) C> C> Units corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBUNIT(:,:) + CHARACTER, ALLOCATABLE :: CBUNIT(:,:) C> C> Mnemonics corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBMNEM(:,:) + CHARACTER, ALLOCATABLE :: CBMNEM(:,:) C> C> Element names corresponding to ibfxyn. - CHARACTER, ALLOCATABLE :: CBELEM(:,:) + CHARACTER, ALLOCATABLE :: CBELEM(:,:) C> C> Bit-wise representations of FXY numbers for master Table D. - INTEGER, ALLOCATABLE :: IDFXYN(:) + INTEGER, ALLOCATABLE :: IDFXYN(:) C> C> Sequence names corresponding to idfxyn. - CHARACTER, ALLOCATABLE :: CDSEQ(:,:) + CHARACTER, ALLOCATABLE :: CDSEQ(:,:) C> C> Mnemonics corresponding to idfxyn. - CHARACTER, ALLOCATABLE :: CDMNEM(:,:) + CHARACTER, ALLOCATABLE :: CDMNEM(:,:) C> C> Numbers of child descriptors corresponding to idfxyn. - INTEGER, ALLOCATABLE :: NDELEM(:) + INTEGER, ALLOCATABLE :: NDELEM(:) C> C> Bit-wise representations of child descriptors corresponding C> to idfxyn. - INTEGER, ALLOCATABLE :: IDEFXY(:) + INTEGER, ALLOCATABLE :: IDEFXY(:) - END MODULE + END MODULE diff --git a/src/moda_nmikrp.F b/src/moda_nmikrp.F index 8931eeab..074764a8 100644 --- a/src/moda_nmikrp.F +++ b/src/moda_nmikrp.F @@ -9,10 +9,10 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_NMIKRP + MODULE MODA_NMIKRP C> Child mnemonics within Table D sequences. - CHARACTER*8, ALLOCATABLE :: NEM(:,:) + CHARACTER*8, ALLOCATABLE :: NEM(:,:) C> Replication indicators corresponding to nem: C> - 5, if corresponding nem is a Table D mnemonic using 1-bit delayed replication C> - 4, if corresponding nem is a Table D mnemonic using 8-bit delayed (stack) replication @@ -20,11 +20,11 @@ MODULE MODA_NMIKRP C> - 2, if corresponding nem is a Table D mnemonic using 16-bit delayed replication C> - 1, if corresponding nem is a Table D mnemonic using regular (non-delayed) replication C> - 0, otherwise - INTEGER, ALLOCATABLE :: IRP(:,:) + INTEGER, ALLOCATABLE :: IRP(:,:) C> Replication counts corresponding to nem: C> - Number of replications, if corresponding nem is a Table D mnemonic using regular C> (non-delayed) replication C> - 0, otherwise - INTEGER, ALLOCATABLE :: KRP(:,:) + INTEGER, ALLOCATABLE :: KRP(:,:) - END MODULE + END MODULE diff --git a/src/moda_nrv203.F b/src/moda_nrv203.F index cbd82234..dc1f1efc 100644 --- a/src/moda_nrv203.F +++ b/src/moda_nrv203.F @@ -13,45 +13,45 @@ C> @author J. Ator C> @date 2012-03-02 - MODULE MODA_NRV203 + MODULE MODA_NRV203 C> Number of entries in the jump/link table which contain C> new reference values (up to a maximum of MXNRV). - INTEGER :: NNRV + INTEGER :: NNRV C> C> Number of bits in Section 4 occupied by each new C> reference value for the current 2-03-YYY operator in C> scope; set to 0 if no such operator is currently in C> scope. - INTEGER :: IBTNRV + INTEGER :: IBTNRV C> C> A number between 1 and nnrv, denoting the first entry C> within the module arrays which applies to the current C> data subset in scope; set to 0 if no 2-03-YYY operators -C> have been applied to the current data subset in scope. - INTEGER :: IPFNRV +C> have been applied to the current data subset in scope. + INTEGER :: IPFNRV C> C> Table B mnemonic to which the corresponding new C> reference value in nrv applies. - CHARACTER*8, ALLOCATABLE :: TAGNRV(:) + CHARACTER*8, ALLOCATABLE :: TAGNRV(:) C> C> Entries within jump/link table which contain new C> reference values. - INTEGER , ALLOCATABLE :: INODNRV(:) + INTEGER , ALLOCATABLE :: INODNRV(:) C> C> New reference values corresponding to inodnrv. - INTEGER*8 , ALLOCATABLE :: NRV(:) + INTEGER*8 , ALLOCATABLE :: NRV(:) C> C> Start of entry range in jump/link table, within which C> the corresponding new reference value in nrv will be C> applied to all occurrences of the corresponding C> Table B mnemonic in tagnrv. - INTEGER , ALLOCATABLE :: ISNRV(:) + INTEGER , ALLOCATABLE :: ISNRV(:) C> C> End of entry range in jump/link table, within which C> the corresponding new reference value in nrv will be C> applied to all occurrences of the corresponding C> Table B mnemonic in tagnrv. - INTEGER , ALLOCATABLE :: IENRV(:) + INTEGER , ALLOCATABLE :: IENRV(:) - END MODULE + END MODULE diff --git a/src/moda_nulbfr.F b/src/moda_nulbfr.F index de13d1f7..bd19cde5 100644 --- a/src/moda_nulbfr.F +++ b/src/moda_nulbfr.F @@ -18,11 +18,11 @@ C> C> @author J. Woollen @date 2003-11-04 - MODULE MODA_NULBFR + MODULE MODA_NULBFR C> Output switch for each internal I/O stream index: C> - 0 BUFR messages will be written to corresponding logical unit (default) C> - 1 no BUFR messages will be written to corresponding logical unit - INTEGER, ALLOCATABLE :: NULL(:) + INTEGER, ALLOCATABLE :: NULL(:) - END MODULE + END MODULE diff --git a/src/moda_rdmtb.F b/src/moda_rdmtb.F index 79d1b3a1..256a2dc8 100644 --- a/src/moda_rdmtb.F +++ b/src/moda_rdmtb.F @@ -14,16 +14,16 @@ C> @date 2014-12-10 - MODULE MODA_RDMTB + MODULE MODA_RDMTB C> Bit-wise representations of child descriptors of C> Table D sequences. - INTEGER, ALLOCATABLE :: IEFXYN(:,:) + INTEGER, ALLOCATABLE :: IEFXYN(:,:) C> Descriptor codes for Table B elements. - CHARACTER*4, ALLOCATABLE :: CMDSCB(:) + CHARACTER*4, ALLOCATABLE :: CMDSCB(:) C> Descriptor codes for Table D sequences. - CHARACTER*4, ALLOCATABLE :: CMDSCD(:) + CHARACTER*4, ALLOCATABLE :: CMDSCD(:) C> Element names corresponding to iefxyn. - CHARACTER*120, ALLOCATABLE :: CEELEM(:,:) + CHARACTER*120, ALLOCATABLE :: CEELEM(:,:) - END MODULE + END MODULE diff --git a/src/moda_rlccmn.F b/src/moda_rlccmn.F index 8890c007..c99c34bb 100644 --- a/src/moda_rlccmn.F +++ b/src/moda_rlccmn.F @@ -10,15 +10,15 @@ C> C> @author J. Woollen @date 2009-03-23 - MODULE MODA_RLCCMN + MODULE MODA_RLCCMN C> Number of long character strings in data subset. - INTEGER :: NRST + INTEGER :: NRST C> Lengths (in bytes) of long character strings. - INTEGER, ALLOCATABLE :: IRNCH(:) + INTEGER, ALLOCATABLE :: IRNCH(:) C> Pointers in data subset to first bits of long character strings. - INTEGER, ALLOCATABLE :: IRBIT(:) + INTEGER, ALLOCATABLE :: IRBIT(:) C> Table B mnemonics associated with long character strings. - CHARACTER*10, ALLOCATABLE :: CRTAG(:) + CHARACTER*10, ALLOCATABLE :: CRTAG(:) - END MODULE + END MODULE diff --git a/src/moda_s01cm.F b/src/moda_s01cm.F index f728aeb2..2aa7b410 100644 --- a/src/moda_s01cm.F +++ b/src/moda_s01cm.F @@ -13,14 +13,14 @@ C> C> @author J. Ator @date 2015-03-03 - MODULE MODA_S01CM + MODULE MODA_S01CM C> Custom values for use within Sections 0 and 1 of all future C> output BUFR messages written to all Fortran logical units. - INTEGER, ALLOCATABLE :: IVMNEM(:) + INTEGER, ALLOCATABLE :: IVMNEM(:) C> Section 0 and 1 mnemonics corresponding to ivmnem. - CHARACTER*8, ALLOCATABLE :: CMNEM(:) + CHARACTER*8, ALLOCATABLE :: CMNEM(:) C> Number of custom values stored. - INTEGER :: NS01V = 0 + INTEGER :: NS01V = 0 - END MODULE + END MODULE diff --git a/src/moda_sc3bfr.F b/src/moda_sc3bfr.F index 2ce42cd1..80a27fe6 100644 --- a/src/moda_sc3bfr.F +++ b/src/moda_sc3bfr.F @@ -18,16 +18,16 @@ C> C> @author J. Ator @date 2009-03-23 - MODULE MODA_SC3BFR + MODULE MODA_SC3BFR C> Section 3 switch for each internal I/O stream index: C> - 0 BUFR messages read from corresponding logical unit will be C> decoded using DX BUFR tables (default) C> - 1 BUFR messages read from corresponding logical unit will be C> decoded using master BUFR tables - INTEGER, ALLOCATABLE :: ISC3(:) + INTEGER, ALLOCATABLE :: ISC3(:) C> Table A mnemonic most recently read from each internal I/O stream C> index, if isc3 = 1 for that stream - CHARACTER*8, ALLOCATABLE :: TAMNEM(:) + CHARACTER*8, ALLOCATABLE :: TAMNEM(:) - END MODULE + END MODULE diff --git a/src/moda_stbfr.F b/src/moda_stbfr.F index bb12b4d4..9a7f0386 100644 --- a/src/moda_stbfr.F +++ b/src/moda_stbfr.F @@ -10,7 +10,7 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_STBFR + MODULE MODA_STBFR C> File status indicators. Every connected I/O stream index has a C> non-zero value in this array: @@ -19,12 +19,12 @@ MODULE MODA_STBFR C> - if the value is negative, then the logical unit number of the C> absolute value of this same value is connected for input C> (i.e. reading/decoding) BUFR - INTEGER, ALLOCATABLE :: IOLUN(:) + INTEGER, ALLOCATABLE :: IOLUN(:) C> Message status indicator corresponding to iolun, denoting whether C> a BUFR message is currently open within the internal arrays for C> the corresponding logical unit: C> - 0 no C> - 1 yes - INTEGER, ALLOCATABLE :: IOMSG(:) + INTEGER, ALLOCATABLE :: IOMSG(:) - END MODULE + END MODULE diff --git a/src/moda_stcode.F b/src/moda_stcode.F index 6810ebff..de070524 100644 --- a/src/moda_stcode.F +++ b/src/moda_stcode.F @@ -11,10 +11,10 @@ C> C> @author J. Ator @date 2010-05-11 - MODULE MODA_STCODE + MODULE MODA_STCODE C> Abnormal status codes. C> - 0 all is normal; no error occurred - INTEGER, ALLOCATABLE :: ISCODES(:) + INTEGER, ALLOCATABLE :: ISCODES(:) - END MODULE + END MODULE diff --git a/src/moda_tababd.F b/src/moda_tababd.F index 54cffdef..dfb5f8fa 100644 --- a/src/moda_tababd.F +++ b/src/moda_tababd.F @@ -7,45 +7,45 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODA_TABABD + MODULE MODA_TABABD C> Number of Table A entries for each internal I/O stream C> (up to a maximum of MAXTBA, whose value is stored in C> array element 0). - INTEGER, ALLOCATABLE :: NTBA(:) + INTEGER, ALLOCATABLE :: NTBA(:) C> C> Number of Table B entries for each internal I/O stream C> (up to a maximum of MAXTBB, whose value is stored in C> array element 0). - INTEGER, ALLOCATABLE :: NTBB(:) + INTEGER, ALLOCATABLE :: NTBB(:) C> C> Number of Table D entries for each internal I/O stream C> (up to a maximum of MAXTBD, whose value is stored in C> array element 0). - INTEGER, ALLOCATABLE :: NTBD(:) + INTEGER, ALLOCATABLE :: NTBD(:) C> C> Entries within jump/link table corresponding to taba. - INTEGER, ALLOCATABLE :: MTAB(:,:) + INTEGER, ALLOCATABLE :: MTAB(:,:) C> C> Message types (in array element 1) and subtypes (in array C> element 2) corresponding to taba. - INTEGER, ALLOCATABLE :: IDNA(:,:,:) + INTEGER, ALLOCATABLE :: IDNA(:,:,:) C> C> Bit-wise representations of the FXY values corresponding C> to tabb. - INTEGER, ALLOCATABLE :: IDNB(:,:) + INTEGER, ALLOCATABLE :: IDNB(:,:) C> C> Bit-wise representations of the FXY values corresponding C> to tabd. - INTEGER, ALLOCATABLE :: IDND(:,:) + INTEGER, ALLOCATABLE :: IDND(:,:) C> C> Table A entries for each internal I/O stream. - CHARACTER*128, ALLOCATABLE :: TABA(:,:) + CHARACTER*128, ALLOCATABLE :: TABA(:,:) C> C> Table B entries for each internal I/O stream. - CHARACTER*128, ALLOCATABLE :: TABB(:,:) + CHARACTER*128, ALLOCATABLE :: TABB(:,:) C> C> Table D entries for each internal I/O stream. - CHARACTER*600, ALLOCATABLE :: TABD(:,:) + CHARACTER*600, ALLOCATABLE :: TABD(:,:) - END MODULE + END MODULE diff --git a/src/moda_tables.F b/src/moda_tables.F index 195c7a61..bd9c7c46 100644 --- a/src/moda_tables.F +++ b/src/moda_tables.F @@ -10,17 +10,17 @@ C> C> @author J. Ator @date 2014-12-10 - MODULE MODA_TABLES + MODULE MODA_TABLES C> Maximum number of entries in the jump/link table; C> equivalent to MAXJL. - INTEGER :: MAXTAB + INTEGER :: MAXTAB C> Number of entries in the jump/link table. - INTEGER :: NTAB + INTEGER :: NTAB C> Mnemonics in the jump/link table. - CHARACTER*10, ALLOCATABLE :: TAG(:) + CHARACTER*10, ALLOCATABLE :: TAG(:) C> Type indicators corresponding to tag: C> - "SUB", if corresponding tag entry is a Table A mnemonic @@ -44,10 +44,10 @@ MODULE MODA_TABLES C> with units of CCITT IA5 C> - "NUM", if corresponding tag entry is a Table B mnemonic C> with any units other than CCITT IA5 - CHARACTER*3, ALLOCATABLE :: TYP(:) + CHARACTER*3, ALLOCATABLE :: TYP(:) C> ??? - INTEGER, ALLOCATABLE :: KNT(:) + INTEGER, ALLOCATABLE :: KNT(:) C> Jump forward indices corresponding to tag and typ: C> - 0, if corresponding typ entry is "CHR" or "NUM" @@ -57,7 +57,7 @@ MODULE MODA_TABLES C> - Jump/link table entry for Table B or D mnemonic which is C> the first sequential child descriptor of the corresponding C> tag entry, otherwise - INTEGER, ALLOCATABLE :: JUMP(:) + INTEGER, ALLOCATABLE :: JUMP(:) C> Link indices corresponding to tag, typ and jmpb: C> - 0, if corresponding typ entry is "SUB" or "RPC", or if @@ -68,27 +68,27 @@ MODULE MODA_TABLES C> mnemonic referenced by corresponding jmpb entry C> - Jump/link table entry for Table B or D mnemonic which C> follows the corresponding tag entry as the next sequential -C> child descriptor of the Table A or D mnemonic referenced +C> child descriptor of the Table A or D mnemonic referenced C> by corresponding jmpb entry, otherwise - INTEGER, ALLOCATABLE :: LINK(:) + INTEGER, ALLOCATABLE :: LINK(:) C> Jump backward indices corresponding to tag and typ: C> - 0, if corresponding typ entry is "SUB" C> - Jump/link table entry denoting the replication of C> corresponding tag entry, if corresponding typ entry is -C> "RPC", or if corresponding typ entry is "SEQ" and +C> "RPC", or if corresponding typ entry is "SEQ" and C> corresponding tag entry uses either short (1-bit) or C> regular (non-delayed) replication C> - Jump/link table entry for Table A or D mnemonic of C> which corresponding tag entry is a child descriptor, C> otherwise - INTEGER, ALLOCATABLE :: JMPB(:) + INTEGER, ALLOCATABLE :: JMPB(:) C> Bit widths corresponding to tag and typ: C> - Bit width of corresponding tag entry, if corresponding C> typ entry is "CHR", "NUM", "DRB" or "DRP" C> - 0, otherwise - INTEGER, ALLOCATABLE :: IBT(:) + INTEGER, ALLOCATABLE :: IBT(:) C> Reference values corresponding to tag and typ: C> - Reference value of corresponding tag entry, if @@ -97,7 +97,7 @@ MODULE MODA_TABLES C> mnemonic referenced by corresponding jump entry, if C> corresponding typ entry is "REP" C> - 0, otherwise - INTEGER, ALLOCATABLE :: IRF(:) + INTEGER, ALLOCATABLE :: IRF(:) C> Scale factors corresponding to tag and typ: C> - Scale factor of corresponding tag entry, if @@ -107,20 +107,20 @@ MODULE MODA_TABLES C> corresponding tag entry, if the corresponding typ entry C> is "SUB" C> - 0, otherwise - INTEGER, ALLOCATABLE :: ISC(:) + INTEGER, ALLOCATABLE :: ISC(:) C> Integer type values corresponding to typ: C> - 1, if corresponding typ entry is "DRS", "DRP" or "DRB" C> - 2, if corresponding typ entry is "NUM" C> - 3, if corresponding typ entry is "CHR" C> - 0, otherwise - INTEGER, ALLOCATABLE :: ITP(:) + INTEGER, ALLOCATABLE :: ITP(:) C> Initialized data values corresponding to typ: C> - Current placeholder value for "missing" data, if C> corresponding typ entry is "REP", "NUM" or "CHR" C> - 0, otherwise - REAL*8, ALLOCATABLE :: VALI(:) + REAL*8, ALLOCATABLE :: VALI(:) C> Initialized replication counts corresponding to typ and jump: C> - 0, if corresponding typ entry is "RPC", "RPS" or "DRB" @@ -128,12 +128,12 @@ MODULE MODA_TABLES C> mnemonic referenced by corresponding jump entry, if C> corresponding typ entry is "REP" C> - 1, otherwise - INTEGER, ALLOCATABLE :: KNTI(:) + INTEGER, ALLOCATABLE :: KNTI(:) C> ??? - INTEGER, ALLOCATABLE :: ISEQ(:,:) + INTEGER, ALLOCATABLE :: ISEQ(:,:) C> ??? - INTEGER, ALLOCATABLE :: JSEQ(:) + INTEGER, ALLOCATABLE :: JSEQ(:) - END MODULE + END MODULE diff --git a/src/moda_ufbcpl.F b/src/moda_ufbcpl.F index 5bbf517d..3ee7ccee 100644 --- a/src/moda_ufbcpl.F +++ b/src/moda_ufbcpl.F @@ -14,10 +14,10 @@ C> C> @author J. Woollen @date 2009-08-11 - MODULE MODA_UFBCPL + MODULE MODA_UFBCPL C> Logical unit numbers used to copy long character strings C> between BUFR data subsets. - INTEGER, ALLOCATABLE :: LUNCPY(:) + INTEGER, ALLOCATABLE :: LUNCPY(:) - END MODULE + END MODULE diff --git a/src/moda_unptyp.F b/src/moda_unptyp.F index 93de8abc..4b614fe6 100644 --- a/src/moda_unptyp.F +++ b/src/moda_unptyp.F @@ -9,7 +9,7 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_UNPTYP + MODULE MODA_UNPTYP C> BUFR message types: C> - 0 message contains data subset byte counters and other @@ -17,6 +17,6 @@ MODULE MODA_UNPTYP C> - 1 message is fully standard and contains no C> non-standard enhancements C> - 2 message is compressed - INTEGER, ALLOCATABLE :: MSGUNP(:) + INTEGER, ALLOCATABLE :: MSGUNP(:) - END MODULE + END MODULE diff --git a/src/moda_usrbit.F b/src/moda_usrbit.F index daa3ee36..1603cf5a 100644 --- a/src/moda_usrbit.F +++ b/src/moda_usrbit.F @@ -9,11 +9,11 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_USRBIT + MODULE MODA_USRBIT C> Length (in bits) of each packed value in mbit. - INTEGER, ALLOCATABLE :: NBIT(:) + INTEGER, ALLOCATABLE :: NBIT(:) C> Pointer in data subset to first bit of each packed data value. - INTEGER, ALLOCATABLE :: MBIT(:) + INTEGER, ALLOCATABLE :: MBIT(:) - END MODULE + END MODULE diff --git a/src/moda_usrint.F b/src/moda_usrint.F index 897d2d71..3a2a29b9 100644 --- a/src/moda_usrint.F +++ b/src/moda_usrint.F @@ -13,17 +13,17 @@ C> C> @author J. Woollen @date 1994-01-06 - MODULE MODA_USRINT + MODULE MODA_USRINT C> Number of data values in BUFR data subset. - INTEGER, ALLOCATABLE :: NVAL(:) + INTEGER, ALLOCATABLE :: NVAL(:) C> Inventory pointer which links each data value to its C> corresponding node in the internal jump/link table. - INTEGER, TARGET, ALLOCATABLE :: INV(:,:) + INTEGER, TARGET, ALLOCATABLE :: INV(:,:) C> Referenced data value, for data values which refer to a previous C> data value in the BUFR data subset via an internal bitmap. - INTEGER, ALLOCATABLE :: NRFELM(:,:) + INTEGER, ALLOCATABLE :: NRFELM(:,:) C> Data values. - REAL*8, TARGET, ALLOCATABLE :: VAL(:,:) + REAL*8, TARGET, ALLOCATABLE :: VAL(:,:) - END MODULE + END MODULE diff --git a/src/moda_usrtmp.F b/src/moda_usrtmp.F index 8c77c193..39873de1 100644 --- a/src/moda_usrtmp.F +++ b/src/moda_usrtmp.F @@ -7,10 +7,10 @@ C> makestab into internal subset arrays inv and val during a subset C> input being done in subroutine rdtree. C> -C> @author J. Woollen 1994-01-06 +C> @author J. Woollen 1994-01-06 - MODULE MODA_USRTMP + MODULE MODA_USRTMP PARAMETER ( MAXRCR = 100 ) diff --git a/src/moda_xtab.F b/src/moda_xtab.F index 80287a25..ede79a8f 100644 --- a/src/moda_xtab.F +++ b/src/moda_xtab.F @@ -15,12 +15,12 @@ C> C> @author J. Woollen @date 2009-03-18 - MODULE MODA_XTAB + MODULE MODA_XTAB C> Tracking index for each internal I/O stream index. C> Set to .true. if the DX BUFR table for the corresponding C> logical unit has changed since the previous call to C> subroutine makestab(); set to .false. otherwise. - LOGICAL, ALLOCATABLE :: XTAB(:) + LOGICAL, ALLOCATABLE :: XTAB(:) - END MODULE + END MODULE diff --git a/src/modv_MAXJL.f b/src/modv_MAXJL.f index d5b6cbce..ab980122 100644 --- a/src/modv_MAXJL.f +++ b/src/modv_MAXJL.f @@ -10,11 +10,11 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXJL + MODULE MODV_MAXJL C> @var maxjl C> Maximum number of entries in the internal jump/link table. - INTEGER :: MAXJL = 96000 + INTEGER :: MAXJL = 96000 - END MODULE + END MODULE diff --git a/src/modv_MAXMEM.f b/src/modv_MAXMEM.f index 7810eee9..0456accc 100644 --- a/src/modv_MAXMEM.f +++ b/src/modv_MAXMEM.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXMEM + MODULE MODV_MAXMEM C> @var maxmem C> Maximum number of bytes that can be used to store BUFR C> messages within internal memory. - INTEGER :: MAXMEM = 50000000 + INTEGER :: MAXMEM = 50000000 - END MODULE + END MODULE diff --git a/src/modv_MAXMSG.f b/src/modv_MAXMSG.f index 261a2771..a93ba379 100644 --- a/src/modv_MAXMSG.f +++ b/src/modv_MAXMSG.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXMSG + MODULE MODV_MAXMSG C> @var maxmsg C> Maximum number of BUFR messages that can be stored C> within internal memory. - INTEGER :: MAXMSG = 200000 + INTEGER :: MAXMSG = 200000 - END MODULE + END MODULE diff --git a/src/modv_MAXNC.f90 b/src/modv_MAXNC.f90 index 363edfa0..fafed051 100644 --- a/src/modv_MAXNC.f90 +++ b/src/modv_MAXNC.f90 @@ -9,7 +9,7 @@ module MODV_MAXNC !> @var maxnc -!> Maximum number of descriptors within Section 3 of a BUFR message. +!> Maximum number of descriptors within Section 3 of a BUFR message. integer, parameter, public :: MAXNC = 600 diff --git a/src/modv_MAXSS.f b/src/modv_MAXSS.f index b3b358f6..c8fe11b8 100644 --- a/src/modv_MAXSS.f +++ b/src/modv_MAXSS.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXSS + MODULE MODV_MAXSS C> @var maxss C> Maximum number of data values that can be read from or C> written into a data subset by the BUFRLIB software. - INTEGER :: MAXSS = 120000 + INTEGER :: MAXSS = 120000 - END MODULE + END MODULE diff --git a/src/modv_MAXTBA.f b/src/modv_MAXTBA.f index 4e59bbbf..d6a17e0e 100644 --- a/src/modv_MAXTBA.f +++ b/src/modv_MAXTBA.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXTBA + MODULE MODV_MAXTBA C> @var maxtba C> Maximum number of entries in the internal BUFR Table A for C> each BUFR file that is connected to the BUFRLIB software. - INTEGER :: MAXTBA = 150 + INTEGER :: MAXTBA = 150 - END MODULE + END MODULE diff --git a/src/modv_MAXTBB.f b/src/modv_MAXTBB.f index 2f3bb440..095ada7a 100644 --- a/src/modv_MAXTBB.f +++ b/src/modv_MAXTBB.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXTBB + MODULE MODV_MAXTBB C> @var maxtbb C> Maximum number of entries in the internal BUFR Table B for C> each BUFR file that is connected to the BUFRLIB software. - INTEGER :: MAXTBB = 500 + INTEGER :: MAXTBB = 500 - END MODULE + END MODULE diff --git a/src/modv_MAXTBD.f b/src/modv_MAXTBD.f index 14a01db6..fee3de1b 100644 --- a/src/modv_MAXTBD.f +++ b/src/modv_MAXTBD.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MAXTBD + MODULE MODV_MAXTBD C> @var maxtbd C> Maximum number of entries in the internal BUFR Table D for C> each BUFR file that is connected to the BUFRLIB software. - INTEGER :: MAXTBD = 500 + INTEGER :: MAXTBD = 500 - END MODULE + END MODULE diff --git a/src/modv_MXBTM.f b/src/modv_MXBTM.f index 8e255150..7c38355d 100644 --- a/src/modv_MXBTM.f +++ b/src/modv_MXBTM.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXBTM + MODULE MODV_MXBTM C> @var mxbtm C> Maximum number of bitmaps that can be stored internally C> for a data subset. - INTEGER :: MXBTM = 5 + INTEGER :: MXBTM = 5 - END MODULE + END MODULE diff --git a/src/modv_MXBTMSE.f b/src/modv_MXBTMSE.f index 068b97ae..264b1df5 100644 --- a/src/modv_MXBTMSE.f +++ b/src/modv_MXBTMSE.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXBTMSE + MODULE MODV_MXBTMSE C> @var mxbtmse C> Maximum number of "set" entries (set to a value of 0) C> within a bitmap. - INTEGER :: MXBTMSE = 500 + INTEGER :: MXBTMSE = 500 - END MODULE + END MODULE diff --git a/src/modv_MXCDV.f b/src/modv_MXCDV.f index ec92f788..8a6d48e4 100644 --- a/src/modv_MXCDV.f +++ b/src/modv_MXCDV.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXCDV + MODULE MODV_MXCDV C> @var mxcdv C> Maximum number of data values that can be written into C> a data subset of a compressed BUFR message by the C> BUFRLIB software. - INTEGER :: MXCDV = 3000 + INTEGER :: MXCDV = 3000 - END MODULE + END MODULE diff --git a/src/modv_MXCSB.f b/src/modv_MXCSB.f index 30712a47..24433c12 100644 --- a/src/modv_MXCSB.f +++ b/src/modv_MXCSB.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXCSB + MODULE MODV_MXCSB C> @var mxcsb C> Maximum number of data subsets that can be written into -C> a compressed BUFR message by the BUFRLIB software. +C> a compressed BUFR message by the BUFRLIB software. - INTEGER :: MXCSB = 4000 + INTEGER :: MXCSB = 4000 - END MODULE + END MODULE diff --git a/src/modv_MXDXTS.f b/src/modv_MXDXTS.f index 9adb0924..472cb38c 100644 --- a/src/modv_MXDXTS.f +++ b/src/modv_MXDXTS.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXDXTS + MODULE MODV_MXDXTS C> @var mxdxts C> Maximum number of dictionary tables that can be stored C> for use with BUFR messages in internal memory. - INTEGER :: MXDXTS = 200 + INTEGER :: MXDXTS = 200 - END MODULE + END MODULE diff --git a/src/modv_MXLCC.f b/src/modv_MXLCC.f index 998e2406..eb3013ea 100644 --- a/src/modv_MXLCC.f +++ b/src/modv_MXLCC.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXLCC + MODULE MODV_MXLCC C> @var mxlcc C> Maximum length (in bytes) of a character string that can be C> written into a data subset of a compressed BUFR message by C> the BUFRLIB software. - INTEGER :: MXLCC = 32 + INTEGER :: MXLCC = 32 - END MODULE + END MODULE diff --git a/src/modv_MXMSGL.f b/src/modv_MXMSGL.f index 65179482..16290da3 100644 --- a/src/modv_MXMSGL.f +++ b/src/modv_MXMSGL.f @@ -1,16 +1,16 @@ C> @file C> @brief Declare and initialize MXMSGL variable. -C> This module declares and initializes the MXMSGL variable. +C> This module declares and initializes the MXMSGL variable. C> C>

This variable is initialized to a default value which can C> be overridden by a subsequent call to function isetprm() within C> the application program. -C> +C> C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXMSGL + MODULE MODV_MXMSGL C> @var mxmsgl C> Maximum length (in bytes) of a BUFR message that can be @@ -19,7 +19,7 @@ MODULE MODV_MXMSGL C> @var mxmsgld4 C> The value of mxmsgl divided by 4. - INTEGER :: MXMSGL = 600000 - INTEGER :: MXMSGLD4 + INTEGER :: MXMSGL = 600000 + INTEGER :: MXMSGLD4 - END MODULE + END MODULE diff --git a/src/modv_MXMTBB.f b/src/modv_MXMTBB.f index 20f9ef04..90cf7eba 100644 --- a/src/modv_MXMTBB.f +++ b/src/modv_MXMTBB.f @@ -10,11 +10,11 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXMTBB + MODULE MODV_MXMTBB C> @var mxmtbb C> Maximum number of entries in a master BUFR Table B. - INTEGER :: MXMTBB = 4000 + INTEGER :: MXMTBB = 4000 - END MODULE + END MODULE diff --git a/src/modv_MXMTBD.f b/src/modv_MXMTBD.f index bb02cc16..eca558e1 100644 --- a/src/modv_MXMTBD.f +++ b/src/modv_MXMTBD.f @@ -10,11 +10,11 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXMTBD + MODULE MODV_MXMTBD C> @var mxmtbd C> Maximum number of entries in a master BUFR Table D. - INTEGER :: MXMTBD = 1000 + INTEGER :: MXMTBD = 1000 - END MODULE + END MODULE diff --git a/src/modv_MXMTBF.f b/src/modv_MXMTBF.f index 95b369fa..78e14ec6 100644 --- a/src/modv_MXMTBF.f +++ b/src/modv_MXMTBF.f @@ -10,7 +10,7 @@ C> @author J. Ator C> @date 2018-01-11 - MODULE MODV_MXMTBF + MODULE MODV_MXMTBF C> @var mxmtbf C> Maximum number of entries in a master BUFR Code/Flag @@ -19,6 +19,6 @@ MODULE MODV_MXMTBF C> individual Code table) or defined bit number (within C> each individual Flag table) as a separate entry. - INTEGER :: MXMTBF = 25000 + INTEGER :: MXMTBF = 25000 - END MODULE + END MODULE diff --git a/src/modv_MXNRV.f b/src/modv_MXNRV.f index 3a44bacc..a469a646 100644 --- a/src/modv_MXNRV.f +++ b/src/modv_MXNRV.f @@ -10,12 +10,12 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXNRV + MODULE MODV_MXNRV C> @var mxnrv C> Maximum number of entries in the internal jump/link table C> that can contain new reference values. - INTEGER :: MXNRV = 15 + INTEGER :: MXNRV = 15 - END MODULE + END MODULE diff --git a/src/modv_MXRST.f b/src/modv_MXRST.f index 952e279c..ade1979a 100644 --- a/src/modv_MXRST.f +++ b/src/modv_MXRST.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXRST + MODULE MODV_MXRST C> @var mxrst C> Maximum number of "long" character strings (greater than 8 C> bytes) that can be read from a data subset of a compressed C> BUFR message. - INTEGER :: MXRST = 50 + INTEGER :: MXRST = 50 - END MODULE + END MODULE diff --git a/src/modv_MXS01V.f b/src/modv_MXS01V.f index 154795ed..19300ecf 100644 --- a/src/modv_MXS01V.f +++ b/src/modv_MXS01V.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXS01V + MODULE MODV_MXS01V C> @var mxs01v C> Maximum number of default Section 0 or Section 1 values C> that can be overwritten within an output BUFR message by C> the BUFRLIB software. - INTEGER :: MXS01V = 10 + INTEGER :: MXS01V = 10 - END MODULE + END MODULE diff --git a/src/modv_MXTAMC.f b/src/modv_MXTAMC.f index a4c6bfe6..aea39c37 100644 --- a/src/modv_MXTAMC.f +++ b/src/modv_MXTAMC.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXTAMC + MODULE MODV_MXTAMC C> @var mxtamc C> Maximum number of Table A mnemonics in the internal C> jump/link table which contain at least one Table C operator C> with an XX value of 21 or greater in their definition. - INTEGER :: MXTAMC = 15 + INTEGER :: MXTAMC = 15 - END MODULE + END MODULE diff --git a/src/modv_MXTCO.f b/src/modv_MXTCO.f index a3ad2d42..37556878 100644 --- a/src/modv_MXTCO.f +++ b/src/modv_MXTCO.f @@ -10,13 +10,13 @@ C> @author J. Ator C> @date 2014-12-10 - MODULE MODV_MXTCO + MODULE MODV_MXTCO C> @var mxtco C> Maximum number of Table C operators with an XX value C> of 21 or greater that can appear within the data subset C> definition of a Table A mnemonic. - INTEGER :: MXTCO = 30 + INTEGER :: MXTCO = 30 - END MODULE + END MODULE diff --git a/src/modv_NFILES.f90 b/src/modv_NFILES.f90 index bda08198..1d73b14e 100644 --- a/src/modv_NFILES.f90 +++ b/src/modv_NFILES.f90 @@ -11,7 +11,7 @@ module MODV_NFILES -!> @var nfiles +!> @var nfiles !> Maximum number of BUFR files that can be connected to the BUFRLIB software (for reading or writing) at any one time. integer, public :: NFILES = 32 diff --git a/src/msgfull.f b/src/msgfull.f index 762b0a51..bef6251d 100644 --- a/src/msgfull.f +++ b/src/msgfull.f @@ -11,7 +11,7 @@ C> @date 2009-03-23 C> C> @param[in] MSIZ -- integer: Size (in bytes) of current BUFR message -C> @param[in] ITOADD -- integer: Size (in bytes) of current data subset +C> @param[in] ITOADD -- integer: Size (in bytes) of current data subset C> @param[in] MXSIZ -- integer: Maximum size of a BUFR message C> @returns MSGFULL -- logical: Flag indicating whether the current C> data subset will fit within the current BUFR @@ -61,9 +61,9 @@ LOGICAL FUNCTION MSGFULL(MSIZ,ITOADD,MXSIZ) C Determine whether the subset will fit. IF ( ( MSIZ + ITOADD + IWGBYT ) .GT. MXSIZ ) THEN - MSGFULL = .TRUE. + MSGFULL = .TRUE. ELSE - MSGFULL = .FALSE. + MSGFULL = .FALSE. ENDIF RETURN diff --git a/src/msgini.f b/src/msgini.f index 89dee4c6..460d6ff7 100644 --- a/src/msgini.f +++ b/src/msgini.f @@ -23,7 +23,7 @@ C> 2021-05-14 | J. Ator | Changed default master table version to 36. C> C> @author Woollen @date 1994-01-06 - + C> This subroutine initializes, within the internal arrays, a new C> uncompressed BUFR message for output. Arrays are filled in common blocks C> msgptr and modules msgcwd and bitbuf. diff --git a/src/msgupd.f b/src/msgupd.f index 25e51594..7c558b9a 100644 --- a/src/msgupd.f +++ b/src/msgupd.f @@ -20,7 +20,7 @@ C> 2016-03-21 | D. Stokes | Call usrtpl for overlarge subsets. C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/msgwrt.f b/src/msgwrt.f index 1b01fc94..0717c4ce 100644 --- a/src/msgwrt.f +++ b/src/msgwrt.f @@ -161,7 +161,7 @@ SUBROUTINE MSGWRT(LUNIT,MESG,MGBYT) C APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA C COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX) -C INFORMATION. +C INFORMATION. IF ( ( CTRT.EQ.'Y' ) .AND. ( IDXMSG(MGWA).NE.1 ) ) THEN diff --git a/src/mstabs.h b/src/mstabs.h index a22ef7a6..527f4e4d 100644 --- a/src/mstabs.h +++ b/src/mstabs.h @@ -22,60 +22,60 @@ void cpmstabs( f77int *pnmtb, f77int *pibfxyn, char (*pcbscl)[4], char (*pcbsref #ifdef IN_ARALLOCC /** Number of master Table B entries; copied from Fortran nmtb variable. */ - f77int nmtb_c; + f77int nmtb_c; /** Bit-wise representations of master Table B FXY numbers; copied from Fortran ibfxyn array. */ - f77int *ibfxyn_c; + f77int *ibfxyn_c; /** Master Table B scale factors; copied from Fortran cbscl array. */ - char (*cbscl_c)[4]; + char (*cbscl_c)[4]; /** Master Table B reference value; copied from Fortran cbsref array. */ - char (*cbsref_c)[12]; + char (*cbsref_c)[12]; /** Master Table B bit widths; copied from Fortran cbbw array. */ - char (*cbbw_c)[4]; + char (*cbbw_c)[4]; /** Master Table B units; copied from Fortran cbunit array. */ - char (*cbunit_c)[24]; + char (*cbunit_c)[24]; /** Master Table B mnemonics; copied from Fortran cbmnem array. */ - char (*cbmnem_c)[8]; + char (*cbmnem_c)[8]; /** Master Table B element names; copied from Fortran cbelem array. */ - char (*cbelem_c)[120]; + char (*cbelem_c)[120]; /** Number of master Table D entries; copied from Fortran nmtd variable. */ - f77int nmtd_c; + f77int nmtd_c; /** Bit-wise representations of master Table D FXY numbers; copied from Fortran idfxyn array. */ - f77int *idfxyn_c; + f77int *idfxyn_c; /** Master Table D sequence names; copied from Fortran cdseq array. */ - char (*cdseq_c)[120]; + char (*cdseq_c)[120]; /** Master Table D mnemonics; copied from Fortran cdmnem array. */ - char (*cdmnem_c)[8]; + char (*cdmnem_c)[8]; /** Number of child descriptors for master Table D sequence; copied from Fortran ndelem array. */ - f77int *ndelem_c; + f77int *ndelem_c; /** Bit-wise representations of child descriptors for master Table D sequence; copied from Fortran idefxy array. */ - f77int *idefxy_c; + f77int *idefxy_c; #else /** Number of master Table B entries; copied from Fortran nmtb variable. */ - extern f77int nmtb_c; + extern f77int nmtb_c; /** Bit-wise representations of master Table B FXY numbers; copied from Fortran ibfxyn array. */ - extern f77int *ibfxyn_c; + extern f77int *ibfxyn_c; /** Master Table B scale factors; copied from Fortran cbscl array. */ - extern char (*cbscl_c)[4]; + extern char (*cbscl_c)[4]; /** Master Table B reference value; copied from Fortran cbsref array. */ - extern char (*cbsref_c)[12]; + extern char (*cbsref_c)[12]; /** Master Table B bit widths; copied from Fortran cbbw array. */ - extern char (*cbbw_c)[4]; + extern char (*cbbw_c)[4]; /** Master Table B units; copied from Fortran cbunit array. */ - extern char (*cbunit_c)[24]; + extern char (*cbunit_c)[24]; /** Master Table B mnemonics; copied from Fortran cbmnem array. */ - extern char (*cbmnem_c)[8]; + extern char (*cbmnem_c)[8]; /** Master Table B element names; copied from Fortran cbelem array. */ - extern char (*cbelem_c)[120]; + extern char (*cbelem_c)[120]; /** Number of master Table D entries; copied from Fortran nmtd variable. */ - extern f77int nmtd_c; + extern f77int nmtd_c; /** Bit-wise representations of master Table D FXY numbers; copied from Fortran idfxyn array. */ - extern f77int *idfxyn_c; + extern f77int *idfxyn_c; /** Master Table D sequence names; copied from Fortran cdseq array. */ - extern char (*cdseq_c)[120]; + extern char (*cdseq_c)[120]; /** Master Table D mnemonics; copied from Fortran cdmnem array. */ - extern char (*cdmnem_c)[8]; + extern char (*cdmnem_c)[8]; /** Number of child descriptors for master Table D sequence; copied from Fortran ndelem array. */ - extern f77int *ndelem_c; + extern f77int *ndelem_c; /** Bit-wise representations of child descriptors for master Table D sequence; copied from Fortran idefxy array. */ - extern f77int *idefxy_c; + extern f77int *idefxy_c; #endif diff --git a/src/mtfnam.f b/src/mtfnam.f index eeec02f7..f4854dc7 100644 --- a/src/mtfnam.f +++ b/src/mtfnam.f @@ -3,7 +3,7 @@ C> corresponding standard and local master table files on the C> filesystem. C> @author Ator @date 2017-10-16 - + C> 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 @@ -18,86 +18,86 @@ C> @param[in] TBLTYP - character*(*): table type:. C> - 'TableB' Table B C> - 'TableD' Table D -C> - 'CodeFlag' Code and Flag Tables +C> - 'CodeFlag' Code and Flag Tables C> @param[out] STDFIL - character*(*): standard master table path/filename. C> @param[out] LOCFIL - character*(*): local master table path/filename. C> C> @author Ator @date 2017-10-16 - SUBROUTINE MTFNAM ( IMT, IMTV, IOGCE, IMTVL, TBLTYP, + SUBROUTINE MTFNAM ( IMT, IMTV, IOGCE, IMTVL, TBLTYP, . STDFIL, LOCFIL ) - COMMON /QUIET/ IPRT - COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR + COMMON /QUIET/ IPRT + COMMON /MSTINF/ LUN1, LUN2, LMTD, MTDIR - CHARACTER*(*) STDFIL, LOCFIL, TBLTYP + CHARACTER*(*) STDFIL, LOCFIL, TBLTYP - CHARACTER*16 TBLTYP2 - CHARACTER*20 FMTF - CHARACTER*100 MTDIR - CHARACTER*128 BORT_STR - LOGICAL FOUND + 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 + 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 diff --git a/src/mtinfo.f b/src/mtinfo.f index 429c48cd..63f46d85 100644 --- a/src/mtinfo.f +++ b/src/mtinfo.f @@ -26,14 +26,14 @@ C> subsequent calls to any of the BUFR C> [message-reading subroutines](@ref hierarchy) for the associated BUFR C> file; otherwise, default values for CMTDIR, LUNMT1 and LUNMT2 will be -C> used as defined within subroutine bfrini(). +C> used as defined within subroutine bfrini(). C> C>

For CMTDIR, any full or relative directory pathname that is legal C> on the local filesystem is permissible, up to a total maximum length C> of 100 characters. The BUFRLIB software will then automatically search C> within this directory for any necessary master table files and open and C> read them as needed. -C> +C> C>

The logical unit numbers LUNMT1 and LUNMT2 should be distinct from C> each other but should not already be assigned to any files on the C> local system. diff --git a/src/mvb.f b/src/mvb.f index a2bdfe62..6f1e0405 100644 --- a/src/mvb.f +++ b/src/mvb.f @@ -1,6 +1,6 @@ C> @file C> @brief Copy a specified number of bytes from -C> one packed binary array to another. +C> one packed binary array to another. C> C> ### Program History Log C> Date | Programmer | Comments @@ -15,7 +15,7 @@ C> 2014-10-22 | J. Ator | Merge two do loops into one, and remove mximb parameter and dimensioning of nval. C> C> @author Woollen @date 1994-01-06 - + C> This subroutine copies a specified number of bytes from C> one packed binary array to another. C> diff --git a/src/nemdefs.f b/src/nemdefs.f index 5edbfae6..d5da71cf 100644 --- a/src/nemdefs.f +++ b/src/nemdefs.f @@ -35,54 +35,54 @@ C> C> @author J. Ator @date 2014-10-02 - RECURSIVE SUBROUTINE NEMDEFS ( LUNIT, NEMO, CELEM, CUNIT, IRET ) + RECURSIVE SUBROUTINE NEMDEFS ( LUNIT, NEMO, CELEM, CUNIT, IRET ) - USE MODA_TABABD + USE MODA_TABABD USE MODV_IM8B - CHARACTER*1 TAB + CHARACTER*1 TAB - CHARACTER*(*) NEMO, CELEM, CUNIT + CHARACTER*(*) NEMO, CELEM, CUNIT C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84 ( LUNIT, MY_LUNIT, 1 ) - CALL NEMDEFS ( MY_LUNIT, NEMO, CELEM, CUNIT, IRET ) - CALL X48 ( IRET, IRET, 1 ) + CALL X84 ( LUNIT, MY_LUNIT, 1 ) + CALL NEMDEFS ( MY_LUNIT, NEMO, CELEM, CUNIT, IRET ) + CALL X48 ( IRET, IRET, 1 ) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = -1 + IRET = -1 -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS( LUNIT, LUN, IL, IM ) - IF ( IL .EQ. 0 ) RETURN + CALL STATUS( LUNIT, LUN, IL, IM ) + IF ( IL .EQ. 0 ) RETURN -C Find the requested mnemonic in the internal Table B arrays. +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 + 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. +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) + 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) + CUNIT = ' ' + LS = MIN(LEN(CUNIT),24) + CUNIT(1:LS) = TABB(ILOC,LUN)(71:70+LS) - IRET = 0 + IRET = 0 - RETURN - END + RETURN + END diff --git a/src/nemspecs.f b/src/nemspecs.f index 1ab61314..c39d368c 100644 --- a/src/nemspecs.f +++ b/src/nemspecs.f @@ -49,90 +49,90 @@ C> C> @author J. Ator @date 2014-10-02 - RECURSIVE SUBROUTINE NEMSPECS - . ( LUNIT, NEMO, NNEMO, NSCL, NREF, NBTS, IRET ) + RECURSIVE SUBROUTINE NEMSPECS + . ( LUNIT, NEMO, NNEMO, NSCL, NREF, NBTS, IRET ) - USE MODA_USRINT - USE MODA_MSGCWD - USE MODA_TABLES - USE MODA_NRV203 + USE MODA_USRINT + USE MODA_MSGCWD + USE MODA_TABLES + USE MODA_NRV203 USE MODV_IM8B - CHARACTER*10 TAGN + CHARACTER*10 TAGN - CHARACTER*(*) NEMO + CHARACTER*(*) NEMO C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84(LUNIT,MY_LUNIT,1) - CALL X84(NNEMO,MY_NNEMO,1) - CALL NEMSPECS(MY_LUNIT,NEMO,MY_NNEMO,NSCL,NREF,NBTS,IRET) - CALL X48(NSCL,NSCL,1) - CALL X48(NREF,NREF,1) - CALL X48(NBTS,NBTS,1) - CALL X48(IRET,IRET,1) + CALL X84(LUNIT,MY_LUNIT,1) + CALL X84(NNEMO,MY_NNEMO,1) + CALL NEMSPECS(MY_LUNIT,NEMO,MY_NNEMO,NSCL,NREF,NBTS,IRET) + CALL X48(NSCL,NSCL,1) + CALL X48(NREF,NREF,1) + CALL X48(NBTS,NBTS,1) + CALL X48(IRET,IRET,1) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = -1 + IRET = -1 -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS( LUNIT, LUN, IL, IM ) - IF ( IL .EQ. 0 ) RETURN - IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN + 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. +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 + CALL FSTAG( LUN, NEMO, NNEMO, 1, NIDX, IERFST ) + IF ( IERFST .NE. 0 ) RETURN -C Confirm that NEMO is a Table B mnemonic. +C Confirm that NEMO is a Table B mnemonic. - NODE = INV(NIDX,LUN) - IF ( ( TYP(NODE) .NE. 'NUM' ) .AND. ( TYP(NODE) .NE. 'CHR' ) ) - . RETURN + 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. +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) + NSCL = ISC(NODE) + NBTS = IBT(NODE) + NREF = IRF(NODE) - IF ( NNRV .GT. 0 ) THEN + 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. +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 + 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 + 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 + END IF - RETURN - END + RETURN + END diff --git a/src/newwin.f b/src/newwin.f index 05231607..f418bb96 100644 --- a/src/newwin.f +++ b/src/newwin.f @@ -15,7 +15,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> Given an index within the internal jump/link table which C> points to the start of an "rpc" window (which is the iteration of an 8-bit C> or 16-bit delayed replication sequence), this subroutine computes @@ -43,7 +43,7 @@ SUBROUTINE NEWWIN(LUN,IWIN,JWIN) 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. +C the last value of the entire subset. JWIN = NVAL(LUN) GOTO 100 diff --git a/src/nmwrd.f b/src/nmwrd.f index 783e4b6f..89f0628b 100644 --- a/src/nmwrd.f +++ b/src/nmwrd.f @@ -26,34 +26,34 @@ C> | 2005-11-29 | J. Ator | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE FUNCTION NMWRD(MBAY) RESULT(IRET) + RECURSIVE FUNCTION NMWRD(MBAY) RESULT(IRET) - USE MODV_IM8B - - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + USE MODV_IM8B - DIMENSION MBAY(*) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + + DIMENSION MBAY(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF (IM8B) THEN - IM8B = .FALSE. + IF (IM8B) THEN + IM8B = .FALSE. - IRET = NMWRD(MBAY) + IRET = NMWRD(MBAY) - IM8B = .TRUE. - RETURN - END IF + IM8B = .TRUE. + RETURN + END IF - LENM = IUPBS01(MBAY,'LENM') - IF(LENM.EQ.0) THEN - IRET = 0 - ELSE - IRET = ((LENM/8)+1)*(8/NBYTW) - ENDIF + LENM = IUPBS01(MBAY,'LENM') + IF(LENM.EQ.0) THEN + IRET = 0 + ELSE + IRET = ((LENM/8)+1)*(8/NBYTW) + ENDIF - RETURN - END + RETURN + END diff --git a/src/numbck.f b/src/numbck.f index 0d8a6f80..95b4b7f3 100644 --- a/src/numbck.f +++ b/src/numbck.f @@ -11,7 +11,7 @@ C> 2007-01-19 | J. Ator | Cleaned up and simplified logic. C> C> @author Woollen @date 1994-01-06 - + C> This function checks the input character string to determine C> whether it contains a valid FXY (descriptor) value. C> diff --git a/src/nummtb.c b/src/nummtb.c index 215ac95b..eb054fd7 100644 --- a/src/nummtb.c +++ b/src/nummtb.c @@ -29,31 +29,31 @@ */ void nummtb( f77int *idn, char *tab, f77int *ipt ) { - f77int *pifxyn, *pbs, nmt; + f77int *pifxyn, *pbs, nmt; - char adn[7], errstr[129]; + char adn[7], errstr[129]; - if ( *idn >= ifxy( "300000", 6 ) ) { - *tab = 'D'; - pifxyn = &idfxyn_c[0]; - nmt = nmtd_c; - } - else { - *tab = 'B'; - pifxyn = &ibfxyn_c[0]; - nmt = nmtb_c; - } + if ( *idn >= ifxy( "300000", 6 ) ) { + *tab = 'D'; + pifxyn = &idfxyn_c[0]; + nmt = nmtd_c; + } + else { + *tab = 'B'; + pifxyn = &ibfxyn_c[0]; + nmt = nmtb_c; + } pbs = ( f77int * ) bsearch( idn, pifxyn, ( size_t ) nmt, sizeof( f77int ), - ( int (*) ( const void *, const void * ) ) cmpia ); + ( 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; + 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; + return; } diff --git a/src/numtbd.f b/src/numtbd.f index acc024cd..a1f2bcb7 100644 --- a/src/numtbd.f +++ b/src/numtbd.f @@ -16,7 +16,7 @@ C> @param[out] TAB -- character: Type associated with IDN C> - 'B' = Table B descriptor C> - 'D' = Table D descriptor -C> @param[out] IRET -- integer: +C> @param[out] IRET -- integer: C> - Positional index of IDN within internal C> Table B, if TAB = 'B' C> - Positional index of IDN within internal diff --git a/src/nvnwin.f b/src/nvnwin.f index 2d302748..8121bd4b 100644 --- a/src/nvnwin.f +++ b/src/nvnwin.f @@ -15,11 +15,11 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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> stack of "event" indices for the requested node. C> C> @param[in] NODE - integer: jump/link table index to look for. C> @param[in] LUN - integer: i/o stream index into internal memory arrays. diff --git a/src/nwords.f b/src/nwords.f index 1c692662..b1a592b1 100644 --- a/src/nwords.f +++ b/src/nwords.f @@ -12,7 +12,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1996-10-09 - + C> This function adds up the complete length of the delayed C> replication sequence beginning at index N of the data subset. C> diff --git a/src/nxtwin.f b/src/nxtwin.f index dc06e222..8350f29a 100644 --- a/src/nxtwin.f +++ b/src/nxtwin.f @@ -1,5 +1,5 @@ C> @file -C> @brief Computes the start and end indices of the next window. +C> @brief Computes the start and end indices of the next window. C> C> ### Program History Log C> Date | Programmer | Comments @@ -15,7 +15,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author WOOLLEN @date 1994-01-06 - + C> Given indices within the internal jump/link table which C> point to the start and end of an "rpc" window (which is an iteration of C> an 8-bit or 16-bit delayed replication sequence), this subroutine diff --git a/src/openbf.f b/src/openbf.f index 63a2e44b..8df37447 100644 --- a/src/openbf.f +++ b/src/openbf.f @@ -93,10 +93,10 @@ 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> - 'SEC3' = same as 'IN', except use Section 3 of input C> messages for decoding rather than DX BUFR C> table information from LUNDX; in this case -C> LUNDX is ignored, and user must provide +C> LUNDX is ignored, and user must provide C> appropriate [master BUFR tables](@ref dfbfmstab) C> within the directory specified by a subsequent C> call to subroutine mtinfo() @@ -153,7 +153,7 @@ RECURSIVE SUBROUTINE OPENBF(LUNIT,IO,LUNDX) COMMON /QUIET / IPRT CHARACTER*(*) IO - CHARACTER*255 FILENAME,FILEACC + CHARACTER*255 FILENAME,FILEACC CHARACTER*128 BORT_STR,ERRSTR CHARACTER*28 CPRINT(0:3) CHARACTER*1 BSTR(4) @@ -215,7 +215,7 @@ RECURSIVE SUBROUTINE OPENBF(LUNIT,IO,LUNDX) C Figure out some important information about the local machine. CALL WRDLEN - + C Initialize some global variables. CALL BFRINI diff --git a/src/pad.f b/src/pad.f index 206f8d4a..b06b762d 100644 --- a/src/pad.f +++ b/src/pad.f @@ -11,7 +11,7 @@ C> 2003-11-04 | D. Keyser | Unified/portable for wrf; documentation; outputs more info. C> C> @author Woollen @date 1994-01-06 - + C> 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 @@ -33,7 +33,7 @@ C> - on output, contains BUFR data subset padded with zeroed-out bits up to IPADB C> @param[inout] IBIT - integer: C> - on input, contains bit pointer within IBAY after which to begin padding. -C> - on output, contains bit pointer within IBAY to last bit that was padded. +C> - on output, contains bit pointer within IBAY to last bit that was padded. C> @param[out] IBYT - integer: number of bytes within IBAY containing packed data, C> including padding C> @param[in] IPADB - integer: bit boundary to pad to (must be a multiple of 8). diff --git a/src/padmsg.f b/src/padmsg.f index 2ec415c0..84e5f7ac 100644 --- a/src/padmsg.f +++ b/src/padmsg.f @@ -2,7 +2,7 @@ C> @brief Pad a BUFR message with zeroed-out bytes up to the C> next 8-byte boundary. C> @author Ator @date 2005-11-29 - + C> 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> @@ -15,31 +15,31 @@ C> @param[out] NPBYT - integer: number of zeroed-out bytes appended to MESG. C> C> @author Ator @date 2005-11-29 - SUBROUTINE PADMSG(MESG,LMESG,NPBYT) + SUBROUTINE PADMSG(MESG,LMESG,NPBYT) - COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) + COMMON /HRDWRD/ NBYTW,NBITW,IORD(8) - DIMENSION MESG(*) + 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. +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 + NMW = NMWRD(MESG) + IF(NMW.GT.LMESG) GOTO 900 -C Pad from the end of the message up to the next 8-byte boundary. +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 + NMB = IUPBS01(MESG,'LENM') + IBIT = NMB*8 + NPBYT = ( NMW * NBYTW ) - NMB + DO I = 1, NPBYT + CALL PKB(0,8,MESG,IBIT) + ENDDO - RETURN + RETURN 900 CALL BORT('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE '// . 'ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') - END + END diff --git a/src/parstr.f b/src/parstr.f index cd8ba56d..7e87e180 100644 --- a/src/parstr.f +++ b/src/parstr.f @@ -1,7 +1,7 @@ C> @file C> @brief Parse a string containing one or more substrings into an array of substrings. C> @author J. Ator @date 2007-01-19 - + C> 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 diff --git a/src/parusr.f b/src/parusr.f index 890a3dea..7f63b39a 100644 --- a/src/parusr.f +++ b/src/parusr.f @@ -12,7 +12,7 @@ C> 2009-05-07 | J. Ator | Use lstjpb instead of lstrpc. C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/parutg.f b/src/parutg.f index fb1e5dfc..812b1cef 100644 --- a/src/parutg.f +++ b/src/parutg.f @@ -1,6 +1,6 @@ C> @file C> @brief Parse a mnemonic from a character string. -C> +C> C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|---------- @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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 @@ -58,7 +58,7 @@ C> @endcode 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> 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: @@ -172,7 +172,7 @@ SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL) 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. +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) diff --git a/src/pkb8.f b/src/pkb8.f index 10d2443d..f4b68deb 100644 --- a/src/pkb8.f +++ b/src/pkb8.f @@ -22,7 +22,7 @@ C> - This subroutine is the logical inverse of subroutine up8(). C> - This subroutine will not work properly if NBITS is less than 0 or C> greater than 64, as determined via an internal call to subroutine -C> wrdlen(). +C> wrdlen(). C> C> Program history log: C> | Date | Programmer | Comments | diff --git a/src/pkbs1.f b/src/pkbs1.f index a5d13d28..355dd562 100644 --- a/src/pkbs1.f +++ b/src/pkbs1.f @@ -14,7 +14,7 @@ C> @authors J. Ator C> @authors D. Keyser C> @date 2005-11-29 -C> +C> C> @param[in] IVAL -- integer: Value to be stored C> @param[in,out] MBAY -- integer(*): BUFR message C> @param[in] S1MNEM -- character*(*): Location in Section 1 of @@ -55,61 +55,61 @@ C> | 2006-04-14 | D. Keyser | Added options for 'MTYP', 'MSBT', 'YEAR', 'MNTH', 'DAYS', 'HOUR', 'YCEN' and 'CENT' | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE SUBROUTINE PKBS1(IVAL,MBAY,S1MNEM) + RECURSIVE SUBROUTINE PKBS1(IVAL,MBAY,S1MNEM) - USE MODV_IM8B + USE MODV_IM8B - DIMENSION MBAY(*) + DIMENSION MBAY(*) - CHARACTER*(*) S1MNEM + CHARACTER*(*) S1MNEM - CHARACTER*128 BORT_STR + CHARACTER*128 BORT_STR C----------------------------------------------------------------------- C----------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF (IM8B) THEN - IM8B = .FALSE. + IF (IM8B) THEN + IM8B = .FALSE. - CALL X84(IVAL,MY_IVAL,1) - CALL PKBS1(MY_IVAL,MBAY,S1MNEM) + CALL X84(IVAL,MY_IVAL,1) + CALL PKBS1(MY_IVAL,MBAY,S1MNEM) - IM8B = .TRUE. - RETURN - END IF + IM8B = .TRUE. + RETURN + END IF -C Note that the following call to function IUPBS01 will ensure -C that subroutine WRDLEN has been called. +C Note that the following call to function IUPBS01 will ensure +C that subroutine WRDLEN has been called. - IBEN = IUPBS01(MBAY,'BEN') + IBEN = IUPBS01(MBAY,'BEN') -C Determine where to store the value. +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 + 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. +C Store the value. - IBIT = (IUPBS01(MBAY,'LEN0')+ISBYT-1)*8 - CALL PKB(IVAL,IWID,MBAY,IBIT) - ELSE - GOTO 900 - ENDIF + 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 + 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 diff --git a/src/pktdd.f b/src/pktdd.f index 73559abe..8fd0d427 100644 --- a/src/pktdd.f +++ b/src/pktdd.f @@ -14,7 +14,7 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/posapx.f b/src/posapx.f index 9e7febbb..5c27aa7f 100644 --- a/src/posapx.f +++ b/src/posapx.f @@ -1,6 +1,6 @@ C> @file C> @brief Position an output BUFR file for appending. -C> +C> C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|---------- @@ -14,13 +14,13 @@ 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; replace fortran backspace with c backbufr remove unecessary error checking logic. C> 2014-12-10 | J. Ator | Use modules instead of common blocks. -C> +C> C> @author Woollen @date 1994-01-06 - + C> 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. -C> +C> C< If LUNXX > 0, then the file is backspaced before being positioned for append. C> If LUNXX < 0, then the file is not backspaced before being positioned for append. C> @@ -48,13 +48,13 @@ SUBROUTINE POSAPX(LUNXX) 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. +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) + CALL BACKBUFR(LUN) !BACKSPACE LUNIT + CALL RDBFDX(LUNIT,LUN) ENDIF GOTO 1 diff --git a/src/rbytes.c b/src/rbytes.c index b1aef490..a94c2767 100644 --- a/src/rbytes.c +++ b/src/rbytes.c @@ -42,13 +42,13 @@ f77int rbytes( char *bmg, f77int *mxmb, f77int isloc, f77int newbytes ) short iret; if ( ( isloc + newbytes ) > *mxmb ) { - iret = 1; + iret = 1; } else if ( fread( &bmg[isloc], 1, newbytes, pbf[0] ) != newbytes ) { - iret = ( feof(pbf[0]) ? -1 : -2 ); + iret = ( feof(pbf[0]) ? -1 : -2 ); } else { - iret = 0; + iret = 0; } return (f77int) iret; diff --git a/src/rcstpl.f b/src/rcstpl.f index 70919033..b3dcbd8b 100644 --- a/src/rcstpl.f +++ b/src/rcstpl.f @@ -17,8 +17,8 @@ C> 2016-11-09 | J. Ator | Added iret argument and check for possibly corrupt subsets. C> C> @author Woollen @date 1994-01-06 - -C> This subroutine initializes space in internal subset array + +C> This subroutine initializes space in internal subset array C> space (inv and val) in modules usrint and usrbit, according C> to the subset definition from subroutine maksetab. This is in C> preparation for the actual unpacking of the subset in rdtree(). diff --git a/src/rdbfdx.f b/src/rdbfdx.f index 9fd98b25..8b75304a 100644 --- a/src/rdbfdx.f +++ b/src/rdbfdx.f @@ -2,7 +2,7 @@ C> @brief Read a complete DX BUFR table. C> C> ### Program History -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | Original author. C> 1995-06-28 | J. Woollen | Increased the size of internal bufr table arrays in order to handle bigger files @@ -19,13 +19,13 @@ C> 2014-12-10 | J. Ator | Use modules instead of common blocks. C> C> @author Woollen @date 1994-01-06 - + C> Beginning at the current file pointer location within LUNIT, C> this subroutine reads a complete DX BUFR table into internal memory arrays C> in module tababd. A DX BUFR table consists of one or more consecutive C> DX BUFR messages. C> -C> This subroutine performs a function similar to +C> This subroutine performs a function similar to C> rdusdx(), except that rdusdx() reads from a file containing C> a user-supplied DX BUFR table in character format. See rdusdx() C> for a description of the arrays that are filled @@ -43,80 +43,80 @@ C> @author Woollen @date 1994-01-06 SUBROUTINE RDBFDX(LUNIT,LUN) - USE MODA_MGWA + USE MODA_MGWA - COMMON /QUIET/ IPRT + COMMON /QUIET/ IPRT - CHARACTER*128 ERRSTR + CHARACTER*128 ERRSTR - LOGICAL DONE + LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- - CALL DXINIT(LUN,0) + CALL DXINIT(LUN,0) - ICT = 0 - DONE = .FALSE. + ICT = 0 + DONE = .FALSE. -C Read a complete dictionary table from LUNIT, as a set of one or -C more DX dictionary messages. +C Read a complete dictionary table from LUNIT, as a set of one or +C more DX dictionary messages. - DO WHILE ( .NOT. DONE ) + 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. +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. + CALL BACKBUFR(LUN) + DONE = .TRUE. ELSE IF ( IER .EQ. -2 ) THEN - GOTO 900 - ELSE IF ( IDXMSG(MGWA) .NE. 1 ) 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. +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 + 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. +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 + DONE = .TRUE. + ELSE -C Store this message into MODULE TABABD. +C Store this message into MODULE TABABD. ICT = ICT + 1 - CALL STBFDX(LUN,MGWA) - ENDIF - ENDDO + CALL STBFDX(LUN,MGWA) + ENDIF + ENDDO - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) + 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 '// + 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(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') - ENDIF + ENDIF - CALL MAKESTAB + CALL MAKESTAB - RETURN - 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// + RETURN + 900 CALL BORT('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY '// . 'MESSAGE') - END + END diff --git a/src/rdcmps.f b/src/rdcmps.f index 7d03e57c..3bcb5541 100644 --- a/src/rdcmps.f +++ b/src/rdcmps.f @@ -2,7 +2,7 @@ C> @brief Read the next compressed BUFR data subset into internal arrays. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 2000-09-19 | J. Woollen | Original author. C> 2002-05-14 | J. Woollen | Improved generality, previously rdcmps would not recognize compressed delayed replication as a legitimate data structure. @@ -17,7 +17,7 @@ C> 2022-05-06 | J. Woollen | Use up8 for 8byte integer operation. C> C> @author Woollen @date 2000-09-19 - + C> 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 diff --git a/src/rdmemm.f b/src/rdmemm.f index bab0ae1c..ed8547ae 100644 --- a/src/rdmemm.f +++ b/src/rdmemm.f @@ -35,7 +35,7 @@ C> successfully read into scope C> - -1 = requested message number could not C> be found in internal arrays -C> +C> C> Program history log: C> | Date | Programmer | Comments | C> | -----|------------|----------| @@ -124,11 +124,11 @@ RECURSIVE SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET) 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 + IF (IPMSGS(JJ).LE.IMSG) THEN + KNOWN = .TRUE. + ELSE + JJ = JJ - 1 + ENDIF ENDDO IF (.NOT.KNOWN) GOTO 902 @@ -136,39 +136,39 @@ RECURSIVE SUBROUTINE RDMEMM(IMSG,SUBSET,JDATE,IRET) IF (JJ.NE.LDXTS) THEN -C No, so reset the software to use the proper table. +C No, so reset the software to use the proper table. - IF(IPRT.GE.2) THEN + 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, + . '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 + 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 diff --git a/src/rdmsgw.f b/src/rdmsgw.f index 3d1dd53b..1baa6710 100644 --- a/src/rdmsgw.f +++ b/src/rdmsgw.f @@ -2,14 +2,14 @@ C> @brief Read a BUFR message. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- 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 | C i/o interface; use C routine crdbufr(); remove code which checks sec0 and message length. C> C> @author J. Ator @date 2005-11-29 - + C> This subroutine reads the next BUFR message from logical C> unit LUNIT as an array of integer words. C> diff --git a/src/rdmtbb.f b/src/rdmtbb.f index 0c543199..5752e0eb 100644 --- a/src/rdmtbb.f +++ b/src/rdmtbb.f @@ -58,73 +58,73 @@ C> | 2021-01-08 | J. Ator | Modified mstabs array declarations for GNUv10 portability | C> | 2021-05-17 | J. Ator | Allow up to 24 characters in cmunit | C> - SUBROUTINE RDMTBB ( LUNSTB, LUNLTB, MXMTBB, - . IMT, IMTV, IOGCE, ILTV, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) + SUBROUTINE RDMTBB ( LUNSTB, LUNLTB, MXMTBB, + . IMT, IMTV, IOGCE, ILTV, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) - CHARACTER*200 STLINE, LTLINE - CHARACTER*128 BORT_STR - CHARACTER*6 CMATCH, ADN30 - CHARACTER*4 CMDSC(*) - CHARACTER CMELEM(120,*) - CHARACTER CMUNIT(24,*) - CHARACTER CMSREF(12,*) - CHARACTER CMMNEM(8,*) - CHARACTER CMSCL(4,*), CMBW(4,*) + CHARACTER*200 STLINE, LTLINE + CHARACTER*128 BORT_STR + CHARACTER*6 CMATCH, ADN30 + CHARACTER*4 CMDSC(*) + CHARACTER CMELEM(120,*) + CHARACTER CMUNIT(24,*) + CHARACTER CMSREF(12,*) + CHARACTER CMMNEM(8,*) + CHARACTER CMSCL(4,*), CMBW(4,*) - INTEGER IMFXYN(*) + 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. +C Call WRDLEN to initialize some important information about the +C local machine, just in case it hasn't already been called. - CALL WRDLEN + CALL WRDLEN -C Read and parse the header lines of both files. +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. + CALL GETTBH ( LUNSTB, LUNLTB, 'B', IMT, IMTV, IOGCE, ILTV ) - 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 +C Read through the remainder of both files, merging the +C contents into a unified set of master Table B arrays. - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBB - STANDARD AND LOCAL'// + 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 + . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) + CALL BORT(BORT_STR) + END diff --git a/src/rdmtbd.f b/src/rdmtbd.f index 4ec6861a..bd31539b 100644 --- a/src/rdmtbd.f +++ b/src/rdmtbd.f @@ -60,72 +60,72 @@ C> | 2007-01-19 | J. Ator | Original author | C> | 2021-01-08 | J. Ator | Modified mstabs array declarations for GNUv10 portability | C> - SUBROUTINE RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, - . IMT, IMTV, IOGCE, ILTV, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) + SUBROUTINE RDMTBD ( LUNSTD, LUNLTD, MXMTBD, MXELEM, + . IMT, IMTV, IOGCE, ILTV, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) - CHARACTER*200 STLINE, LTLINE - CHARACTER*128 BORT_STR - CHARACTER*120 CEELEM(MXMTBD,MXELEM) - CHARACTER*6 CMATCH, ADN30 - CHARACTER*4 CMDSC(*) - CHARACTER CMSEQ(120,*) - CHARACTER CMMNEM(8,*) + CHARACTER*200 STLINE, LTLINE + CHARACTER*128 BORT_STR + CHARACTER*120 CEELEM(MXMTBD,MXELEM) + CHARACTER*6 CMATCH, ADN30 + CHARACTER*4 CMDSC(*) + CHARACTER CMSEQ(120,*) + CHARACTER CMMNEM(8,*) - INTEGER IMFXYN(*), NMELEM(*), - . IEFXYN(MXMTBD,MXELEM) + 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. +C Call WRDLEN to initialize some important information about the +C local machine, just in case it hasn't already been called. - CALL WRDLEN + CALL WRDLEN -C Read and parse the header lines of both files. +C Read and parse the header lines of both files. - CALL GETTBH ( LUNSTD, LUNLTD, 'D', IMT, IMTV, IOGCE, ILTV ) + 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. +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 + 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'// + 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 + . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) + CALL BORT(BORT_STR) + END diff --git a/src/rdmtbf.f b/src/rdmtbf.f index f5cd8487..3a1ec19e 100644 --- a/src/rdmtbf.f +++ b/src/rdmtbf.f @@ -23,62 +23,62 @@ C> | -----|------------|----------| C> | 2017-10-17 | J. Ator | Original author | C> - SUBROUTINE RDMTBF ( LUNSTF, LUNLTF ) + SUBROUTINE RDMTBF ( LUNSTF, LUNLTF ) - CHARACTER*160 STLINE, LTLINE - CHARACTER*128 BORT_STR - CHARACTER*6 CMATCH, ADN30 + 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. +C Call WRDLEN to initialize some important information about the +C local machine, just in case it hasn't already been called. - CALL WRDLEN + CALL WRDLEN -C Initialize the internal memory structure, including allocating -C space for it in case this hasn't already been done. +C Initialize the internal memory structure, including allocating +C space for it in case this hasn't already been done. - CALL INITTBF + CALL INITTBF -C Read and parse the header lines of both files. +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 GETTBH ( LUNSTF, LUNLTF, 'F', IMT, IMTV, IOGCE, ILTV ) - 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 Read through the remainder of both files, merging the +C contents into a unified internal memory structure. -C Sort the contents of the 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 - CALL SORTTBF +C Sort the contents of the internal memory structure. - RETURN - 900 WRITE(BORT_STR,'("BUFRLIB: RDMTBF - STANDARD AND LOCAL'// + 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 + . CMATCH(1:1), '-', CMATCH(2:3), '-', CMATCH(4:6) + CALL BORT(BORT_STR) + END diff --git a/src/rdtree.f b/src/rdtree.f index a94e4e75..c21e7b15 100644 --- a/src/rdtree.f +++ b/src/rdtree.f @@ -2,7 +2,7 @@ C> @brief Read the next uncompressed BUFR data subset into internal arrays. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | original author C> 1998-10-27 | J. Woollen | modified to correct problems caused by in- lining code with fpp directives @@ -17,10 +17,10 @@ C> 2012-06-04 | J. Ator | set decoded real*8 value to "missing" when corresponding character field has all bits 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 corrupt subsets -C> 2022-05-06 | J. Woollen | replace upbb with upb8 for 8byte integers +C> 2022-05-06 | J. Woollen | replace upbb with upb8 for 8byte integers C> C> @author Woollen @date 1994-01-06 - + C> 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) @@ -77,12 +77,12 @@ SUBROUTINE RDTREE(LUN,IRET) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN -C The unpacked value is a delayed descriptor replication factor. +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. +C The unpacked value is a real. IF (IVAL(N).LT.2_8**ibt(node)-1) THEN VAL(N,LUN) = UPS(IVAL(N),NODE) diff --git a/src/rdusdx.f b/src/rdusdx.f index 72e69843..eb107d1b 100644 --- a/src/rdusdx.f +++ b/src/rdusdx.f @@ -1,8 +1,8 @@ C> @file C> @brief Read a complete DX BUFR table. -C> +C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | original author C> 1995-06-28 | J. Woollen | increased the size of internal bufr table arrays in order to handle bigger files @@ -19,7 +19,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author Woollen @date 1994-01-06 - + C> This subroutine reads and parses a file containing a user- c> supplied DX BUFR table in character format, and then stores c> this information into internal arrays in module tababd. @@ -99,19 +99,19 @@ SUBROUTINE RDUSDX(LUNDX,LUN) 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 + 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' + 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:) ) + CALL STNTBI ( IGETNTBI(LUN,'B'), LUN, NUMB, NEMO, CARD(23:) ) GOTO 1 ENDIF @@ -119,7 +119,7 @@ SUBROUTINE RDUSDX(LUNDX,LUN) C ------------------------ IF(NUMB(1:1).EQ.'3') THEN - CALL STNTBI ( IGETNTBI(LUN,'D'), LUN, NUMB, NEMO, CARD(23:) ) + CALL STNTBI ( IGETNTBI(LUN,'D'), LUN, NUMB, NEMO, CARD(23:) ) GOTO 1 ENDIF diff --git a/src/readdx.f b/src/readdx.f index 9cfca545..a3c3e1ec 100644 --- a/src/readdx.f +++ b/src/readdx.f @@ -2,7 +2,7 @@ C> @brief Read DX BUFR table information into internal arrays. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | original author C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with call to bort() @@ -11,7 +11,7 @@ C> 2009-04-21 | J. Ator | use errwrt C> C> @author Woollen @date 1994-01-06 - + C> This subroutine generates internal arrays containing DX BUFR C> (dictionary) tables which are needed to read, write, initialize or C> append a BUFR file. The information used to create the internal diff --git a/src/readerme.f b/src/readerme.f index 72f0be4b..e8e6d7b0 100644 --- a/src/readerme.f +++ b/src/readerme.f @@ -158,52 +158,52 @@ RECURSIVE SUBROUTINE READERME(MESG,LUNIT,SUBSET,JDATE,IRET) 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. +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 + 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. +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. + IF(IDRDM(LUN).GT.0) THEN + ENDTBL = .TRUE. ENDIF - ELSE - IF(IDRDM(LUN).EQ.0) THEN + ELSE + IF(IDRDM(LUN).EQ.0) THEN -C This is the first DX dictionary message that is part of a -C new dictionary table. +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 + 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 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. +C end of the dictionary table. - ENDTBL = .TRUE. + ENDTBL = .TRUE. ENDIF IF(ENDTBL) THEN - IF ( IPRT .GE. 2 ) THEN - CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') - WRITE ( UNIT=ERRSTR, FMT='(A,I3,A)' ) + 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 '// + 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(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') - ENDIF - IDRDM(LUN) = 0 - CALL MAKESTAB + ENDIF + IDRDM(LUN) = 0 + CALL MAKESTAB ENDIF C EXITS diff --git a/src/readmg.f b/src/readmg.f index 6bd23064..89bc401d 100644 --- a/src/readmg.f +++ b/src/readmg.f @@ -49,7 +49,7 @@ C> from ABS(LUNXX) the same as an end-of-file condition. This option is C> no longer supported, but the capability to call this subroutine with C> LUNXX < 0 is itself still supported for backwards-compatibility with -C> certain legacy application programs. +C> certain legacy application programs. C> C> Program history log: C> | Date | Programmer | Comments | @@ -139,7 +139,7 @@ RECURSIVE SUBROUTINE READMG(LUNXX,SUBSET,JDATE,IRET) C all such dictionary messages (they should be stored C consecutively!) and reset the internal tables. - CALL BACKBUFR(LUN) + CALL BACKBUFR(LUN) CALL RDBFDX(LUNIT,LUN) IF(IPRT.GE.1) THEN diff --git a/src/reads3.f b/src/reads3.f index 30dba6ee..1e58ce54 100644 --- a/src/reads3.f +++ b/src/reads3.f @@ -1,15 +1,15 @@ C> @file C> @brief Read the Section 3 descriptors from a BUFR message. -C> +C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- 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 master tables need to be read -C> +C> C> @author J. Ator @date 2009-03-23 - + C> 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 @@ -18,139 +18,139 @@ C> @param[in] LUN - integer: I/O stream index into internal memory arrays. C> C> @author J. Ator @date 2009-03-23 - SUBROUTINE READS3 ( LUN ) + SUBROUTINE READS3 ( LUN ) - USE MODA_SC3BFR - USE MODA_BITBUF + USE MODA_SC3BFR + USE MODA_BITBUF USE MODA_DSCACH - COMMON /QUIET/ IPRT + COMMON /QUIET/ IPRT - DIMENSION IDS3(MAXNC) - CHARACTER*6 CDS3(MAXNC),NUMB,ADN30 + DIMENSION IDS3(MAXNC) + CHARACTER*6 CDS3(MAXNC),NUMB,ADN30 - CHARACTER*55 CSEQ + CHARACTER*55 CSEQ - CHARACTER*128 ERRSTR + CHARACTER*128 ERRSTR - LOGICAL INCACH + LOGICAL INCACH - SAVE IREPCT + 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('+++++++++++++++++++++++++++++++++++++++++++++++++') +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 ' // + 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(ERRSTR) + CALL ERRWRT('+++++++++++++++++++++++++++++++++++++++++++++++++') CALL ERRWRT(' ') - ENDIF + ENDIF + +C* Get an FXY value to use with this Table A mnemonic. -C* Get an FXY value to use with this Table A mnemonic. - - IDN = IGETTDI ( LUN ) - NUMB = ADN30 ( IDN, 6 ) + IDN = IGETTDI ( LUN ) + NUMB = ADN30 ( IDN, 6 ) -C* Store all of the information for this mnemonic within the -C* internal Table A. +C* Store all of the information for this mnemonic within the +C* internal Table A. - CALL STNTBIA ( N, LUN, NUMB, TAMNEM(LUN), CSEQ ) + 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. +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 ) + CALL STSEQ ( LUN, IREPCT, IDN, TAMNEM(LUN), CSEQ, IDS3, NCDS3 ) -C* Update the jump/link table. +C* Update the jump/link table. - CALL MAKESTAB + CALL MAKESTAB - RETURN -900 CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW') - END + RETURN +900 CALL BORT('BUFRLIB: READS3 - MXCNEM OVERFLOW') + END diff --git a/src/readsb.f b/src/readsb.f index 65763dbb..e2769786 100644 --- a/src/readsb.f +++ b/src/readsb.f @@ -1,6 +1,6 @@ C> @file C> @brief Read the next data subset from a BUFR message. - + C> This subroutine reads the next data subset from a BUFR C> message into internal arrays. C> @@ -17,7 +17,7 @@ C>

Logical unit LUNIT should have already been opened for C> input operations via a previous call to subroutine openbf(), and a C> BUFR message should have already been read into internal arrays via -C> a previous call to one of the +C> a previous call to one of the C> [message-reading subroutines](@ref hierarchy). C> C>

Whenever this subroutine returns with IRET = 0, this indicates diff --git a/src/restd.c b/src/restd.c index 00af2f05..1922d30a 100644 --- a/src/restd.c +++ b/src/restd.c @@ -62,73 +62,73 @@ void restd( f77int *lun, f77int *tddesc, f77int *nctddesc, f77int *ctddesc ) ** Examine each child descriptor one at a time. */ for ( i = 1; i <= inum; i++ ) { - uptdd( &itbd, lun, &i, &desc ); - if (! istdesc( &desc ) ) { + 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 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 ); +** 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 ) ) ) { + 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] +** 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( cwork, "%c%02ld%c%c%c", - adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); - strncpy( adn, cwork, 6 ); adn[6] = '\0'; - ctddesc[(*nctddesc)-1] = ifxy( adn, 7 ); - } - else if ( ( *nctddesc > 1 ) && - ( ctddesc[(*nctddesc)-2] == ifxy( "101000", 6 ) ) ) { + cadn30( &ctddesc[(*nctddesc)-1], adn, 7 ); + sprintf( cwork, "%c%02ld%c%c%c", + adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); + strncpy( adn, cwork, 6 ); adn[6] = '\0'; + 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] +** 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( cwork, "%c%02ld%c%c%c", - adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); - strncpy( adn, cwork, 6 ); adn[6] = '\0'; - ctddesc[(*nctddesc)-2] = ifxy( adn, 7 ); - } + cadn30( &ctddesc[(*nctddesc)-2], adn, 7 ); + sprintf( cwork, "%c%02ld%c%c%c", + adn[0], (long) ncdesc, adn[3], adn[4], adn[5] ); + strncpy( adn, cwork, 6 ); adn[6] = '\0'; + ctddesc[(*nctddesc)-2] = ifxy( adn, 7 ); + } /* -** Add the child descriptors to the output list. +** Add the child descriptors to the output list. */ - for ( j = 0; j < ncdesc; j++ ) { - wrdesc( cdesc[j], ctddesc, nctddesc ); - } - - } - else if ( tab == 'B' ) { + 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( cwork, "%c%c%c%03ld", '2', '0', '6', (long) ibit ); - strncpy( adn, cwork, 6 ); adn[6] = '\0'; - wrdesc( ifxy( adn, 7 ), ctddesc, nctddesc ); - wrdesc( desc, ctddesc, nctddesc ); - } +** 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( cwork, "%c%c%c%03ld", '2', '0', '6', (long) ibit ); + strncpy( adn, cwork, 6 ); adn[6] = '\0'; + wrdesc( ifxy( adn, 7 ), ctddesc, nctddesc ); + wrdesc( desc, ctddesc, nctddesc ); + } } - else { + 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 ); - } +** 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; diff --git a/src/rewnbf.f b/src/rewnbf.f index 4b7b600b..a16abd8b 100644 --- a/src/rewnbf.f +++ b/src/rewnbf.f @@ -1,8 +1,8 @@ C> @file C> @brief Store or restore parameters associated with a BUFR file. -C> +C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 2003-11-04 | J. Woollen | original author (was in verification version but may have been in the production version at one time and then removed) C> 2003-11-04 | D. Keyser | unified/portable for wrf; added documentation; outputs more complete diagnostic info when routine terminates abnormally @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author Woollen @date 2003-11-04 - + C> This subroutine, depending on the value of ISR, will C> either: C> - store the current parameters associated with a BUFR file diff --git a/src/rsvfvm.f b/src/rsvfvm.f index 878c5ccd..0a053667 100644 --- a/src/rsvfvm.f +++ b/src/rsvfvm.f @@ -2,7 +2,7 @@ C> @brief Process a "following value" mnemonic. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | original author C> 2003-11-04 | J. Ator | added documentation @@ -10,7 +10,7 @@ C> 2003-11-04 | D. Keyser | unified/portable for wrf; added history documentation C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/rtrcpt.f b/src/rtrcpt.f index 2aa1d1fc..67fefca7 100644 --- a/src/rtrcpt.f +++ b/src/rtrcpt.f @@ -1,7 +1,7 @@ C> @file C> @brief Read the tank receipt time from Section 1 of a BUFR message. -C> This subroutine reads the tank receipt time (if one exists) from +C> This subroutine reads the tank receipt time (if one exists) from C> Section 1 of a BUFR message. It is similar to subroutine rtrcptb(), C> except that rtrcptb() operates on a BUFR message passed in via a C> memory array, whereas this subroutine operates on the BUFR message @@ -24,7 +24,7 @@ C> - -1 = no tank receipt time exists within the C> BUFR message currently open for input C> within internal arrays -C> +C> C> Program history log: C> | Date | Programmer | Comments | C> | -----|------------|----------| @@ -69,7 +69,7 @@ RECURSIVE SUBROUTINE RTRCPT(LUNIT,IYR,IMO,IDY,IHR,IMI,IRET) C Unpack the tank receipt time. CALL RTRCPTB(MBAY(1,LUN),IYR,IMO,IDY,IHR,IMI,IRET) - + C EXITS C ----- diff --git a/src/rtrcptb.f b/src/rtrcptb.f index 09b7b2bf..d50ec1fb 100644 --- a/src/rtrcptb.f +++ b/src/rtrcptb.f @@ -33,7 +33,7 @@ RECURSIVE SUBROUTINE RTRCPTB(MBAY,IYR,IMO,IDY,IHR,IMI,IRET) USE MODV_IM8B - DIMENSION MBAY (*) + DIMENSION MBAY (*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- @@ -60,9 +60,9 @@ RECURSIVE SUBROUTINE RTRCPTB(MBAY,IYR,IMO,IDY,IHR,IMI,IRET) C Check whether the message contains a tank receipt time. IF(IUPBS01(MBAY,'BEN').EQ.4) THEN - IS1BYT = 23 + IS1BYT = 23 ELSE - IS1BYT = 19 + IS1BYT = 19 ENDIF IF( (IS1BYT+5) .GT. IUPBS01(MBAY,'LEN1') ) RETURN diff --git a/src/seqsdx.f b/src/seqsdx.f index d9d88fda..ff7008d1 100644 --- a/src/seqsdx.f +++ b/src/seqsdx.f @@ -12,7 +12,7 @@ C> 2007-01-19 | J. Ator | replaced call to parseq with call to parstr C> C> @author Woollen @date 1994-01-06 - + C> This subroutine decodes the Table D sequence information C> from a mnemonic definition card that was previously read from a C> user-supplied DX BUFR table in character format by rdusdx(). diff --git a/src/setblock.f b/src/setblock.f index 9cd8a853..83158d1f 100644 --- a/src/setblock.f +++ b/src/setblock.f @@ -30,9 +30,9 @@ C> @param[in] IBLK -- integer: Flag indicating whether future BUFR C> output messages should be encapsulated with C> control words -C> - -1 = Yes, using little-endian control words +C> - -1 = Yes, using little-endian control words C> - 0 = No (the default) -C> - 1 = Yes, using big-endian control words +C> - 1 = Yes, using big-endian control words C> C> @remarks C> - This subroutine can be used to generate BUFR files consistent @@ -53,7 +53,7 @@ C> | 2012-09-15 | J. Woollen | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE SUBROUTINE SETBLOCK(IBLK) + RECURSIVE SUBROUTINE SETBLOCK(IBLK) USE MODV_IM8B @@ -75,7 +75,7 @@ RECURSIVE SUBROUTINE SETBLOCK(IBLK) ENDIF CALL OPENBF(0,'FIRST',0) - IBLOCK=IBLK + IBLOCK=IBLK RETURN END diff --git a/src/setbmiss.f b/src/setbmiss.f index 2112b029..057aa569 100644 --- a/src/setbmiss.f +++ b/src/setbmiss.f @@ -30,7 +30,7 @@ C> application program. In any actual BUFR data subset, "missing" C> values are always encoded as all bits set to 1, per WMO C> regulations. -C> +C> C> Program history log: C> | Date | Programmer | Comments | C> | -----|------------|----------| diff --git a/src/setvalnb.f b/src/setvalnb.f index 01452b46..afbfc9ef 100644 --- a/src/setvalnb.f +++ b/src/setvalnb.f @@ -10,7 +10,7 @@ C> it then searches in either a forward or backward direction for a C> specific occurrence of a nearby mnemonic, and if found C> stores the specified data value in the corresponding location -C> within the subset. +C> within the subset. C> C> @author J. Ator C> @date 2016-07-29 @@ -53,59 +53,59 @@ C> | 2016-07-29 | J. Ator | Original author | C> | 2022-10-04 | J. Ator | Added 8-byte wrapper | - RECURSIVE SUBROUTINE SETVALNB - . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB, R8VAL, IRET ) + RECURSIVE SUBROUTINE SETVALNB + . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB, R8VAL, IRET ) - USE MODA_USRINT - USE MODA_MSGCWD - USE MODA_TABLES - USE MODV_IM8B + USE MODA_USRINT + USE MODA_MSGCWD + USE MODA_TABLES + USE MODV_IM8B - CHARACTER*(*) TAGPV, TAGNB + CHARACTER*(*) TAGPV, TAGNB - REAL*8 R8VAL + REAL*8 R8VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C Check for I8 integers. +C Check for I8 integers. - IF(IM8B) THEN - IM8B=.FALSE. + IF(IM8B) THEN + IM8B=.FALSE. - CALL X84 ( LUNIT, MY_LUNIT, 1 ) - CALL X84 ( NTAGPV, MY_NTAGPV, 1 ) - CALL X84 ( NTAGNB, MY_NTAGNB, 1 ) - CALL SETVALNB ( MY_LUNIT, TAGPV, MY_NTAGPV, TAGNB, MY_NTAGNB, - . R8VAL, IRET ) - CALL X48 ( IRET, IRET, 1 ) + CALL X84 ( LUNIT, MY_LUNIT, 1 ) + CALL X84 ( NTAGPV, MY_NTAGPV, 1 ) + CALL X84 ( NTAGNB, MY_NTAGNB, 1 ) + CALL SETVALNB ( MY_LUNIT, TAGPV, MY_NTAGPV, TAGNB, MY_NTAGNB, + . R8VAL, IRET ) + CALL X48 ( IRET, IRET, 1 ) - IM8B=.TRUE. - RETURN - ENDIF + IM8B=.TRUE. + RETURN + ENDIF - IRET = -1 + IRET = -1 -C Get LUN from LUNIT. +C Get LUN from LUNIT. - CALL STATUS (LUNIT, LUN, IL, IM ) - IF ( IL .LE. 0 ) RETURN - IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN + 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. +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 + 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. +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 + CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IERFT ) + IF ( IERFT .NE. 0 ) RETURN - IRET = 0 - VAL(NNB,LUN) = R8VAL - - RETURN - END + IRET = 0 + VAL(NNB,LUN) = R8VAL + + RETURN + END diff --git a/src/sntbbe.f b/src/sntbbe.f index 858312b8..a4bee2d4 100644 --- a/src/sntbbe.f +++ b/src/sntbbe.f @@ -39,131 +39,131 @@ C> | 2021-05-17 | J. Ator | Allow up to 24 characters in cmunit | C> | 2021-09-30 | J. Ator | Replace jstchr with Fortran intrinsic adjustl; replace rjust with Fortran intrinsic adjustr | C> - SUBROUTINE SNTBBE ( IFXYN, LINE, MXMTBB, - . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, - . CMUNIT, CMMNEM, CMDSC, CMELEM ) - - CHARACTER*(*) LINE - CHARACTER*200 TAGS(10), WKTAG - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*4 CMDSC(*) - CHARACTER CMELEM(120,*) - CHARACTER CMUNIT(24,*) - CHARACTER CMSREF(12,*) - CHARACTER CMMNEM(8,*) - CHARACTER CMSCL(4,*), CMBW(4,*) - - INTEGER IMFXYN(*) + SUBROUTINE SNTBBE ( IFXYN, LINE, MXMTBB, + . NMTBB, IMFXYN, CMSCL, CMSREF, CMBW, + . CMUNIT, CMMNEM, CMDSC, CMELEM ) + + CHARACTER*(*) LINE + CHARACTER*200 TAGS(10), WKTAG + CHARACTER*128 BORT_STR1, BORT_STR2 + CHARACTER*4 CMDSC(*) + CHARACTER CMELEM(120,*) + CHARACTER CMUNIT(24,*) + CHARACTER CMSREF(12,*) + CHARACTER CMMNEM(8,*) + CHARACTER CMSCL(4,*), CMBW(4,*) + + INTEGER IMFXYN(*) C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IF ( NMTBB .GE. MXMTBB ) GOTO 900 - NMTBB = NMTBB + 1 + IF ( NMTBB .GE. MXMTBB ) GOTO 900 + NMTBB = NMTBB + 1 -C Store the FXY number. This is the element descriptor. +C Store the FXY number. This is the element descriptor. - IMFXYN ( NMTBB ) = IFXYN + IMFXYN ( NMTBB ) = IFXYN -C Parse the table entry. +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 + CALL PARSTR ( LINE, TAGS, 10, NTAG, '|', .FALSE. ) + IF ( NTAG .LT. 4 ) THEN + BORT_STR2 = ' HAS TOO FEW FIELDS' + GOTO 901 + ENDIF -C Scale factor. +C Scale factor. - TAGS(2) = ADJUSTL( TAGS(2) ) - IF ( TAGS(2) .EQ. ' ' ) THEN - BORT_STR2 = ' HAS MISSING SCALE FACTOR' - GOTO 901 - ENDIF - TAGS(2)(1:4) = ADJUSTR( TAGS(2)(1:4) ) + TAGS(2) = ADJUSTL( TAGS(2) ) + IF ( TAGS(2) .EQ. ' ' ) THEN + BORT_STR2 = ' HAS MISSING SCALE FACTOR' + GOTO 901 + ENDIF + TAGS(2)(1:4) = ADJUSTR( TAGS(2)(1:4) ) DO II = 1, 4 - CMSCL ( II, NMTBB ) = TAGS(2)(II:II) + CMSCL ( II, NMTBB ) = TAGS(2)(II:II) ENDDO -C Reference value. +C Reference value. - TAGS(3) = ADJUSTL( TAGS(3) ) - IF ( TAGS(3) .EQ. ' ' ) THEN - BORT_STR2 = ' HAS MISSING REFERENCE VALUE' - GOTO 901 - ENDIF - TAGS(3)(1:12) = ADJUSTR( TAGS(3)(1:12) ) + TAGS(3) = ADJUSTL( TAGS(3) ) + IF ( TAGS(3) .EQ. ' ' ) THEN + BORT_STR2 = ' HAS MISSING REFERENCE VALUE' + GOTO 901 + ENDIF + TAGS(3)(1:12) = ADJUSTR( TAGS(3)(1:12) ) DO II = 1, 12 - CMSREF ( II, NMTBB ) = TAGS(3)(II:II) + CMSREF ( II, NMTBB ) = TAGS(3)(II:II) ENDDO -C Bit width. +C Bit width. - TAGS(4) = ADJUSTL( TAGS(4) ) - IF ( TAGS(4) .EQ. ' ' ) THEN - BORT_STR2 = ' HAS MISSING BIT WIDTH' - GOTO 901 - ENDIF - TAGS(4)(1:4) = ADJUSTR( TAGS(4)(1:4) ) + TAGS(4) = ADJUSTL( TAGS(4) ) + IF ( TAGS(4) .EQ. ' ' ) THEN + BORT_STR2 = ' HAS MISSING BIT WIDTH' + GOTO 901 + ENDIF + TAGS(4)(1:4) = ADJUSTR( TAGS(4)(1:4) ) DO II = 1, 4 - CMBW ( II, NMTBB ) = TAGS(4)(II:II) + CMBW ( II, NMTBB ) = TAGS(4)(II:II) END DO -C Units. Note that this field is allowed to be blank. +C Units. Note that this field is allowed to be blank. - IF ( NTAG .GT. 4 ) THEN - TAGS(5) = ADJUSTL( TAGS(5) ) + IF ( NTAG .GT. 4 ) THEN + TAGS(5) = ADJUSTL( TAGS(5) ) DO II = 1, 24 - CMUNIT ( II, NMTBB ) = TAGS(5)(II:II) + CMUNIT ( II, NMTBB ) = TAGS(5)(II:II) ENDDO - ELSE + ELSE DO II = 1, 24 - CMUNIT ( II, NMTBB ) = ' ' + CMUNIT ( II, NMTBB ) = ' ' ENDDO - ENDIF + ENDIF -C Comment (additional) fields. Any of these fields may be blank. +C Comment (additional) fields. Any of these fields may be blank. - CMDSC ( NMTBB ) = ' ' + CMDSC ( NMTBB ) = ' ' DO II = 1, 8 - CMMNEM ( II, NMTBB ) = ' ' + CMMNEM ( II, NMTBB ) = ' ' ENDDO - DO II = 1, 120 - CMELEM ( II, NMTBB ) = ' ' + DO II = 1, 120 + CMELEM ( II, NMTBB ) = ' ' ENDDO - 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. - TAGS(1) = ADJUSTL( TAGS(1) ) -C If there is a mnemonic, then make sure it's legal. - IF ( ( TAGS(1) .NE. ' ' ) .AND. - . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN - BORT_STR2 = ' HAS ILLEGAL MNEMONIC' - GOTO 901 - ENDIF + 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. + TAGS(1) = ADJUSTL( TAGS(1) ) +C If there is a mnemonic, then make sure it's legal. + IF ( ( TAGS(1) .NE. ' ' ) .AND. + . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN + BORT_STR2 = ' HAS ILLEGAL MNEMONIC' + GOTO 901 + ENDIF DO II = 1, 8 - CMMNEM ( II, NMTBB ) = TAGS(1)(II:II) + CMMNEM ( II, NMTBB ) = TAGS(1)(II:II) ENDDO - ENDIF - IF ( NTAG .GT. 1 ) THEN -C The second additional field contains descriptor codes. - TAGS(2) = ADJUSTL( TAGS(2) ) - CMDSC ( NMTBB ) = TAGS(2)(1:4) - ENDIF - IF ( NTAG .GT. 2 ) THEN -C The third additional field contains the element name. - TAGS(3) = ADJUSTL( TAGS(3) ) - DO II = 1, 120 - CMELEM ( II, NMTBB ) = TAGS(3)(II:II) + ENDIF + IF ( NTAG .GT. 1 ) THEN +C The second additional field contains descriptor codes. + TAGS(2) = ADJUSTL( TAGS(2) ) + CMDSC ( NMTBB ) = TAGS(2)(1:4) + ENDIF + IF ( NTAG .GT. 2 ) THEN +C The third additional field contains the element name. + TAGS(3) = ADJUSTL( TAGS(3) ) + DO II = 1, 120 + CMELEM ( II, NMTBB ) = TAGS(3)(II:II) ENDDO - ENDIF - ENDIF + ENDIF + ENDIF - RETURN - 900 CALL BORT('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') - 901 BORT_STR1 = 'BUFRLIB: SNTBBE - CARD BEGINNING WITH: ' // + 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 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/sntbde.f b/src/sntbde.f index 098c8a8b..c336843c 100644 --- a/src/sntbde.f +++ b/src/sntbde.f @@ -45,126 +45,126 @@ C> | 2021-01-08 | J. Ator | Modified mstabs array declarations for GNUv10 portability | C> | 2021-09-30 | J. Ator | Replace jstchr with Fortran intrinsic adjustl | C> - SUBROUTINE SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, - . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, - . NMELEM, IEFXYN, CEELEM ) - - CHARACTER*(*) LINE - CHARACTER*200 TAGS(10), CLINE - CHARACTER*128 BORT_STR1, BORT_STR2 - CHARACTER*120 CEELEM(MXMTBD,MXELEM) - CHARACTER*6 ADN30, ADSC, CLEMON - CHARACTER*4 CMDSC(*) - CHARACTER CMSEQ(120,*) - CHARACTER CMMNEM(8,*) - - INTEGER IMFXYN(*), NMELEM(*), + SUBROUTINE SNTBDE ( LUNT, IFXYN, LINE, MXMTBD, MXELEM, + . NMTBD, IMFXYN, CMMNEM, CMDSC, CMSEQ, + . NMELEM, IEFXYN, CEELEM ) + + CHARACTER*(*) LINE + CHARACTER*200 TAGS(10), CLINE + CHARACTER*128 BORT_STR1, BORT_STR2 + CHARACTER*120 CEELEM(MXMTBD,MXELEM) + CHARACTER*6 ADN30, ADSC, CLEMON + CHARACTER*4 CMDSC(*) + CHARACTER CMSEQ(120,*) + CHARACTER CMMNEM(8,*) + + INTEGER IMFXYN(*), NMELEM(*), . IEFXYN(MXMTBD,MXELEM) - LOGICAL DONE + LOGICAL DONE C----------------------------------------------------------------------- C----------------------------------------------------------------------- - IF ( NMTBD .GE. MXMTBD ) GOTO 900 - NMTBD = NMTBD + 1 + IF ( NMTBD .GE. MXMTBD ) GOTO 900 + NMTBD = NMTBD + 1 -C Store the FXY number. This is the sequence descriptor. +C Store the FXY number. This is the sequence descriptor. - IMFXYN ( NMTBD ) = IFXYN + IMFXYN ( NMTBD ) = IFXYN -C Is there any other information within the first line of the -C table entry? If so, it follows a "|" separator. +C Is there any other information within the first line of the +C table entry? If so, it follows a "|" separator. DO II = 1, 8 - CMMNEM ( II, NMTBD ) = ' ' + CMMNEM ( II, NMTBD ) = ' ' ENDDO - CMDSC ( NMTBD ) = ' ' + CMDSC ( NMTBD ) = ' ' DO II = 1, 120 - CMSEQ ( II, NMTBD ) = ' ' + CMSEQ ( II, NMTBD ) = ' ' ENDDO - IPT = INDEX ( LINE, '|' ) - IF ( IPT .NE. 0 ) THEN + IPT = INDEX ( LINE, '|' ) + IF ( IPT .NE. 0 ) THEN -C Parse the rest of the line. Any of the fields may be blank. +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. - TAGS(1) = ADJUSTL( TAGS(1) ) + CALL PARSTR ( LINE(IPT+1:), TAGS, 10, NTAG, ';', .FALSE. ) + IF ( NTAG .GT. 0 ) THEN +C The first additional field contains the mnemonic. + TAGS(1) = ADJUSTL( TAGS(1) ) C If there is a mnemonic, then make sure it's legal. IF ( ( TAGS(1) .NE. ' ' ) .AND. - . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN - BORT_STR2 = ' HAS ILLEGAL MNEMONIC' - GOTO 901 - ENDIF + . ( NEMOCK ( TAGS(1) ) .NE. 0 ) ) THEN + BORT_STR2 = ' HAS ILLEGAL MNEMONIC' + GOTO 901 + ENDIF DO II = 1, 8 - CMMNEM ( II, NMTBD ) = TAGS(1)(II:II) + CMMNEM ( II, NMTBD ) = TAGS(1)(II:II) ENDDO - ENDIF - IF ( NTAG .GT. 1 ) THEN -C The second additional field contains descriptor codes. - TAGS(2) = ADJUSTL( TAGS(2) ) - CMDSC ( NMTBD ) = TAGS(2)(1:4) - ENDIF - IF ( NTAG .GT. 2 ) THEN -C The third additional field contains the sequence name. - TAGS(3) = ADJUSTL( TAGS(3) ) + ENDIF + IF ( NTAG .GT. 1 ) THEN +C The second additional field contains descriptor codes. + TAGS(2) = ADJUSTL( TAGS(2) ) + CMDSC ( NMTBD ) = TAGS(2)(1:4) + ENDIF + IF ( NTAG .GT. 2 ) THEN +C The third additional field contains the sequence name. + TAGS(3) = ADJUSTL( TAGS(3) ) DO II = 1, 120 - CMSEQ ( II, NMTBD ) = TAGS(3)(II:II) + CMSEQ ( II, NMTBD ) = TAGS(3)(II:II) ENDDO - 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 - TAGS(3) = ADJUSTL( TAGS(3) ) - 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)') + 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 + TAGS(3) = ADJUSTL( TAGS(3) ) + 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 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/sntbfe.f b/src/sntbfe.f index ddc398ce..f68184dd 100644 --- a/src/sntbfe.f +++ b/src/sntbfe.f @@ -22,134 +22,134 @@ C> | 2017-11-02 | J. Ator | Original author | C> | 2021-09-30 | J. Ator | Replace jstchr with Fortran intrinsic adjustl | C> - SUBROUTINE SNTBFE ( LUNT, IFXYN, LINE ) + SUBROUTINE SNTBFE ( LUNT, IFXYN, LINE ) - 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) + 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 + 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 - CVAL(II) = ADJUSTL( CVAL(II) ) - 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 - - TAGS(2) = ADJUSTL( TAGS(2) ) - CALL STRNUM ( TAGS(2), IVAL ) - -C Find the last non-blank character in the meaning string. - - TAGS(3) = ADJUSTL( TAGS(3) ) - 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)') +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 + CVAL(II) = ADJUSTL( CVAL(II) ) + 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 + + TAGS(2) = ADJUSTL( TAGS(2) ) + CALL STRNUM ( TAGS(2), IVAL ) + +C Find the last non-blank character in the meaning string. + + TAGS(3) = ADJUSTL( TAGS(3) ) + 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 + CALL BORT2(BORT_STR1,BORT_STR2) + END diff --git a/src/sorttbf.c b/src/sorttbf.c index 31d6ffb4..f2ee08f2 100644 --- a/src/sorttbf.c +++ b/src/sorttbf.c @@ -2,7 +2,7 @@ * @brief Sort entries within the master Code/Flag table. * * ### Program History Log - * Date | Programmer | Comments + * Date | Programmer | Comments * -----|------------|---------- * 2017-11-16 | J. Ator | Original author. * @@ -21,5 +21,5 @@ void sorttbf( void ) { qsort( &cfe[0], ( size_t ) nmtf, sizeof( struct code_flag_entry ), - ( int (*) ( const void *, const void * ) ) cmpstia1 ); + ( int (*) ( const void *, const void * ) ) cmpstia1 ); } diff --git a/src/srchtbf.c b/src/srchtbf.c index 6452a81c..50c272ad 100644 --- a/src/srchtbf.c +++ b/src/srchtbf.c @@ -14,7 +14,7 @@ * and associated value upon which the first FXY number and its * associated value depend, for example when the meaning of an * originating sub-center value depends on the identity of the - * originating center for which the sub-center in question is a + * originating center for which the sub-center in question is a * member. * * @author J. Ator @@ -72,104 +72,104 @@ * | 2018-01-11 | J. Ator | Original author | */ void srchtbf( f77int *ifxyi, f77int *ivali, f77int *ifxyd, f77int *mxfxyd, f77int *ivald, - char *meaning, f77int *mxmng, f77int *lnmng, f77int *iret ) + char *meaning, f77int *mxmng, f77int *lnmng, f77int *iret ) { - struct code_flag_entry key, *pkey, *pcfe, *pbs; + struct code_flag_entry key, *pkey, *pcfe, *pbs; - int ipt, ii, slmng; + int ipt, ii, slmng; - *iret = -1; + *iret = -1; - /* - ** Initialize some values for searching the internal table. - */ + /* + ** Initialize some values for searching the internal table. + */ - key.iffxyn = *ifxyi; - key.ifval = *ivali; - key.iffxynd = ifxyd[0]; - key.ifvald = *ivald; + key.iffxyn = *ifxyi; + key.ifval = *ivali; + key.iffxynd = ifxyd[0]; + key.ifvald = *ivald; - pkey = &key; - pcfe = &cfe[0]; + pkey = &key; + pcfe = &cfe[0]; - /* - ** Search for a matching entry. - */ + /* + ** 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 ); + 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; - } + /* + ** 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. - */ + /* + ** 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 ); + sizeof( struct code_flag_entry ), + ( int (*) ( const void *, const void * ) ) cmpstia2 ); if ( pbs == NULL ) { - /* - ** There are no dependencies. - */ - return; - } + /* + ** 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; + /* + ** 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++; - } + /* + ** 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; + return; } diff --git a/src/status.f b/src/status.f index 57bec9bf..58f72fe5 100644 --- a/src/status.f +++ b/src/status.f @@ -13,7 +13,7 @@ C> C> @author J. Woollen C> @date 1994-01-06 -C> +C> C> @param[in] LUNIT -- integer: Fortran logical unit number for C> BUFR file C> @param[out] LUN -- integer: Internal I/O stream index associated diff --git a/src/stbfdx.f b/src/stbfdx.f index ac0b1a14..aa483512 100644 --- a/src/stbfdx.f +++ b/src/stbfdx.f @@ -9,7 +9,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author J Ator @date 2009-03-23 - + C> This subroutine copies a DX BUFR tables message C> from the input array mesg into the internal memory arrays in C> module tababd. diff --git a/src/stdmsg.f b/src/stdmsg.f index 67e802ff..aa496c0b 100644 --- a/src/stdmsg.f +++ b/src/stdmsg.f @@ -5,7 +5,7 @@ C> future calls to [message-writing subroutines](@ref hierarchy) and C> [subset-writing subroutines](@ref hierarchy) should be internally C> reformatted to remove all BUFRLIB software extensions to the -C> WMO standard, prior to actually writing each message. +C> WMO standard, prior to actually writing each message. C> C>

It is strongly recommended to use this subroutine (or, C> alternatively, subroutine stndrd() for messages which already exist @@ -19,7 +19,7 @@ C> C>

This subroutine can be called at any time after the first call C> to subroutine openbf(), and the specified value for CF will remain -C> in effect for all future calls to +C> in effect for all future calls to C> [message-writing subroutines](@ref hierarchy) and C> [subset-writing subroutines](@ref hierarchy) for all Fortran logical C> units that are open for output within the application program, @@ -52,7 +52,7 @@ SUBROUTINE STDMSG(CF) CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CSMF = CF + CSMF = CF C EXITS C ----- diff --git a/src/stndrd.f b/src/stndrd.f index 89da2a3b..6f7bba14 100644 --- a/src/stndrd.f +++ b/src/stndrd.f @@ -6,7 +6,7 @@ C> and returns its output via a separate memory array, C> whereas stdmsg() operates on BUFR messages stored internally C> within the software. -C> +C> C> @author J. Ator C> @date 2004-08-18 C> @@ -23,7 +23,7 @@ C> - Standardized messages are usually longer in length than their C> non-standard counterparts, so it's usually a good idea to allow C> for extra space when allocating MSGOT within the application program. -C> +C> C> Program history log: C> | Date | Programmer | Comments | C> | -----|------------|----------| @@ -123,7 +123,7 @@ RECURSIVE SUBROUTINE STNDRD(LUNIT,MSGIN,LMSGOT,MSGOT) 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 +C TO BE EXPANDED INTO AN EQUIVALENT STANDARD SEQUENCE CALL RESTD(LUN,ISUB,NCD,ICD) ELSE diff --git a/src/stntbi.f b/src/stntbi.f index b301df62..c3a2d09e 100644 --- a/src/stntbi.f +++ b/src/stntbi.f @@ -1,7 +1,7 @@ C> @file C> @brief Store a new entry within the internal BUFR Table B or D. C> @author Ator @date 2009-03-23 - + C> This subroutine stores a new entry within internal BUFR C> Table B or D, depending on the value of NUMB. C> @@ -14,24 +14,24 @@ C> corresponding to NUMB. C> C> @author Ator @date 2009-03-23 - SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) + SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) - USE MODA_TABABD + USE MODA_TABABD - CHARACTER*(*) NUMB, NEMO, CELSQ + CHARACTER*(*) NUMB, NEMO, CELSQ C----------------------------------------------------------------------- C----------------------------------------------------------------------- - CALL NENUBD ( NEMO, NUMB, LUN ) + CALL NENUBD ( NEMO, NUMB, LUN ) - IF ( NUMB(1:1) .EQ. '0') THEN + 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 + 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) @@ -39,5 +39,5 @@ SUBROUTINE STNTBI ( N, LUN, NUMB, NEMO, CELSQ ) NTBD(LUN) = N ENDIF - RETURN - END + RETURN + END diff --git a/src/stntbia.f b/src/stntbia.f index ebaa7001..ac25aac9 100644 --- a/src/stntbia.f +++ b/src/stntbia.f @@ -1,7 +1,7 @@ C> @file C> @brief Store a new entry within the internal BUFR Table A. C> @author Ator @date 2009-03-23 - + C> This subroutine stores a new entry within internal BUFR Table A. C> C> @param[in] N - integer: storage index into internal Table A. @@ -11,57 +11,57 @@ C> @param[in] CELSQ - character*55: sequence description corresponding to NUMB. C> C> @author Ator @date 2009-03-23 - SUBROUTINE STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) + SUBROUTINE STNTBIA ( N, LUN, NUMB, NEMO, CELSQ ) - USE MODA_TABABD + USE MODA_TABABD - CHARACTER*128 BORT_STR + CHARACTER*128 BORT_STR - CHARACTER*(*) NUMB, NEMO, CELSQ + CHARACTER*(*) NUMB, NEMO, CELSQ - LOGICAL DIGIT + 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. +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 + 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. +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) + 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. +C Decode and store the message type and subtype. - IF ( DIGIT ( NEMO(3:8) ) ) THEN + 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 + 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) + READ ( NUMB(4:6),'(I3)') IDNA(N,LUN,1) c .... Message subtype hardwired to ZERO - IDNA(N,LUN,2) = 0 - ENDIF + IDNA(N,LUN,2) = 0 + ENDIF -C Update the count of internal Table A entries. +C Update the count of internal Table A entries. NTBA(LUN) = N - RETURN -900 WRITE(BORT_STR,'("BUFRLIB: STNTBIA - TABLE A FXY VALUE (",A,") ' + 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,") ' + 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 + CALL BORT(BORT_STR) + END diff --git a/src/strbtm.f b/src/strbtm.f index 904c5700..b52a8be7 100644 --- a/src/strbtm.f +++ b/src/strbtm.f @@ -8,7 +8,7 @@ C> 2019-05-22 | J. Ator | add confirmation check C> C> @author J Ator @date 2016-05-27 - + C> This subroutine stores internal information in c> module bitmaps if the input element is part of a bitmap. C> @@ -16,24 +16,24 @@ C> @param[in] LUN - integer: I/O stream index into internal memory arrays. C> C> @author J Ator @date 2016-05-27 - SUBROUTINE STRBTM ( N, LUN ) + SUBROUTINE STRBTM ( N, LUN ) USE MODV_MXBTM USE MODV_MXBTMSE - USE MODA_MSGCWD - USE MODA_USRINT - USE MODA_TABLES - USE MODA_BITMAPS + USE MODA_MSGCWD + USE MODA_USRINT + USE MODA_TABLES + USE MODA_BITMAPS LOGICAL ISBTME C----------------------------------------------------------------------- C----------------------------------------------------------------------- - NODE = INV( N, LUN ) + NODE = INV( N, LUN ) - IF ( TAG(NODE)(1:5) .EQ. 'DPRI ' ) THEN + 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 @@ -62,31 +62,31 @@ SUBROUTINE STRBTM ( N, LUN ) IF ( .NOT. ISBTME ) THEN LINBTM = .FALSE. RETURN - ELSE IF ( .NOT. LINBTM ) THEN + ELSE IF ( .NOT. LINBTM ) THEN -C This is the start of a new bitmap. +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 + 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. +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 + 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 + RETURN +900 CALL BORT('BUFRLIB: STRBTM - MXBTM OVERFLOW') +901 CALL BORT('BUFRLIB: STRBTM - MXBTMSE OVERFLOW') + END diff --git a/src/strcpt.f b/src/strcpt.f index 7f510be9..847e7bb8 100644 --- a/src/strcpt.f +++ b/src/strcpt.f @@ -35,7 +35,7 @@ C> IYR, IMO, IDY, IHR, and IMI are ignored. C> C> @remarks -C> - Tank receipt time is an NCEP extension to Section 1 of the +C> - Tank receipt time is an NCEP extension to Section 1 of the C> [official WMO BUFR regulations](@ref manual). C> However, it's encoded by the BUFRLIB software in such a way that C> its inclusion within an output BUFR message is still fully @@ -79,13 +79,13 @@ RECURSIVE SUBROUTINE STRCPT(CF,IYR,IMO,IDY,IHR,IMI) CALL CAPIT(CF) IF(CF.NE.'Y'.AND. CF.NE.'N') GOTO 900 - CTRT = CF + CTRT = CF IF(CTRT.EQ.'Y') THEN - ITRYR = IYR - ITRMO = IMO - ITRDY = IDY - ITRHR = IHR - ITRMI = IMI + ITRYR = IYR + ITRMO = IMO + ITRDY = IDY + ITRHR = IHR + ITRMI = IMI ENDIF C EXITS diff --git a/src/string.f b/src/string.f index b2ea0423..1bedd880 100644 --- a/src/string.f +++ b/src/string.f @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/strtbfe.c b/src/strtbfe.c index 39af0792..3b139960 100644 --- a/src/strtbfe.c +++ b/src/strtbfe.c @@ -31,7 +31,7 @@ * | 2017-11-13 | J. Ator | Original author | */ void strtbfe( f77int *ifxyn, f77int *ival, char *meaning, f77int *lmeaning, - f77int *idfxy, f77int *idval ) + f77int *idfxy, f77int *idval ) { unsigned int mnlen; diff --git a/src/stseq.c b/src/stseq.c index dd2cff0f..df2f6b87 100644 --- a/src/stseq.c +++ b/src/stseq.c @@ -47,7 +47,7 @@ * @author J. Ator @date 2009-03-23 */ void stseq( f77int *lun, f77int *irepct, f77int *idn, char *nemo, - char *cseq, f77int *cdesc, f77int *ncdesc ) + char *cseq, f77int *cdesc, f77int *ncdesc ) { f77int i, j, nb, nd, ipt, ix, iy, iret, nbits; f77int i0 = 0, imxcd, rpidn, pkint, ilen; @@ -81,359 +81,359 @@ void stseq( f77int *lun, f77int *irepct, f77int *idn, char *nemo, */ tab = 'D'; nd = igetntbi( lun, &tab, sizeof ( tab ) ); - cadn30( idn, adn, sizeof( adn ) ); + 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' ) { + 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. +** 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 ) { + 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. +** 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 ); + rpidn = igettdi( lun ); - sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", - ( unsigned long ) ++(*irepct) ); - memset( &rpseq[24], (int) cblk, 31 ); - sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); + 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, - &idefxy_c[icvidx(&ipt,&i0,&imxcd)], - &ndelem_c[ipt] ); - pkint = rpidn; + stseq( lun, irepct, &rpidn, nemo2, rpseq, + &idefxy_c[icvidx(&ipt,&i0,&imxcd)], + &ndelem_c[ipt] ); + pkint = rpidn; - } - else { + } + else { /* -** Store cdesc[i] as is directly within the internal Table D. +** Store cdesc[i] as is directly within the internal Table D. */ - stseq( lun, irepct, &cdesc[i], &cdmnem_c[ipt][0], - &cdseq_c[ipt][0], - &idefxy_c[icvidx(&ipt,&i0,&imxcd)], - &ndelem_c[ipt] ); - pkint = cdesc[i]; - } + stseq( lun, irepct, &cdesc[i], &cdmnem_c[ipt][0], + &cdseq_c[ipt][0], + &idefxy_c[icvidx(&ipt,&i0,&imxcd)], + &ndelem_c[ipt] ); + pkint = cdesc[i]; + } } - else if ( adn[0] == '2' ) { + else if ( adn[0] == '2' ) { /* -** cdesc[i] is an operator descriptor. +** cdesc[i] is an operator descriptor. */ - strnum( &adn[1], &ix, 2 ); - strnum( &adn[3], &iy, 3 ); + strnum( &adn[1], &ix, 2 ); + strnum( &adn[3], &iy, 3 ); - if ( ( ( ix >= 4 ) && ( ix <= 6 ) ) || ( imrkopr( adn, 6 ) ) ) { + 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. +** 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 ); + strncpy( nemo2, adn, 6 ); + memset( &nemo2[6], (int) cblk, 2 ); - if ( ( ix == 4 ) && ( iy == 0 ) ) { + if ( ( ix == 4 ) && ( iy == 0 ) ) { /* -** Cancel the most-recently added associated field. +** 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 { + 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? +** 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' ) ) { + 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. +** No, so create and store a new Table B entry for nemo2. */ - tab = 'B'; - nb = igetntbi( lun, &tab, sizeof( tab ) ); + 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 ); + 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 bit-wise FXY value into -** a Table B bit-wise FXY value. +** Note that 49152 = 3*(2**14), so subtracting 49152 in the +** following statement changes a Table D bit-wise FXY value into +** a Table B bit-wise FXY value. */ - pkint = ( igettdi( lun ) - 49152 ); - cadn30( &pkint, adn2, sizeof( adn2 ) ); + pkint = ( igettdi( lun ) - 49152 ); + cadn30( &pkint, adn2, sizeof( adn2 ) ); - stntbi( &nb, lun, adn2, nemo2, rpseq, - sizeof( adn2 ), 8, 55 ); + stntbi( &nb, lun, adn2, nemo2, rpseq, + sizeof( adn2 ), 8, 55 ); - /* Initialize card to all blanks. */ - memset( card, (int) cblk, sizeof( card ) ); + /* 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 ); - strcpy( &card[40], units ); - card[40+strlen(units)] = cblk; /* overwrite trailing null */ - elemdx( card, lun, sizeof( card ) ); - } - if ( ix == 4 ) { + strncpy( &card[2], nemo2, 8 ); + strncpy( &card[16], "0", 1 ); + strncpy( &card[30], "0", 1 ); + sprintf( &card[33], "%4lu", ( unsigned long ) nbits ); + strcpy( &card[40], units ); + card[40+strlen(units)] = cblk; /* overwrite trailing null */ + elemdx( card, lun, sizeof( card ) ); + } + if ( ix == 4 ) { /* -** Add an associated field. +** 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 ) { + 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. +** 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]; - } + 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' ) { + 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. +** 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'; + adn[6] = '\0'; - strnum( &adn[3], &iy, 3 ); + 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. +** 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++; - } + 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. +** 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 ) ); - } + 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 ); + strnum( &adn[1], &ix, 2 ); /* -** Note we are guaranteed that 0 < ix <= 63 since adn was generated -** using subroutine CADN30. +** 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 ) ) ) { + 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!) +** 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], &cdmnem_c[ipt][0], - &cdseq_c[ipt][0], - &idefxy_c[icvidx(&ipt,&i0,&imxcd)], - &ndelem_c[ipt] ); - pkint = cdesc[i]; - } - else { + nummtb( &cdesc[i], &tab, &ipt ); + stseq( lun, irepct, &cdesc[i], &cdmnem_c[ipt][0], + &cdseq_c[ipt][0], + &idefxy_c[icvidx(&ipt,&i0,&imxcd)], + &ndelem_c[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. +** 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. */ - if ( ( rpdesc = malloc( imxcd * sizeof(f77int) ) ) == NULL ) { - sprintf( errstr, "BUFRLIB: STSEQ - UNABLE TO ALLOCATE SPACE" - " FOR RPDESC" ); - bort( errstr, ( f77int ) strlen( errstr ) ); - } + if ( ( rpdesc = malloc( imxcd * sizeof(f77int) ) ) == NULL ) { + sprintf( errstr, "BUFRLIB: STSEQ - UNABLE TO ALLOCATE SPACE" + " FOR RPDESC" ); + bort( errstr, ( f77int ) strlen( errstr ) ); + } - for ( j = 0; j < ix; j++ ) { - rpdesc[j] = cdesc[i+j]; - } + for ( j = 0; j < ix; j++ ) { + rpdesc[j] = cdesc[i+j]; + } - rpidn = igettdi( lun ); + rpidn = igettdi( lun ); - sprintf( rpseq, "REPLICATION SEQUENCE %.3lu", - ( unsigned long ) ++(*irepct) ); - memset( &rpseq[24], (int) cblk, 31 ); - sprintf( nemo2, "RPSEQ%.3lu", ( unsigned long ) *irepct ); + 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 ); + stseq( lun, irepct, &rpidn, nemo2, rpseq, rpdesc, &ix ); - free( rpdesc ); + free( rpdesc ); - pkint = rpidn; - i += ix - 1; - } + pkint = rpidn; + i += ix - 1; + } } - else { + else { /* -** cdesc[i] is a Table B descriptor. +** cdesc[i] is a Table B descriptor. ** -** Is cdesc[i] already listed as an entry in the internal Table B? +** 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' ) ) { + 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. +** No, so search for it within the master table B. */ - nummtb( &cdesc[i], &tab, &ipt ); + nummtb( &cdesc[i], &tab, &ipt ); /* -** Start a new Table B entry for cdesc[i]. +** 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, &cbmnem_c[ipt][0], - &cbelem_c[ipt][0], sizeof( adn2 ), 8, 55 ); + nb = igetntbi( lun, &tab, sizeof( tab ) ); + cadn30( &cdesc[i], adn2, sizeof( adn2 ) ); + stntbi( &nb, lun, adn2, &cbmnem_c[ipt][0], + &cbelem_c[ipt][0], sizeof( adn2 ), 8, 55 ); - /* Initialize card to all blanks. */ - memset( card, (int) cblk, sizeof( card ) ); + /* Initialize card to all blanks. */ + memset( card, (int) cblk, sizeof( card ) ); - strncpy( &card[2], &cbmnem_c[ipt][0], 8 ); - strncpy( &card[13], &cbscl_c[ipt][0], 4 ); - strncpy( &card[19], &cbsref_c[ipt][0], 12 ); - strncpy( &card[33], &cbbw_c[ipt][0], 4 ); - strncpy( &card[40], &cbunit_c[ipt][0], 24 ); - elemdx( card, lun, sizeof( card ) ); - } - pkint = cdesc[i]; + strncpy( &card[2], &cbmnem_c[ipt][0], 8 ); + strncpy( &card[13], &cbscl_c[ipt][0], 4 ); + strncpy( &card[19], &cbsref_c[ipt][0], 12 ); + strncpy( &card[33], &cbbw_c[ipt][0], 4 ); + strncpy( &card[40], &cbunit_c[ipt][0], 24 ); + elemdx( card, lun, sizeof( card ) ); + } + pkint = cdesc[i]; } - if ( strncmp( adn, "204", 3 ) != 0 ) { + 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. +** 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. +** 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 ) ); - } - } - } + 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. +** 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 ) ); + 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 ) ); } - } + } } } diff --git a/src/tabent.f b/src/tabent.f index b65b328d..741148b3 100644 --- a/src/tabent.f +++ b/src/tabent.f @@ -15,7 +15,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author Woollen @date 1994-01-06 - + C> This subroutine builds and stores an entry for a Table B or c> Table D mnemonic within the internal jump/link table. C> diff --git a/src/tabsub.f b/src/tabsub.f index f9be9a05..44c45d24 100644 --- a/src/tabsub.f +++ b/src/tabsub.f @@ -18,7 +18,7 @@ C> 2017-04-03 | J. Ator | add a dimension to all tco arrays so that each subset definition in the jump/link table has its own set of table c operators C> C> @author Woollen @date 1994-01-06 - + C> This subroutine builds the entire jump/link tree C> (including recursively resolving all "child" mnemonics) for a Table A C> mnemonic within the internal jump/link table. @@ -129,7 +129,7 @@ SUBROUTINE TABSUB(LUN,NEMO) C Instead, revert to the use of standard Table B values. IF(IPFNRV.EQ.0) GOTO 911 - DO JJ=IPFNRV,NNRV + DO JJ=IPFNRV,NNRV IENRV(JJ) = NTAB ENDDO IPFNRV = 0 @@ -213,7 +213,7 @@ SUBROUTINE TABSUB(LUN,NEMO) C operator, then these IENRV(*) values would have already C been properly set above. - DO JJ=IPFNRV,NNRV + DO JJ=IPFNRV,NNRV IENRV(JJ) = NTAB ENDDO ENDIF diff --git a/src/trybump.f b/src/trybump.f index dc06707f..1a2aacfe 100644 --- a/src/trybump.f +++ b/src/trybump.f @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author Woollen @date 1994-01-06 - + C> 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. diff --git a/src/ufbcup.f b/src/ufbcup.f index 2fe5756a..d312535e 100644 --- a/src/ufbcup.f +++ b/src/ufbcup.f @@ -2,7 +2,7 @@ C> @brief Copy unique elements of a data subset. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 1994-01-06 | J. Woollen | original author C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with call to new internal bufrlib routine "bort" @@ -13,7 +13,7 @@ C> 2022-10-14 | J. Ator | added 8-byte wrapper C> C> @author Woollen @date 1994-01-06 - + C> 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. diff --git a/src/ufbdmp.f b/src/ufbdmp.f index b53972da..bd9d62a7 100644 --- a/src/ufbdmp.f +++ b/src/ufbdmp.f @@ -17,7 +17,7 @@ C> @date 1994-01-06 C> C> @param[in] LUNIN -- integer: Absolute value is Fortran logical -C> unit number for BUFR file +C> unit number for BUFR file C> - If LUNIN > 0, data values are printed to C> LUPRT using the format descriptor code C> 'G15.6', meaning that all values will be @@ -90,7 +90,7 @@ RECURSIVE SUBROUTINE UFBDMP(LUNIN,LUPRT) REAL*8 VL PARAMETER (MXFV=31) - INTEGER IFV(MXFV) + INTEGER IFV(MXFV) DATA PMISS /' MISSING'/ DATA YOU /'Y'/ diff --git a/src/ufbevn.f b/src/ufbevn.f index 04af1dd6..cb02d4d4 100644 --- a/src/ufbevn.f +++ b/src/ufbevn.f @@ -137,7 +137,7 @@ RECURSIVE SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) 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) =' + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') @@ -148,7 +148,7 @@ RECURSIVE SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) 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) =' + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') @@ -159,7 +159,7 @@ RECURSIVE SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) 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) =' + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') @@ -236,7 +236,7 @@ RECURSIVE SUBROUTINE UFBEVN(LUNIT,USR,I1,I2,I3,IRET,STR) 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) =' + . 'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' CALL ERRWRT(ERRSTR) CALL ERRWRT(STR) CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++') diff --git a/src/ufbget.f b/src/ufbget.f index 77b5c745..1576c206 100644 --- a/src/ufbget.f +++ b/src/ufbget.f @@ -7,7 +7,7 @@ C> 1994-01-06 | J. Woollen | original author C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with call to new internal bufrlib routine "bort"; improved machine portability C> 1998-10-27 | J. Woollen | modified to correct problems caused by in- lining code with fpp directives -C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 +C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 C> 2000-09-19 | J. Woollen | maximum message length increased from 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 interdependencies @@ -19,7 +19,7 @@ C> 2022-10-04 | J. Ator | added 8-byte wrapper C> C> @author Woollen @date 1994-01-06 - + C> This subroutine unpacks and returns the values for one-dimensional C> descriptors in the input string without advancing the subset pointer. C> diff --git a/src/ufbint.f b/src/ufbint.f index 12cbf7d1..f0d7ce05 100644 --- a/src/ufbint.f +++ b/src/ufbint.f @@ -99,7 +99,7 @@ C> assocated DX BUFR table), and the corresponding location in USR C> will contain the total number of replications of that mnemonic C> within the data subset. Note that, when using this option, the -C> applicable replication indicators must be included in STR +C> applicable replication indicators must be included in STR C> along with the mnemonic itself, as shown in an example in the C> discussion of [DX BUFR Tables](@ref ufbsubs). C> - If ABS(LUNIN) points to a file that is open for input (reading @@ -120,7 +120,7 @@ C> the beginning of the message C> C> @param[in] LUNIN -- integer: Absolute value is Fortran logical -C> unit number for BUFR file +C> unit number for BUFR file C> @param[in,out] USR -- real*8(*,*): Data values C> - If ABS(LUNIN) was opened for input, then C> USR is output from this subroutine and diff --git a/src/ufbinx.f b/src/ufbinx.f index c012302c..a21aa440 100644 --- a/src/ufbinx.f +++ b/src/ufbinx.f @@ -2,7 +2,7 @@ C> @brief Read one or more data values from a data subset. C> C> ### Program History Log -C> Date | Programmer | Comments +C> Date | Programmer | Comments C> -----|------------|---------- C> 2003-11-04 | J. Woollen | original author (was in verification version but may have been in the production version at one time and then removed) C> 2003-11-04 | D. Keyser | unified/portable for wrf; added documentation; outputs more complete diagnostic info @@ -13,7 +13,7 @@ C> 2022-10-04 | J. Ator | added 8-byte wrapper C> C> @author Woollen @date 2003-11-04 - + C> If logical unit LUNIT has already been opened for input operations C> via a previous call to subroutine openbf(), then this subroutine C> will save the current file position, rewind the file to the diff --git a/src/ufbmem.f b/src/ufbmem.f index efbd83a7..98986096 100644 --- a/src/ufbmem.f +++ b/src/ufbmem.f @@ -15,7 +15,7 @@ C> @date 1994-01-06 C> C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR -C> file +C> file C> @param[in] INEW -- integer: Processing option C> - 0 = Initialize the internal arrays, then C> read all BUFR messages from LUNIT into @@ -42,7 +42,7 @@ C> closed via an internal call to subroutine closbf() before exiting C> this subroutine. In either case, IUNIT can now be used to access C> all BUFR messages that were read and stored by all previous calls -C> to this subroutine. +C> to this subroutine. C> C> Program history log: C> | Date | Programmer | Comments | @@ -124,7 +124,7 @@ RECURSIVE SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) ITEMP = NDXTS CALL STATUS(LUNIT,LUN,IL,IM) - CALL CEWIND(LUN) + CALL CEWIND(LUN) CALL CPDXMM(LUNIT) C If a table was indeed present at the beginning of the file, @@ -141,12 +141,12 @@ RECURSIVE SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) 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. +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 + CALL BACKBUFR(LUN) !BACKSPACE LUNIT + CALL CPDXMM(LUNIT) + GOTO 1 ENDIF NMSG = NMSG+1 @@ -182,7 +182,7 @@ RECURSIVE SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) 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, + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) @@ -206,7 +206,7 @@ RECURSIVE SUBROUTINE UFBMEM(LUNIT,INEW,IRET,IUNIT) 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, + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) diff --git a/src/ufbmex.f b/src/ufbmex.f index 294643ef..87f6f3ae 100644 --- a/src/ufbmex.f +++ b/src/ufbmex.f @@ -39,7 +39,7 @@ C>

Logical unit numbers LUNIT and LUNDX must already be associated C> with actual filenames on the local system, typically via a Fortran C> "OPEN" statement. -C> +C> C> Program history log: C> | Date | Programmer | Comments | C> | -----|------------|----------| @@ -157,7 +157,7 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) 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, + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMSG, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) @@ -181,7 +181,7 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) 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, + . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', MAXMEM, . ') - INCOMPLETE READ' CALL ERRWRT(ERRSTR) WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' ) diff --git a/src/ufbovr.f b/src/ufbovr.f index 4c751026..440ca94c 100644 --- a/src/ufbovr.f +++ b/src/ufbovr.f @@ -9,7 +9,7 @@ C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 C> 2002-05-14 | J. Woollen | removed old cray compiler directives C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies -C> 2003-11-04 | D. Keyser | maxjl increased to 16000; unified/portable for wrf; documentation; outputs more +C> 2003-11-04 | D. Keyser | maxjl increased to 16000; unified/portable for wrf; documentation; outputs more 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 @@ -17,7 +17,7 @@ C> 2022-10-04 | J. Ator | added 8-byte wrapper C> C> @author Woollen @date 1994-01-06 - + C> 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 diff --git a/src/ufbpos.f b/src/ufbpos.f index c012a05f..1a1772ef 100644 --- a/src/ufbpos.f +++ b/src/ufbpos.f @@ -57,7 +57,7 @@ RECURSIVE SUBROUTINE UFBPOS(LUNIT,IREC,ISUB,SUBSET,JDATE) CHARACTER*128 BORT_STR CHARACTER*8 SUBSET - + C----------------------------------------------------------------------- C---------------------------------------------------------------------- @@ -91,10 +91,10 @@ RECURSIVE SUBROUTINE UFBPOS(LUNIT,IREC,ISUB,SUBSET,JDATE) 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 diff --git a/src/ufbrp.f b/src/ufbrp.f index 37ca20a1..c6398d35 100644 --- a/src/ufbrp.f +++ b/src/ufbrp.f @@ -13,7 +13,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author J. Woollen @date 1994-01-06 - + C> This subroutine writes or reads specified data 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. diff --git a/src/ufbrw.f b/src/ufbrw.f index cb1ff2b1..464de43a 100644 --- a/src/ufbrw.f +++ b/src/ufbrw.f @@ -18,7 +18,7 @@ C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author J. Woollen @date 1994-01-06 - + C> 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. diff --git a/src/ufbsp.f b/src/ufbsp.f index 495a0c45..1d8648c4 100644 --- a/src/ufbsp.f +++ b/src/ufbsp.f @@ -9,9 +9,9 @@ C> 2003-11-04 | D. Keyser | maxjl increased to 16000; unified/portable for wrf; documentation C> 2009-03-31 | J. Woollen | add documentation C> 2014-12-10 | J. Ator | use modules instead of common blocks -C> +C> C> @author J. Woollen @date 1999-11-18 - + C> 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. diff --git a/src/ufbtab.f b/src/ufbtab.f index d85ac045..43568b52 100644 --- a/src/ufbtab.f +++ b/src/ufbtab.f @@ -12,7 +12,7 @@ C> C> @author J. Woollen C> @date 1994-01-06 -C> +C> C> @param[in] LUNIN -- integer: Absolute value is Fortran logical C> unit number for BUFR file C> @param[out] TAB -- real*8(*,*): Data values @@ -133,7 +133,7 @@ RECURSIVE SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) CALL X84(LUNIN,MY_LUNIN,1) CALL X84(I1,MY_I1,1) CALL X84(I2,MY_I2,1) - CALL UFBTAB(MY_LUNIN,TAB,MY_I1,MY_I2,IRET,STR) + CALL UFBTAB(MY_LUNIN,TAB,MY_I1,MY_I2,IRET,STR) CALL X48(IRET,IRET,1) IM8B=.TRUE. @@ -174,7 +174,7 @@ RECURSIVE SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) C IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG C --------------------------------------------------------------------- - CALL REWNBF(LUNIT,0) + CALL REWNBF(LUNIT,0) ENDIF IAC = 1 @@ -220,7 +220,7 @@ RECURSIVE SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) C PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT C -------------------------------------------------------- - if(msgunp(lun)==2) goto 115 + if(msgunp(lun)==2) goto 115 C --------------------------------------------- C THIS BRANCH IS FOR UNCOMPRESSED MESSAGES diff --git a/src/ufdump.f b/src/ufdump.f index eb39b0c4..ca34d6dc 100644 --- a/src/ufdump.f +++ b/src/ufdump.f @@ -95,7 +95,7 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) INTEGER ICFDP(MXCFDP) PARAMETER (MXFV=31) - INTEGER IFV(MXFV) + INTEGER IFV(MXFV) PARAMETER (MXSEQ=10) INTEGER IDXREP(MXSEQ) @@ -191,15 +191,15 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) 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 + . (TYPE.EQ.'DRB').OR.(TYPE.EQ.'DRS')) THEN -C Print the number of replications +C Print the number of replications NSEQ = NSEQ+1 IF(NSEQ.GT.MXSEQ) GOTO 904 @@ -305,7 +305,7 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) 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. +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 @@ -330,7 +330,7 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) ENDDO UNIT(IPT-1:IPT-1) = ')' ENDIF - ENDIF + ENDIF WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC @@ -346,7 +346,7 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) ENDIF DO II=1,NIFV ICFDP(1) = (-1) - IFVD = (-1) + IFVD = (-1) CALL SRCHTBF(IDN,IFV(II),ICFDP,MXCFDP,IFVD, . CFMEANG,LCFMEANG,LCFMG,IERSF) IF(IERSF.EQ.0) THEN @@ -372,7 +372,7 @@ RECURSIVE SUBROUTINE UFDUMP(LUNIT,LUPRT) ENDIF ENDDO IF(IERFT.EQ.0) THEN - IFVD = NINT(VAL(NOUT,LUN)) + 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) diff --git a/src/upc.f b/src/upc.f index fcc0edef..cb4fcead 100644 --- a/src/upc.f +++ b/src/upc.f @@ -1,6 +1,6 @@ C> @file C> @brief Decode a character string from an integer array. -C> +C> C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| @@ -12,7 +12,7 @@ C> 2014-11-19 | J. Ator | add cnvnull argument C> C> @author Woollen @date 1994-01-06 - + C> This subroutine decodes a character string from within a specified C> number of bytes of an integer array, starting at the bit immediately C> after a specified bit within the array. @@ -59,7 +59,7 @@ SUBROUTINE UPC(CHR,NCHR,IBAY,IBIT,CNVNULL) CALL UPB(IVAL(1),8,IBAY,IBIT) IF((IVAL(1).EQ.0).AND.(CNVNULL)) THEN CHR(I:I) = ' ' - ELSE + ELSE CHR(I:I) = CVAL(LB:LB) ENDIF IF(IASCII.EQ.0) CALL IPKM(CHR(I:I),1,IATOE(IUPM(CHR(I:I),8))) diff --git a/src/upds3.f b/src/upds3.f index 62a2eb35..845480b3 100644 --- a/src/upds3.f +++ b/src/upds3.f @@ -4,11 +4,11 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 2003-11-04 | J. Ator | Original author -C> 2004-08-18 | J. Ator | Removed IFIRST check, since wrdlen() now 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> 2022-10-04 | J. Ator | Added 8-byte wrapper +C> 2003-11-04 | J. Ator | Original author +C> 2004-08-18 | J. Ator | Removed IFIRST check, since wrdlen() now 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> 2022-10-04 | J. Ator | Added 8-byte wrapper C> C> @author J. Ator @date 2003-11-04 diff --git a/src/upftbv.f b/src/upftbv.f index b4c1effc..061a7c37 100644 --- a/src/upftbv.f +++ b/src/upftbv.f @@ -4,9 +4,9 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 2005-11-29 | J. Ator | Original version -C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks -C> 2022-10-04 | J. Ator | Added 8-byte wrapper +C> 2005-11-29 | J. Ator | Original version +C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks +C> 2022-10-04 | J. Ator | Added 8-byte wrapper C> C> @author J. Ator @date 2005-11-29 @@ -73,7 +73,7 @@ RECURSIVE SUBROUTINE UPFTBV(LUNIT,NEMO,VAL,MXIB,IBIT,NIB) IF(TABB(N,LUN)(71:74).NE.'FLAG') GOTO 902 C Figure out which bits are set. - + NIB(1) = 0 R8VAL = VAL NBITS = VALX(TABB(N,LUN)(110:112)) diff --git a/src/ups.f b/src/ups.f index 8a057d23..f7efc09c 100644 --- a/src/ups.f +++ b/src/ups.f @@ -26,53 +26,53 @@ C> - This function is the logical inverse of function ipks(). C> C> @author J. Ator @date 2012-03-02 - REAL*8 FUNCTION UPS(IVAL,NODE) + REAL*8 FUNCTION UPS(IVAL,NODE) - USE MODA_TABLES - USE MODA_NRV203 + USE MODA_TABLES + USE MODA_NRV203 integer*8 ival,imask - REAL*8 TEN + REAL*8 TEN - DATA TEN /10./ + DATA TEN /10./ C----------------------------------------------------------------------- - UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE)) + UPS = ( IVAL + IRF(NODE) ) * TEN**(-ISC(NODE)) - IF ( NNRV .GT. 0 ) THEN + 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. +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 + 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. +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_8**(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 + IMASK = 2_8**(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. +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 + UPS = ( IVAL + NRV(JJ) ) * TEN**(-ISC(NODE)) + RETURN + END IF + END DO - END IF + END IF - RETURN - END + RETURN + END diff --git a/src/uptdd.f b/src/uptdd.f index b6ec2db4..7ea42ffe 100644 --- a/src/uptdd.f +++ b/src/uptdd.f @@ -5,17 +5,17 @@ C> | Date | Programmer | Comments | C> | -----|------------|----------| C> 1994-01-06 | J. Woollen | original author -C> 1995-06-28 | J. Woollen | increased the size of internal bufr table arrays +C> 1995-06-28 | J. Woollen | increased the size of internal bufr table arrays C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with bufrlib routine "bort" C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 C> 2003-11-04 | J. Ator | added documentation C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies -C> 2003-11-04 | D. Keyser | unified/portable for wrf; added history documentation; outputs more complete diagnostic info +C> 2003-11-04 | D. Keyser | unified/portable for wrf; added history documentation; outputs more complete diagnostic info C> 2014-12-10 | J. Ator | use modules instead of common blocks C> C> @author J. Woollen @date 1994-01-06 -C> This subroutine returns the bit-wise representation of the FXY value corresponding to, sequentially, +C> This subroutine returns the bit-wise representation of the FXY value corresponding to, sequentially, C> a particular (IENT'th) "child" mnemonic of a Table D sequence ("parent") mnemonic. C> C> @param[in] ID - integer: positional index of parent mnemonic within internal BUFR Table D array tabd. diff --git a/src/valx.f b/src/valx.f index c82c98fa..52913366 100644 --- a/src/valx.f +++ b/src/valx.f @@ -4,12 +4,12 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 1994-01-06 | J. Woollen | Original author -C> 1998-07-08 | J. Woollen | Replaced call to CRAY library routine "ABORT" with call to new internal routine bort() -C> 1999-11-18 | J. Woollen | Renamed from val$ to valx because the $ symbol causes problems on certain platforms -C> 2003-11-04 | D. Keyser | Use bort2() instead of bort() -C> 2009-04-21 | J. Ator | Use errwrt() -C> 2021-09-30 | J. Ator | Replace rjust with Fortran intrinsic adjustr +C> 1994-01-06 | J. Woollen | Original author +C> 1998-07-08 | J. Woollen | Replaced call to CRAY library routine "ABORT" with call to new internal routine bort() +C> 1999-11-18 | J. Woollen | Renamed from val$ to valx because the $ symbol causes problems on certain platforms +C> 2003-11-04 | D. Keyser | Use bort2() instead of bort() +C> 2009-04-21 | J. Ator | Use errwrt() +C> 2021-09-30 | J. Ator | Replace rjust with Fortran intrinsic adjustr C> C> @author J. Woollen @date 1994-01-06 diff --git a/src/wrcmps.f b/src/wrcmps.f index 7a22b596..7f9d6219 100644 --- a/src/wrcmps.f +++ b/src/wrcmps.f @@ -5,18 +5,18 @@ C> Date | Programmer | Comments | C> -----|------------|----------| C> 2002-05-14 | J. Woollen | original author -C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies -C> 2003-11-04 | D. Keyser | maxjl increased from 15k to 16000; writ1 and flush now saved;unified/portable for wrf; added documentation and abort info -C> 2004-08-18 | J. Ator | remove call to xmsgini; improve documentation; correct character value logic; maximum message length 20k TO 50k -C> 2004-08-18 | J. Woollen | save 'first'; added 'kmiss'; added logic to correct missing values; removed unecessary references to writ1 -C> 2005-11-29 | J. Ator | fix initialization bug for character compression; increase mxcsb to 4k; check edition number before padding message -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; separated matx,catx,ncol for use in subroutine writlc; passed mbay(1,lun) to cmsgini for use in writlc +C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies +C> 2003-11-04 | D. Keyser | maxjl increased from 15k to 16000; writ1 and flush now saved;unified/portable for wrf; added documentation and abort info +C> 2004-08-18 | J. Ator | remove call to xmsgini; improve documentation; correct character value logic; maximum message length 20k TO 50k +C> 2004-08-18 | J. Woollen | save 'first'; added 'kmiss'; added logic to correct missing values; removed unecessary references to writ1 +C> 2005-11-29 | J. Ator | fix initialization bug for character compression; increase mxcsb to 4k; check edition number before padding message +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; separated matx,catx,ncol for use in subroutine writlc; passed mbay(1,lun) to cmsgini for use in writlc C> 2012-02-17 | J. Ator | fixed a bug involving compressed files with embedded dictionary messages C> 2014-12-03 | J. Ator | use pkx to pack local reference value for 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 long character strings (via writlc) into messages which contain delayed replication +C> 2016-03-18 | J. Ator | fix bug involving encoding long character strings (via writlc) into messages which contain delayed replication C> 2021-02-24 | J. Ator | use ipkm and pkc instead of pkx C> 2022-05-06 | J. Woollen | use pkb8 for packing 8byte integers C> @@ -43,7 +43,7 @@ SUBROUTINE WRCMPS(LUNIX) USE MODV_MXCDV USE MODV_MXCSB - + USE MODA_USRINT USE MODA_MSGCWD USE MODA_BITBUF @@ -52,15 +52,15 @@ SUBROUTINE WRCMPS(LUNIX) USE MODA_COMPRX USE MODA_COMPRS USE MODA_S01CM - + COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS - + CHARACTER*128 BORT_STR CHARACTER*8 SUBSET CHARACTER*1 CZERO 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 @@ -70,27 +70,27 @@ SUBROUTINE WRCMPS(LUNIX) 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 - + 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 @@ -100,7 +100,7 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -109,7 +109,7 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -127,13 +127,13 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -143,10 +143,10 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -156,15 +156,15 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -178,24 +178,24 @@ SUBROUTINE WRCMPS(LUNIX) 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 - +C .TRUE. OTHERWISE + IMISS = 2**IWID(I)-1 IF(ICOL.EQ.1) THEN KMIN(I) = IMISS @@ -213,7 +213,7 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -221,19 +221,19 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -243,21 +243,21 @@ SUBROUTINE WRCMPS(LUNIX) 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. @@ -268,26 +268,26 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -296,43 +296,43 @@ SUBROUTINE WRCMPS(LUNIX) 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 @@ -341,8 +341,8 @@ SUBROUTINE WRCMPS(LUNIX) IF(KBIT(I).GT.0) THEN DO J=1,NCOL IF(MATX(I,J).LT.2_8**IWID(I)-1) THEN - INCR = MATX(I,J)-KMIN(I) - ELSE + INCR = MATX(I,J)-KMIN(I) + ELSE INCR = 2_8**KBIT(I)-1 ENDIF CALL PKB8(INCR,KBIT(I),MGWA,IBIT) @@ -365,48 +365,48 @@ SUBROUTINE WRCMPS(LUNIX) 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. - +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,")'// diff --git a/src/wrdesc.c b/src/wrdesc.c index 06ab8651..09eac38a 100644 --- a/src/wrdesc.c +++ b/src/wrdesc.c @@ -9,7 +9,7 @@ * Given the bit-wise representation of a descriptor, * this routine adds it to an ongoing array of descriptors, after * first making sure that there is enough room in the array. - * + * * If an array overflow occurs, then an appropriate error message * will be written via bort(). * @@ -29,12 +29,12 @@ void wrdesc( f77int desc, f77int *descary, f77int *ndescary ) ** Is there room in descary for desc? */ if ( ( *ndescary + 1 ) < MAXNC ) { - descary[(*ndescary)++] = desc; + descary[(*ndescary)++] = desc; } else { - sprintf( errstr, "BUFRLIB: WRDESC - EXPANDED SECTION 3 CONTAINS" - " MORE THAN %d DESCRIPTORS", MAXNC ); - bort( errstr, ( f77int ) strlen( errstr ) ); + sprintf( errstr, "BUFRLIB: WRDESC - EXPANDED SECTION 3 CONTAINS" + " MORE THAN %d DESCRIPTORS", MAXNC ); + bort( errstr, ( f77int ) strlen( errstr ) ); } return; diff --git a/src/wrdxtb.f b/src/wrdxtb.f index 0d254185..64d36a74 100644 --- a/src/wrdxtb.f +++ b/src/wrdxtb.f @@ -4,11 +4,11 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -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, Table B, or Table D descriptors in any single DX BUFR tables message -C> 2014-11-14 | J. Ator | Replace ipkm() calss with pkb() calls -C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks -C> 2022-10-04 | J. Ator | Added 8-byte wrapper +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, Table B, or Table D descriptors in any single DX BUFR tables message +C> 2014-11-14 | J. Ator | Replace ipkm() calss with pkb() calls +C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks +C> 2022-10-04 | J. Ator | Added 8-byte wrapper C> C> @author J. Ator @date 2009-03-23 diff --git a/src/writcp.f b/src/writcp.f index a03e501b..96d79a8a 100644 --- a/src/writcp.f +++ b/src/writcp.f @@ -10,9 +10,9 @@ C> C> @author J. Woollen @date 2002-05-14 -C> This subroutine is similar to subroutine writsb(), except that +C> This subroutine is similar to subroutine writsb(), except that C> when the subset is encoded and packed into the current message -C> for the BUFR file associated with logical unit LUNIT, it is +C> for the BUFR file associated with logical unit LUNIT, it is C> packed using compression as prescribed within the C> [official WMO BUFR regulations](@ref manual). C> diff --git a/src/writdx.f b/src/writdx.f index 970e0abd..a5d8ba94 100644 --- a/src/writdx.f +++ b/src/writdx.f @@ -4,15 +4,15 @@ C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|--------- -C> 1994-01-06 | J. Woollen | original author -C> 1995-06-28 | J. Woollen | increased the size of internal bufr table arrays in order to handle bigger files -C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with call to new internal bufrlib routine "bort" -C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 -C> 2000-09-19 | J. Woollen | maximum message length increased from 10,000 to 20,000 bytes -C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies -C> 2003-11-04 | D. Keyser | unified/portable for wrf -C> 2004-08-09 | J. Ator | maximum message length increased from 20,000 to 50,000 bytes -C> 2009-03-23 | J. Ator | use wrdxtb +C> 1994-01-06 | J. Woollen | original author +C> 1995-06-28 | J. Woollen | increased the size of internal bufr table arrays in order to handle bigger files +C> 1998-07-08 | J. Woollen | replaced call to cray library routine "abort" with call to new internal bufrlib routine "bort" +C> 1999-11-18 | J. Woollen | the number of bufr files which can be opened at one time increased from 10 to 32 +C> 2000-09-19 | J. Woollen | maximum message length increased from 10,000 to 20,000 bytes +C> 2003-11-04 | S. Bender | added remarks/bufrlib routine interdependencies +C> 2003-11-04 | D. Keyser | unified/portable for wrf +C> 2004-08-09 | J. Ator | maximum message length increased from 20,000 to 50,000 bytes +C> 2009-03-23 | J. Ator | use wrdxtb C> C> @author Woollen @date 1994-01-06 diff --git a/src/writlc.f b/src/writlc.f index aedfc45d..9df79256 100644 --- a/src/writlc.f +++ b/src/writlc.f @@ -4,17 +4,17 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 2003-11-04 | J. Woollen | Original author -C> 2004-08-09 | J. Ator | Maximum message length increased from 20K to 50K 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 occurrence of STR +C> 2003-11-04 | J. Woollen | Original author +C> 2004-08-09 | J. Ator | Maximum message length increased from 20K to 50K 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 occurrence of STR C> 2009-08-11 | J. Woollen | Added COMMON COMPRS along with logic to write long strings into compressed subsets -C> 2012-12-07 | J. Ator | Allow str mnemonic length of up to 14 chars when used with '#' occurrence code -C> 2014-10-22 | J. Ator | No longer abort if no subset available for writing; just print a warning message -C> 2014-12-10 | J. Ator | USE modules instead of COMMON blocks -C> 2020-09-09 | J. Ator | No longer abort if STR not available within subset definition; instead, just print a warning message -C> 2022-10-04 | J. Ator | Added 8-byte wrapper +C> 2012-12-07 | J. Ator | Allow str mnemonic length of up to 14 chars when used with '#' occurrence code +C> 2014-10-22 | J. Ator | No longer abort if no subset available for writing; just print a warning message +C> 2014-12-10 | J. Ator | USE modules instead of COMMON blocks +C> 2020-09-09 | J. Ator | No longer abort if STR not available within subset definition; instead, just print a warning message +C> 2022-10-04 | J. Ator | Added 8-byte wrapper C> C> @author J. Woollen @author J. Ator @date 2003-11-04 @@ -120,7 +120,7 @@ RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR) CTAG = TGS(1)(1:10) ENDIF - IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN + IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN C The message is compressed. @@ -134,14 +134,14 @@ RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR) CALL USRTPL(LUN,N,MATX(N,NCOL)) ELSEIF(CTAG.EQ.TAG(NODE)) THEN ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN + IF(ITAGCT.EQ.IOID) THEN IF(ITP(NODE).NE.3) GOTO 904 CATX(N,NCOL)=' ' -C The following statement enforces a limit of MXLCC +C The following statement enforces a limit of MXLCC C characters per long character string when writing C compressed messages. This limit keeps the array -C CATX to a reasonable dimensioned size. +C CATX to a reasonable dimensioned size. NCHR=MIN(MXLCC,IBT(NODE)/8) CATX(N,NCOL)=CHR(1:NCHR) @@ -197,7 +197,7 @@ RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR) CALL USRTPL(LUN,N,IVAL) ELSEIF(CTAG.EQ.TAG(NODE)) THEN ITAGCT = ITAGCT + 1 - IF(ITAGCT.EQ.IOID) THEN + IF(ITAGCT.EQ.IOID) THEN IF(ITP(NODE).NE.3) GOTO 904 NCHR = NBIT/8 IBIT = MBIT diff --git a/src/writsa.f b/src/writsa.f index 14b8185c..33cda4a9 100644 --- a/src/writsa.f +++ b/src/writsa.f @@ -24,7 +24,7 @@ C> addition to writing each completed message to a specified Fortran C> logical unit, it also returns a copy of each completed message to C> the application program within a memory array. -C> +C> C> This subroutine looks and behaves a lot like subroutine writsb(). C> Specifically, it is called to indicate to the BUFRLIB software that C> all necessary values for a data subset (i.e. report) have been written, @@ -113,7 +113,7 @@ RECURSIVE SUBROUTINE WRITSA(LUNXX,LMSGT,MSGT,MSGL) C---------------------------------------------------------------------- C---------------------------------------------------------------------- -C CHECK FOR I8 INTEGERS +C CHECK FOR I8 INTEGERS C --------------------- IF(IM8B) THEN diff --git a/src/writsb.f b/src/writsb.f index f96794e9..9caa265a 100644 --- a/src/writsb.f +++ b/src/writsb.f @@ -4,16 +4,16 @@ C> ### Program History Log C> Date | Programmer | Comments C> -----|------------|--------- -C> 1994-01-06 | J. Woollen | Original author -C> 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort() -C> 2003-11-04 | J. Ator | Added documentation +C> 1994-01-06 | J. Woollen | Original author +C> 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort() +C> 2003-11-04 | J. Ator | Added documentation C> 2003-11-04 | S. Bender | Added remarks and routine interdependencies -C> 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally -C> 2005-03-09 | J. Ator | Added capability for compressed messages -C> 2022-10-04 | J. Ator | Added 8-byte wrapper +C> 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally +C> 2005-03-09 | J. Ator | Added capability for compressed messages +C> 2022-10-04 | J. Ator | Added 8-byte wrapper C> C> @author J. Woollen @date 1994-01-06 - + C> This subroutine writes a complete data subset into a BUFR message, for eventual output to logical unit LUNIT. C> C> This subroutine is called to indicate to the BUFRLIB software that @@ -34,7 +34,7 @@ C> by the BUFRLIB software. This maximum message size is initially set C> to an internal default value within subroutine bfrini(), but it can C> be changed to a different value via a separate prior call to -C> subroutine maxout(). +C> subroutine maxout(). C> - This subroutine will always check to ensure that the data subset, C> when encoded and packed, will fit into the current BUFR message that C> is already open within the internal arrays associated with logical diff --git a/src/wrtree.f b/src/wrtree.f index 22cb9cb8..73c9217c 100644 --- a/src/wrtree.f +++ b/src/wrtree.f @@ -4,20 +4,20 @@ C> ### Program History Log C> Date | Programmer | Comments | C> -----|------------|----------| -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 opened at one time increased from 10 to 32 -C> 2000-09-19 | J. Woollen | maximum message length increased from 10k TO 20k bytes -C> 2003-11-04 | S. Bender | added remarks/bufrlib routine -C> 2003-11-04 | D. Keyser | maxjl (maximum number of jump/link entries) increased from 15K to 16K -C> 2004-03-10 | J. Woollen | converted packing function 'pks' to real*8 -C> 2004-08-09 | J. Ator | maximum message length increased from 20K TO 50K -C> 2007-01-19 | J. Ator | prevent overflow of cval for strings longer than 8 characters; use function ibfms -C> 2009-08-03 | J. Woollen | added capability to copy long strings via ufbcpy using file pointer stored in new 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 properly encoded with all bits set to 1 -C> 2014-12-10 | J. Ator | use modules instead of common blocks -C> 2022-05-06 | J. Woollen | replace pkb with pkb8 for 8byte integers +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 opened at one time increased from 10 to 32 +C> 2000-09-19 | J. Woollen | maximum message length increased from 10k TO 20k bytes +C> 2003-11-04 | S. Bender | added remarks/bufrlib routine +C> 2003-11-04 | D. Keyser | maxjl (maximum number of jump/link entries) increased from 15K to 16K +C> 2004-03-10 | J. Woollen | converted packing function 'pks' to real*8 +C> 2004-08-09 | J. Ator | maximum message length increased from 20K TO 50K +C> 2007-01-19 | J. Ator | prevent overflow of cval for strings longer than 8 characters; use function ibfms +C> 2009-08-03 | J. Woollen | added capability to copy long strings via ufbcpy using file pointer stored in new 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 properly encoded with all bits set to 1 +C> 2014-12-10 | J. Ator | use modules instead of common blocks +C> 2022-05-06 | J. Woollen | replace pkb with pkb8 for 8byte integers C> C> @author J. Woollen @date 1994-01-06 @@ -69,17 +69,17 @@ SUBROUTINE WRTREE(LUN) NODE = INV(N,LUN) IF(ITP(NODE).LT.3) THEN -C The value to be packed is numeric. +C The value to be packed is numeric. CALL PKB8(IVAL(N),IBT(NODE),IBAY,IBIT) ELSE -C The value to be packed is a character string. +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 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. @@ -93,8 +93,8 @@ SUBROUTINE WRTREE(LUN) 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 + NUMCHR = MIN(NCR,LEN(LSTR)) + DO JJ = 1, NUMCHR CALL IPKM(LSTR(JJ:JJ),1,255) ENDDO CALL PKC(LSTR,NUMCHR,IBAY,IBIT) @@ -117,6 +117,6 @@ SUBROUTINE WRTREE(LUN) C ------------------------- LUNCPY(LUN)=0 - + RETURN END diff --git a/src/wtstat.f b/src/wtstat.f index e7f02383..db638e17 100644 --- a/src/wtstat.f +++ b/src/wtstat.f @@ -4,13 +4,13 @@ C> ### Program history log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 1994-01-06 | J. Woollen | Original author -C> 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() -C> 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 -C> 2003-11-04 | J. Ator | Corrected a typo in test for IM validity; added documentation -C> 2003-11-04 | S. Bender | Added remarks and routine interdependencies -C> 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally -C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks +C> 1994-01-06 | J. Woollen | Original author +C> 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() +C> 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 +C> 2003-11-04 | J. Ator | Corrected a typo in test for IM validity; added documentation +C> 2003-11-04 | S. Bender | Added remarks and routine interdependencies +C> 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally +C> 2014-12-10 | J. Ator | Use modules instead of COMMON blocks C> C> @author J. Woollen @date 1994-01-06 C> diff --git a/src/x48.F b/src/x48.F index 48985de2..3c584f19 100644 --- a/src/x48.F +++ b/src/x48.F @@ -4,7 +4,7 @@ C> ### Program history log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 2022-10-12 | J. Woollen | Original author +C> 2022-10-12 | J. Woollen | Original author C> C> @author J. Woollen @date 2022-10-12 diff --git a/src/x84.F b/src/x84.F index 6deb512e..ca83a89b 100644 --- a/src/x84.F +++ b/src/x84.F @@ -5,10 +5,10 @@ C> ### Program history log C> Date | Programmer | Comments | C> -----|------------|----------| -C> 2022-10-12 | J. Woollen | Original author +C> 2022-10-12 | J. Woollen | Original author C> C> @author J. Woollen @date 2022-10-12 - + C> This subroutine reads an array containing a specified number C> of 8-byte integer values and then re-encodes them as a corresponding C> array of 4-byte integer values. From 45bacf868de2325f5d171e054ea4d7b5e21e45c8 Mon Sep 17 00:00:00 2001 From: Edward Hartnett Date: Fri, 3 Feb 2023 20:36:12 -0700 Subject: [PATCH 2/2] changed all tabs to spaces --- test/test_IN_1.F | 272 +++++++-------- test/test_IN_2.F | 232 ++++++------- test/test_IN_3.F | 516 ++++++++++++++-------------- test/test_IN_4.F | 290 ++++++++-------- test/test_IN_5.F | 52 +-- test/test_IN_6.F | 24 +- test/test_IN_7.F | 102 +++--- test/test_IN_8.F90 | 2 +- test/test_OUT_1.F | 296 ++++++++-------- test/test_OUT_2.F | 190 +++++------ test/test_OUT_3.F | 346 +++++++++---------- test/test_OUT_4.F | 96 +++--- test/test_OUT_5.F | 44 +-- test/test_OUT_6.F | 80 ++--- test/test_OUT_7.F90 | 6 +- test/test_c_interface_2.c | 48 +-- utils/debufr.c.in | 342 +++++++++---------- utils/debufr.f | 700 +++++++++++++++++++------------------- utils/gettab.f90 | 4 +- utils/readbp.f90 | 14 +- utils/readmp.f90 | 10 +- utils/split_by_subset.f90 | 2 +- utils/xbfmg.c | 322 +++++++++--------- 23 files changed, 1995 insertions(+), 1995 deletions(-) diff --git a/test/test_IN_1.F b/test/test_IN_1.F index d33fff40..5c2052f7 100644 --- a/test/test_IN_1.F +++ b/test/test_IN_1.F @@ -6,184 +6,184 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADSB, IUPBS01, IUPBS3, IBFMS - INTEGER*4 MXBF, nbyt, ierr + INTEGER*4 IREADSB, IUPBS01, IUPBS3, IBFMS + INTEGER*4 MXBF, nbyt, ierr #endif - PARAMETER ( MXBF = 20000 ) - PARAMETER ( MXBFD4 = MXBF/4 ) - PARAMETER ( MXDS3 = 20 ) + PARAMETER ( MXBF = 20000 ) + PARAMETER ( MXBFD4 = MXBF/4 ) + PARAMETER ( MXDS3 = 20 ) - PARAMETER ( MXR8PM = 10 ) - PARAMETER ( MXR8LV = 255 ) + PARAMETER ( MXR8PM = 10 ) + PARAMETER ( MXR8LV = 255 ) - REAL*8 r8arr ( MXR8PM, MXR8LV ) + REAL*8 r8arr ( MXR8PM, MXR8LV ) - INTEGER ibfmg ( MXBFD4 ) + INTEGER ibfmg ( MXBFD4 ) - CHARACTER smidstg*9, softvstg*12, cmgtag*8, - + bfmg(MXBF), cds3(MXDS3)*6, tagpr*8, - + celem(2)*60, cunit(2)*22 + CHARACTER smidstg*9, softvstg*12, cmgtag*8, + + bfmg(MXBF), cds3(MXDS3)*6, tagpr*8, + + celem(2)*60, cunit(2)*22 - CHARACTER*20 filnam / 'testfiles/IN_1' / - CHARACTER filost / 'r' / + CHARACTER*20 filnam / 'testfiles/IN_1' / + CHARACTER filost / 'r' / - EQUIVALENCE ( bfmg (1), ibfmg (1) ) + EQUIVALENCE ( bfmg (1), ibfmg (1) ) C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_1' - print *, ' using CRBMG with OPENBF IO = ''SEC3''' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_1' + print *, ' using CRBMG with OPENBF IO = ''SEC3''' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* Open the test file. - CALL COBFL ( filnam, filost ) - print *, ' COBFL -> OK' +C* Open the test file. + CALL COBFL ( filnam, filost ) + print *, ' COBFL -> OK' -C Specify format of Section 1 date/time when reading. - CALL DATELEN ( 10 ) +C Specify format of Section 1 date/time when reading. + CALL DATELEN ( 10 ) C Specify the use of Section 3 decoding. - OPEN ( UNIT = 11, FILE = '/dev/null' ) - CALL OPENBF ( 11, 'SEC3', 11 ) - print *, ' OPENBF -> OK' + OPEN ( UNIT = 11, FILE = '/dev/null' ) + CALL OPENBF ( 11, 'SEC3', 11 ) + print *, ' OPENBF -> OK' -C Specify location of master BUFR tables. - CALL MTINFO ( '../tables', 90, 91 ) - print *, ' MTINFO -> OK' +C Specify location of master BUFR tables. + CALL MTINFO ( '../tables', 90, 91 ) + print *, ' MTINFO -> OK' -C Read a BUFR message from the test file into a memory array. - CALL CRBMG ( bfmg, MXBF, nbyt, ierr ) - IF ( ierr .ne. 0 ) THEN - print *, ' CRBMG -> FAILED!!' - ELSE - print *, ' CRBMG -> OK' +C Read a BUFR message from the test file into a memory array. + CALL CRBMG ( bfmg, MXBF, nbyt, ierr ) + IF ( ierr .ne. 0 ) THEN + print *, ' CRBMG -> FAILED!!' + ELSE + print *, ' CRBMG -> OK' C Read and check some values from Section 1. - IF ( ( IUPBS01 ( ibfmg, 'MTYP' ) .eq. 2 ) .and. - + ( IUPBS01 ( ibfmg, 'MTV' ) .eq. 14 ) .and. - + ( IUPBS01 ( ibfmg, 'LENM' ) .eq. 4169 ) ) THEN - print *, ' IUPBS01 -> OK' - ELSE - print *, ' IUPBS01 -> FAILED!!' - ENDIF + IF ( ( IUPBS01 ( ibfmg, 'MTYP' ) .eq. 2 ) .and. + + ( IUPBS01 ( ibfmg, 'MTV' ) .eq. 14 ) .and. + + ( IUPBS01 ( ibfmg, 'LENM' ) .eq. 4169 ) ) THEN + print *, ' IUPBS01 -> OK' + ELSE + print *, ' IUPBS01 -> FAILED!!' + ENDIF C Read and check some values from Section 3. - IF ( ( IUPBS3 ( ibfmg, 'NSUB' ) .eq. 1 ) .and. - + ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 0 ) ) THEN - print *, ' IUPBS3 -> OK' - ELSE - print *, ' IUPBS3 -> FAILED!!' - ENDIF + IF ( ( IUPBS3 ( ibfmg, 'NSUB' ) .eq. 1 ) .and. + + ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 0 ) ) THEN + print *, ' IUPBS3 -> OK' + ELSE + print *, ' IUPBS3 -> FAILED!!' + ENDIF C Read and check some data descriptors from Section 3. - CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 ) - IF ( ( nds3 .eq. 8 ) .and. - + ( cds3(1) .eq. '309052' ) .and. - + ( cds3(5) .eq. '002095' ) ) THEN - print *, ' UPDS3 -> OK' - ELSE - print *, ' UPDS3 -> FAILED!!' - ENDIF + CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 ) + IF ( ( nds3 .eq. 8 ) .and. + + ( cds3(1) .eq. '309052' ) .and. + + ( cds3(5) .eq. '002095' ) ) THEN + print *, ' UPDS3 -> OK' + ELSE + print *, ' UPDS3 -> FAILED!!' + ENDIF C Pass the BUFR message from the memory array into the library. - CALL READERME ( ibfmg, 11, cmgtag, imgdt, ierme ) - IF ( ( ierme .eq. 0 ) .and. - + ( cmgtag .eq. 'MSTTB001' ) ) THEN - print *, ' READERME -> OK' - ELSE - print *, ' READERME -> FAILED!!' - ENDIF + CALL READERME ( ibfmg, 11, cmgtag, imgdt, ierme ) + IF ( ( ierme .eq. 0 ) .and. + + ( cmgtag .eq. 'MSTTB001' ) ) THEN + print *, ' READERME -> OK' + ELSE + print *, ' READERME -> FAILED!!' + ENDIF C Get and check the element names and units associated with C some Table B mnemonics. - CALL NEMDEFS ( 11, 'VSIGX', celem(1), cunit(1), ierndv ) - CALL NEMDEFS ( 11, 'SMID', celem(2), cunit(2), iernds ) - IF ( ( ierndv .eq. 0 ) .and. ( iernds .eq. 0 ) .and. - + ( celem(1)(1:40) .eq. - + 'Extended vertical sounding significance ' ) .and. - + ( celem(2)(1:39) .eq. - + 'Ship or mobile land station identifier ' ) .and. - + ( cunit(1)(1:12) .eq. 'FLAG TABLE ' ) .and. - + ( cunit(2)(1:10) .eq. 'CCITT IA5 ' ) ) THEN - print *, ' NEMDEFS -> OK' - ELSE - print *, ' NEMDEFS -> FAILED!!' - ENDIF + CALL NEMDEFS ( 11, 'VSIGX', celem(1), cunit(1), ierndv ) + CALL NEMDEFS ( 11, 'SMID', celem(2), cunit(2), iernds ) + IF ( ( ierndv .eq. 0 ) .and. ( iernds .eq. 0 ) .and. + + ( celem(1)(1:40) .eq. + + 'Extended vertical sounding significance ' ) .and. + + ( celem(2)(1:39) .eq. + + 'Ship or mobile land station identifier ' ) .and. + + ( cunit(1)(1:12) .eq. 'FLAG TABLE ' ) .and. + + ( cunit(2)(1:10) .eq. 'CCITT IA5 ' ) ) THEN + print *, ' NEMDEFS -> OK' + ELSE + print *, ' NEMDEFS -> FAILED!!' + ENDIF C Read and check the Section 1 date-time. - IF ( imgdt .eq. 2012093012 ) THEN - print *, ' DATELEN -> OK' - ELSE - print *, ' DATELEN -> FAILED!!' - ENDIF - -C* Read a data subset from the BUFR message. - IF ( IREADSB (11) .ne. 0 ) THEN - print *, ' IREADSB -> FAILED!!' - ELSE - print *, ' IREADSB -> OK' + IF ( imgdt .eq. 2012093012 ) THEN + print *, ' DATELEN -> OK' + ELSE + print *, ' DATELEN -> FAILED!!' + ENDIF + +C* Read a data subset from the BUFR message. + IF ( IREADSB (11) .ne. 0 ) THEN + print *, ' IREADSB -> FAILED!!' + ELSE + print *, ' IREADSB -> OK' C Get and check the parent of a Table B mnemonic. - CALL GETTAGPR ( 11, 'PRLC', 192, tagpr, iertgp ) - IF ( ( iertgp .eq. 0 ) .and. ( tagpr .eq. 'WSPLRAOB' ) ) - + THEN - print *, ' GETTAGPR -> OK' - ELSE - print *, ' GETTAGPR -> FAILED!!' - ENDIF + CALL GETTAGPR ( 11, 'PRLC', 192, tagpr, iertgp ) + IF ( ( iertgp .eq. 0 ) .and. ( tagpr .eq. 'WSPLRAOB' ) ) + + THEN + print *, ' GETTAGPR -> OK' + ELSE + print *, ' GETTAGPR -> FAILED!!' + ENDIF C Read and check some data values. - CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'CLONH A4ME HSMSL QCEVR' ) - IF ( ( nr8lv .eq. 1 ) .and. - + ( NINT(r8arr(1,1)*100000) .eq. 10388797 ).and. - + ( NINT(r8arr(2,1)) .eq. 7 ) .and. - + ( NINT(r8arr(3,1)) .eq. 14 ) .and. - + ( IBFMS(r8arr(4,1)) .eq. 1 ) ) THEN - print *, ' UFBINT -> OK' - print *, ' IBFMS -> OK' - ELSE - print *, ' UFBINT -> FAILED!!' - print *, ' IBFMS -> FAILED!!' - ENDIF + CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'CLONH A4ME HSMSL QCEVR' ) + IF ( ( nr8lv .eq. 1 ) .and. + + ( NINT(r8arr(1,1)*100000) .eq. 10388797 ).and. + + ( NINT(r8arr(2,1)) .eq. 7 ) .and. + + ( NINT(r8arr(3,1)) .eq. 14 ) .and. + + ( IBFMS(r8arr(4,1)) .eq. 1 ) ) THEN + print *, ' UFBINT -> OK' + print *, ' IBFMS -> OK' + ELSE + print *, ' UFBINT -> FAILED!!' + print *, ' IBFMS -> FAILED!!' + ENDIF C Read and check a sequence of data values. - CALL UFBSEQ ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'TDWPRAOB' ) - IF ( ( nr8lv .eq. 191 ) .and. - + ( NINT(r8arr(8,3)*100) .eq. 29416 ) .and. - + ( NINT(r8arr(10,11)*10) .eq. 55 ) .and. - + ( NINT(r8arr(2,12)) .eq. 2048 ) .and. - + ( NINT(r8arr(5,67)*100000) .eq. -1167 ) .and. - + ( NINT(r8arr(1,186)) .eq. 2523 ) ) THEN - print *, ' UFBSEQ -> OK' - ELSE - print *, ' UFBSEQ -> FAILED!!' - ENDIF + CALL UFBSEQ ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'TDWPRAOB' ) + IF ( ( nr8lv .eq. 191 ) .and. + + ( NINT(r8arr(8,3)*100) .eq. 29416 ) .and. + + ( NINT(r8arr(10,11)*10) .eq. 55 ) .and. + + ( NINT(r8arr(2,12)) .eq. 2048 ) .and. + + ( NINT(r8arr(5,67)*100000) .eq. -1167 ) .and. + + ( NINT(r8arr(1,186)) .eq. 2523 ) ) THEN + print *, ' UFBSEQ -> OK' + ELSE + print *, ' UFBSEQ -> FAILED!!' + ENDIF C Read and check some long character strings. - CALL READLC ( 11, smidstg, 'SMID' ) - CALL READLC ( 11, softvstg, 'SOFTV' ) - IF ( ( smidstg(7:9) .eq. 'UAO' ) .and. - + ( softvstg(5:12) .eq. '5.8.5.10' ) ) THEN - print *, ' READLC -> OK' - ELSE - print *, ' READLC -> FAILED!!' - ENDIF + CALL READLC ( 11, smidstg, 'SMID' ) + CALL READLC ( 11, softvstg, 'SOFTV' ) + IF ( ( smidstg(7:9) .eq. 'UAO' ) .and. + + ( softvstg(5:12) .eq. '5.8.5.10' ) ) THEN + print *, ' READLC -> OK' + ELSE + print *, ' READLC -> FAILED!!' + ENDIF - ENDIF + ENDIF - ENDIF + ENDIF -C Close the test file. - CALL CCBFL( ) - print *, ' CCBFL -> OK' +C Close the test file. + CALL CCBFL( ) + print *, ' CCBFL -> OK' - STOP - END + STOP + END diff --git a/test/test_IN_2.F b/test/test_IN_2.F index ad1fa872..980019d2 100644 --- a/test/test_IN_2.F +++ b/test/test_IN_2.F @@ -7,130 +7,130 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADMG, IUPVS01, NMSUB, IBFMS + INTEGER*4 IREADMG, IUPVS01, NMSUB, IBFMS #endif - PARAMETER ( MXR8PM = 10 ) - PARAMETER ( MXR8LV = 255 ) - - REAL*8 r8arr ( MXR8PM, MXR8LV ), GETVALNB + PARAMETER ( MXR8PM = 10 ) + PARAMETER ( MXR8LV = 255 ) - INTEGER ibit (32) + REAL*8 r8arr ( MXR8PM, MXR8LV ), GETVALNB - CHARACTER cmgtag*8 + INTEGER ibit (32) + + CHARACTER cmgtag*8 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_2' - print *, ' using OPENBF IO = ''IN'' and LUNIN != LUNDX' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_2' + print *, ' using OPENBF IO = ''IN'' and LUNIN != LUNDX' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* Open the test files. - - OPEN ( UNIT = 11, FILE = 'testfiles/IN_2', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/IN_2_bufrtab' ) - - CALL OPENBF ( 11, 'IN', 12 ) - - print *, ' OPENBF -> OK' - -C* Read the BUFR message from the BUFR file. - - IF ( IREADMG ( 11, cmgtag, imgdt ) .ne. 0 ) THEN - - print *, ' IREADMG -> FAILED!!' - - ELSE - - IF ( ( cmgtag .eq. 'NC005064' ) .and. - + ( imgdt .eq. 12101013 ) ) THEN - print *, ' IREADMG -> OK' - ELSE - print *, ' IREADMG -> FAILED!!' - ENDIF - - IF ( ( IUPVS01(11,'MSBT') .eq. 64 ) .and. - + ( IUPVS01(11,'OGCE') .eq. 7 ) .and. - + ( IUPVS01(11,'LENM') .eq. 19926 ) ) THEN - print *, ' IUPVS01 -> OK' - ELSE - print *, ' IUPVS01 -> FAILED!!' - ENDIF - - IF ( NMSUB(11) .eq. 154 ) THEN - print *, ' NMSUB -> OK' - ELSE - print *, ' NMSUB -> FAILED!!' - ENDIF - -C* Read the 5th data subset from the BUFR message. - - DO ii = 1, 5 - CALL READSB (11, ierrsb) - END DO - - IF ( ierrsb .ne. 0 ) THEN - - print *, ' READSB -> FAILED!!' - - ELSE - - print *, ' READSB -> OK' - - CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'CLAT SAZA PRLC WDIR RPID SIDP' ) - IF ( ( nr8lv .eq. 1 ) .and. - + ( NINT(r8arr(1,1)*100) .eq. 1260 ) .and. - + ( NINT(r8arr(2,1)*100) .eq. 2765 ) .and. - + ( NINT(r8arr(3,1)) .eq. 25540 ) .and. - + ( NINT(r8arr(4,1)) .eq. 218 ) .and. - + ( IBFMS(r8arr(5,1)) .eq. 1 ) ) THEN - print *, ' UFBINT -> OK' - print *, ' IBFMS -> OK' - ELSE - print *, ' UFBINT -> FAILED!!' - print *, ' IBFMS -> FAILED!!' - ENDIF - - CALL UPFTBV ( 11, 'SIDP', r8arr(6,1), 32, ibit, nib ) - IF ( ( nib .eq. 1 ) .and. ( ibit(1) .eq. 9 ) ) THEN - print *, ' UPFTBV -> OK' - ELSE - print *, ' UPFTBV -> FAILED!!' - ENDIF - - CALL UFBREP ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'GNAP PCCF MAQC NCTH' ) - IF ( ( nr8lv .eq. 12 ) .and. - + ( NINT(r8arr(1,2)) .eq. 2 ) .and. - + ( NINT(r8arr(2,4)) .eq. 86 ) .and. - + ( NINT(r8arr(2,6)) .eq. 0 ) .and. - + ( IBFMS(r8arr(3,8)) .eq. 1 ) .and. - + ( IBFMS(r8arr(4,9)) .eq. 1 ) .and. - + ( NINT(r8arr(2,11)) .eq. 97 ) .and. - + ( NINT(r8arr(1,12)) .eq. 3 ) ) THEN - print *, ' UFBREP -> OK' - ELSE - print *, ' UFBREP -> FAILED!!' - ENDIF - - IF ( ( NINT(GETVALNB(11,'NCTH',3,'PCCF',-1)) .eq. 0 ) - + .and. - + ( NINT(GETVALNB(11,'SSNX',1,'SWCM',1)) .eq. 1 ) ) - + THEN - print *, ' GETVALNB -> OK' - ELSE - print *, ' GETVALNB -> FAILED!!' - ENDIF - - ENDIF - - ENDIF - - STOP - END +C* Open the test files. + + OPEN ( UNIT = 11, FILE = 'testfiles/IN_2', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/IN_2_bufrtab' ) + + CALL OPENBF ( 11, 'IN', 12 ) + + print *, ' OPENBF -> OK' + +C* Read the BUFR message from the BUFR file. + + IF ( IREADMG ( 11, cmgtag, imgdt ) .ne. 0 ) THEN + + print *, ' IREADMG -> FAILED!!' + + ELSE + + IF ( ( cmgtag .eq. 'NC005064' ) .and. + + ( imgdt .eq. 12101013 ) ) THEN + print *, ' IREADMG -> OK' + ELSE + print *, ' IREADMG -> FAILED!!' + ENDIF + + IF ( ( IUPVS01(11,'MSBT') .eq. 64 ) .and. + + ( IUPVS01(11,'OGCE') .eq. 7 ) .and. + + ( IUPVS01(11,'LENM') .eq. 19926 ) ) THEN + print *, ' IUPVS01 -> OK' + ELSE + print *, ' IUPVS01 -> FAILED!!' + ENDIF + + IF ( NMSUB(11) .eq. 154 ) THEN + print *, ' NMSUB -> OK' + ELSE + print *, ' NMSUB -> FAILED!!' + ENDIF + +C* Read the 5th data subset from the BUFR message. + + DO ii = 1, 5 + CALL READSB (11, ierrsb) + END DO + + IF ( ierrsb .ne. 0 ) THEN + + print *, ' READSB -> FAILED!!' + + ELSE + + print *, ' READSB -> OK' + + CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'CLAT SAZA PRLC WDIR RPID SIDP' ) + IF ( ( nr8lv .eq. 1 ) .and. + + ( NINT(r8arr(1,1)*100) .eq. 1260 ) .and. + + ( NINT(r8arr(2,1)*100) .eq. 2765 ) .and. + + ( NINT(r8arr(3,1)) .eq. 25540 ) .and. + + ( NINT(r8arr(4,1)) .eq. 218 ) .and. + + ( IBFMS(r8arr(5,1)) .eq. 1 ) ) THEN + print *, ' UFBINT -> OK' + print *, ' IBFMS -> OK' + ELSE + print *, ' UFBINT -> FAILED!!' + print *, ' IBFMS -> FAILED!!' + ENDIF + + CALL UPFTBV ( 11, 'SIDP', r8arr(6,1), 32, ibit, nib ) + IF ( ( nib .eq. 1 ) .and. ( ibit(1) .eq. 9 ) ) THEN + print *, ' UPFTBV -> OK' + ELSE + print *, ' UPFTBV -> FAILED!!' + ENDIF + + CALL UFBREP ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'GNAP PCCF MAQC NCTH' ) + IF ( ( nr8lv .eq. 12 ) .and. + + ( NINT(r8arr(1,2)) .eq. 2 ) .and. + + ( NINT(r8arr(2,4)) .eq. 86 ) .and. + + ( NINT(r8arr(2,6)) .eq. 0 ) .and. + + ( IBFMS(r8arr(3,8)) .eq. 1 ) .and. + + ( IBFMS(r8arr(4,9)) .eq. 1 ) .and. + + ( NINT(r8arr(2,11)) .eq. 97 ) .and. + + ( NINT(r8arr(1,12)) .eq. 3 ) ) THEN + print *, ' UFBREP -> OK' + ELSE + print *, ' UFBREP -> FAILED!!' + ENDIF + + IF ( ( NINT(GETVALNB(11,'NCTH',3,'PCCF',-1)) .eq. 0 ) + + .and. + + ( NINT(GETVALNB(11,'SSNX',1,'SWCM',1)) .eq. 1 ) ) + + THEN + print *, ' GETVALNB -> OK' + ELSE + print *, ' GETVALNB -> FAILED!!' + ENDIF + + ENDIF + + ENDIF + + STOP + END diff --git a/test/test_IN_3.F b/test/test_IN_3.F index 6e408055..2c94340b 100644 --- a/test/test_IN_3.F +++ b/test/test_IN_3.F @@ -7,178 +7,178 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADNS, IFBGET, LCMGDF, IBFMS + INTEGER*4 IREADNS, IFBGET, LCMGDF, IBFMS #endif - PARAMETER ( MXR8PM = 6 ) - PARAMETER ( MXR8LV = 50 ) - - REAL*8 r8arr ( MXR8PM, MXR8LV ), - + r8arf ( MXR8PM, MXR8LV ), - + r8arhr ( 1, MXR8LV ), - + r8arh ( MXR8PM, MXR8LV ), - + r8ardr ( 1, MXR8LV ), - + r8ard ( MXR8PM, MXR8LV ) + PARAMETER ( MXR8PM = 6 ) + PARAMETER ( MXR8LV = 50 ) - CHARACTER cmgtag*8, celem(3)*40, cunit(3)*20 + REAL*8 r8arr ( MXR8PM, MXR8LV ), + + r8arf ( MXR8PM, MXR8LV ), + + r8arhr ( 1, MXR8LV ), + + r8arh ( MXR8PM, MXR8LV ), + + r8ardr ( 1, MXR8LV ), + + r8ard ( MXR8PM, MXR8LV ) - LOGICAL decodeOK + CHARACTER cmgtag*8, celem(3)*40, cunit(3)*20 + + LOGICAL decodeOK C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_3' - print *, ' using OPENBF IO = ''IN'' and LUNIN = LUNDX' - print *, ' using nested delayed replication' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_3' + print *, ' using OPENBF IO = ''IN'' and LUNIN = LUNDX' + print *, ' using nested delayed replication' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - OPEN ( UNIT = 11, FILE = 'testfiles/IN_3', FORM ='UNFORMATTED') - -C* First, read some values from all of the data subsets. - - CALL UFBTAB ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'CLAT CLON HSMSL {SHRVFFSQ}' ) - IF ( ( nr8lv .eq. 10 ) .and. - + ( NINT(r8arr(1,1)*100) .eq. 4025 ) .and. - + ( NINT(r8arr(3,1)) .eq. 88 ) .and. - + ( NINT(r8arr(4,1)) .eq. 12 ) .and. - + ( NINT(r8arr(2,2)*100) .eq. -8852 ) .and. - + ( NINT(r8arr(4,2)) .eq. 20 ) .and. - + ( NINT(r8arr(1,5)*100) .eq. 3352 ) .and. - + ( IBFMS(r8arr(3,5)) .eq. 1 ) .and. - + ( NINT(r8arr(1,8)*100) .eq. 3277 ) .and. - + ( NINT(r8arr(1,9)*100) .eq. 3693 ) .and. - + ( NINT(r8arr(2,9)*100) .eq. -9496 ) .and. - + ( NINT(r8arr(3,9)) .eq. 228 ) .and. - + ( NINT(r8arr(4,9)) .eq. 20 ) ) THEN - print *, ' UFBTAB -> OK' - print *, ' IBFMS -> OK' - ELSE - print *, ' UFBTAB -> FAILED!!' - print *, ' IBFMS -> FAILED!!' - ENDIF - -C* (Re)open the file for usual reading of each subset one at a time. - - CALL OPENBF ( 11, 'IN', 11 ) - - print *, ' OPENBF -> OK' - - isct = 0 - - decodeOK = .true. - - DO WHILE ( ( decodeOK ) .and. - + ( IREADNS ( 11, cmgtag, imgdt ) .eq. 0 ) ) - -C* Continue checking with the next subset. - - isct = isct + 1 - - CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, nr8rr, - + 'YEAR MNTH DAYS HOUR MINU' ) - CALL UFBREP ( 11, r8arf, MXR8PM, MXR8LV, nr8rf, - + 'TSIG YEAR MNTH DAYS HOUR MINU' ) - CALL UFBINT ( 11, r8arhr, 1, MXR8LV, nr8rhr, - + '{SHRVHTSQ}' ) - CALL UFBSEQ ( 11, r8arh, MXR8PM, MXR8LV, nr8rh, - + 'SHRVHTSQ' ) - CALL UFBINT ( 11, r8ardr, 1, MXR8LV, nr8rdr, - + '{SHRVDCSQ}' ) - CALL UFBSEQ ( 11, r8ard, MXR8PM, MXR8LV, nr8rd, - + 'SHRVDCSQ' ) - - IF ( isct .eq. 1 ) THEN - - CALL RTRCPT ( 11, ityr, itmo, itdy, ithr, itmi, ier ) - IF ( ier .ne. -1 ) decodeOK = .false. - - IF ( ( nr8rr .ne. 1 ) .or. - + ( NINT(r8arr(2,1)) .ne. 2 ) .or. - + ( NINT(r8arr(4,1)) .ne. 14 ) .or. - + ( NINT(r8arr(5,1)) .ne. 3 ) ) decodeOK = .false. - - IF ( ( nr8rf .ne. 12 ) .or. - + ( NINT(r8arf(1,1)) .ne. 4 ) .or. - + ( NINT(r8arf(2,1)) .ne. 2015 ) .or. - + ( NINT(r8arf(3,1)) .ne. 2 ) .or. - + ( NINT(r8arf(4,1)) .ne. 12 ) .or. - + ( NINT(r8arf(5,1)) .ne. 18 ) .or. - + ( NINT(r8arf(4,4)) .ne. 13 ) .or. - + ( NINT(r8arf(5,4)) .ne. 12 ) .or. - + ( NINT(r8arf(4,10)) .ne. 15 ) .or. - + ( NINT(r8arf(5,10)) .ne. 0 ) .or. - + ( NINT(r8arf(1,11)) .ne. 4 ) .or. - + ( NINT(r8arf(4,11)) .ne. 15 ) .or. - + ( NINT(r8arf(5,11)) .ne. 6 ) ) decodeOK = .false. - - IF ( ( nr8rhr .ne. 12 ) .or. - + ( NINT(r8arhr(1,1)) .ne. 1 ) .or. - + ( NINT(r8arhr(1,2)) .ne. 1 ) .or. - + ( NINT(r8arhr(1,3)) .ne. 1 ) .or. - + ( NINT(r8arhr(1,8)) .ne. 1 ) .or. - + ( nr8rh .ne. 12 ) .or. - + ( NINT(r8arh(3,1)*1000) .ne. 1402 ) .or. - + ( NINT(r8arh(5,1)) .ne. 26 ) .or. - + ( NINT(r8arh(3,2)*1000) .ne. 1372 ) .or. - + ( NINT(r8arh(1,8)) .ne. 0 ) .or. - + ( NINT(r8arh(2,8)) .ne. 0 ) .or. - + ( nr8rdr .ne. 12 ) .or. - + ( NINT(r8ardr(1,1)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,2)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,4)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,6)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,9)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,10)) .ne. 1 ) .or. - + ( nr8rd .ne. 3 ) .or. - + ( NINT(r8ard(3,1)*100) .ne. 33980 ) .or. - + ( NINT(r8ard(3,2)*100) .ne. 33131 ) .or. - + ( NINT(r8ard(5,2)) .ne. 26 ) .or. - + ( NINT(r8ard(1,3)) .ne. 0 ) .or. - + ( NINT(r8ard(2,3)) .ne. 1 ) .or. - + ( NINT(r8ard(3,3)*100) .ne. 32564 ) ) - + decodeOK = .false. - - ELSE IF ( isct .eq. 4 ) THEN - - CALL RTRCPT ( 11, ityr, itmo, itdy, ithr, itmi, ier ) - IF ( ( ier .ne. 0 ) .or. ( ityr .ne. 2014 ) .or. - + ( itmo .ne. 10 ) .or. ( itdy .ne. 5 ) .or. - + ( ithr .ne. 12 ) .or. ( itmi .ne. 52 ) ) - + decodeOK = .false. - - IF ( ( nr8rhr .ne. 20 ) .or. - + ( NINT(r8arhr(1,1)) .ne. 2 ) .or. - + ( NINT(r8arhr(1,2)) .ne. 2 ) .or. - + ( NINT(r8arhr(1,12)) .ne. 2 ) .or. - + ( NINT(r8arhr(1,19)) .ne. 2 ) .or. - + ( nr8rh .ne. 40 ) .or. - + ( NINT(r8arh(1,1)) .ne. 0 ) .or. - + ( NINT(r8arh(3,1)*1000) .ne. 2286 ) .or. - + ( NINT(r8arh(1,2)) .ne. 2 ) .or. - + ( NINT(r8arh(3,2)*1000) .ne. 2286 ) .or. - + ( NINT(r8arh(1,3)) .ne. 0 ) .or. - + ( NINT(r8arh(3,3)*1000) .ne. 2256 ) .or. - + ( NINT(r8arh(1,4)) .ne. 2 ) .or. - + ( NINT(r8arh(3,4)*1000) .ne. 2256 ) .or. - + ( NINT(r8arh(1,37)) .ne. 0 ) .or. - + ( NINT(r8arh(3,37)*1000) .ne. 2225 ) .or. - + ( NINT(r8arh(1,38)) .ne. 2 ) .or. - + ( NINT(r8arh(3,38)*1000) .ne. 2225 ) .or. - + ( nr8rdr .ne. 20 ) .or. - + ( NINT(r8ardr(1,4)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,6)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,9)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,10)) .ne. 0 ) .or. - + ( NINT(r8ardr(1,18)) .ne. 0 ) .or. - + ( nr8rd .ne. 0 ) ) - + decodeOK = .false. - - ELSE IF ( isct .eq. 6 ) THEN + OPEN ( UNIT = 11, FILE = 'testfiles/IN_3', FORM ='UNFORMATTED') + +C* First, read some values from all of the data subsets. + + CALL UFBTAB ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'CLAT CLON HSMSL {SHRVFFSQ}' ) + IF ( ( nr8lv .eq. 10 ) .and. + + ( NINT(r8arr(1,1)*100) .eq. 4025 ) .and. + + ( NINT(r8arr(3,1)) .eq. 88 ) .and. + + ( NINT(r8arr(4,1)) .eq. 12 ) .and. + + ( NINT(r8arr(2,2)*100) .eq. -8852 ) .and. + + ( NINT(r8arr(4,2)) .eq. 20 ) .and. + + ( NINT(r8arr(1,5)*100) .eq. 3352 ) .and. + + ( IBFMS(r8arr(3,5)) .eq. 1 ) .and. + + ( NINT(r8arr(1,8)*100) .eq. 3277 ) .and. + + ( NINT(r8arr(1,9)*100) .eq. 3693 ) .and. + + ( NINT(r8arr(2,9)*100) .eq. -9496 ) .and. + + ( NINT(r8arr(3,9)) .eq. 228 ) .and. + + ( NINT(r8arr(4,9)) .eq. 20 ) ) THEN + print *, ' UFBTAB -> OK' + print *, ' IBFMS -> OK' + ELSE + print *, ' UFBTAB -> FAILED!!' + print *, ' IBFMS -> FAILED!!' + ENDIF + +C* (Re)open the file for usual reading of each subset one at a time. + + CALL OPENBF ( 11, 'IN', 11 ) + + print *, ' OPENBF -> OK' + + isct = 0 + + decodeOK = .true. + + DO WHILE ( ( decodeOK ) .and. + + ( IREADNS ( 11, cmgtag, imgdt ) .eq. 0 ) ) + +C* Continue checking with the next subset. + + isct = isct + 1 + + CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, nr8rr, + + 'YEAR MNTH DAYS HOUR MINU' ) + CALL UFBREP ( 11, r8arf, MXR8PM, MXR8LV, nr8rf, + + 'TSIG YEAR MNTH DAYS HOUR MINU' ) + CALL UFBINT ( 11, r8arhr, 1, MXR8LV, nr8rhr, + + '{SHRVHTSQ}' ) + CALL UFBSEQ ( 11, r8arh, MXR8PM, MXR8LV, nr8rh, + + 'SHRVHTSQ' ) + CALL UFBINT ( 11, r8ardr, 1, MXR8LV, nr8rdr, + + '{SHRVDCSQ}' ) + CALL UFBSEQ ( 11, r8ard, MXR8PM, MXR8LV, nr8rd, + + 'SHRVDCSQ' ) + + IF ( isct .eq. 1 ) THEN + + CALL RTRCPT ( 11, ityr, itmo, itdy, ithr, itmi, ier ) + IF ( ier .ne. -1 ) decodeOK = .false. + + IF ( ( nr8rr .ne. 1 ) .or. + + ( NINT(r8arr(2,1)) .ne. 2 ) .or. + + ( NINT(r8arr(4,1)) .ne. 14 ) .or. + + ( NINT(r8arr(5,1)) .ne. 3 ) ) decodeOK = .false. + + IF ( ( nr8rf .ne. 12 ) .or. + + ( NINT(r8arf(1,1)) .ne. 4 ) .or. + + ( NINT(r8arf(2,1)) .ne. 2015 ) .or. + + ( NINT(r8arf(3,1)) .ne. 2 ) .or. + + ( NINT(r8arf(4,1)) .ne. 12 ) .or. + + ( NINT(r8arf(5,1)) .ne. 18 ) .or. + + ( NINT(r8arf(4,4)) .ne. 13 ) .or. + + ( NINT(r8arf(5,4)) .ne. 12 ) .or. + + ( NINT(r8arf(4,10)) .ne. 15 ) .or. + + ( NINT(r8arf(5,10)) .ne. 0 ) .or. + + ( NINT(r8arf(1,11)) .ne. 4 ) .or. + + ( NINT(r8arf(4,11)) .ne. 15 ) .or. + + ( NINT(r8arf(5,11)) .ne. 6 ) ) decodeOK = .false. + + IF ( ( nr8rhr .ne. 12 ) .or. + + ( NINT(r8arhr(1,1)) .ne. 1 ) .or. + + ( NINT(r8arhr(1,2)) .ne. 1 ) .or. + + ( NINT(r8arhr(1,3)) .ne. 1 ) .or. + + ( NINT(r8arhr(1,8)) .ne. 1 ) .or. + + ( nr8rh .ne. 12 ) .or. + + ( NINT(r8arh(3,1)*1000) .ne. 1402 ) .or. + + ( NINT(r8arh(5,1)) .ne. 26 ) .or. + + ( NINT(r8arh(3,2)*1000) .ne. 1372 ) .or. + + ( NINT(r8arh(1,8)) .ne. 0 ) .or. + + ( NINT(r8arh(2,8)) .ne. 0 ) .or. + + ( nr8rdr .ne. 12 ) .or. + + ( NINT(r8ardr(1,1)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,2)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,4)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,6)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,9)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,10)) .ne. 1 ) .or. + + ( nr8rd .ne. 3 ) .or. + + ( NINT(r8ard(3,1)*100) .ne. 33980 ) .or. + + ( NINT(r8ard(3,2)*100) .ne. 33131 ) .or. + + ( NINT(r8ard(5,2)) .ne. 26 ) .or. + + ( NINT(r8ard(1,3)) .ne. 0 ) .or. + + ( NINT(r8ard(2,3)) .ne. 1 ) .or. + + ( NINT(r8ard(3,3)*100) .ne. 32564 ) ) + + decodeOK = .false. + + ELSE IF ( isct .eq. 4 ) THEN + + CALL RTRCPT ( 11, ityr, itmo, itdy, ithr, itmi, ier ) + IF ( ( ier .ne. 0 ) .or. ( ityr .ne. 2014 ) .or. + + ( itmo .ne. 10 ) .or. ( itdy .ne. 5 ) .or. + + ( ithr .ne. 12 ) .or. ( itmi .ne. 52 ) ) + + decodeOK = .false. + + IF ( ( nr8rhr .ne. 20 ) .or. + + ( NINT(r8arhr(1,1)) .ne. 2 ) .or. + + ( NINT(r8arhr(1,2)) .ne. 2 ) .or. + + ( NINT(r8arhr(1,12)) .ne. 2 ) .or. + + ( NINT(r8arhr(1,19)) .ne. 2 ) .or. + + ( nr8rh .ne. 40 ) .or. + + ( NINT(r8arh(1,1)) .ne. 0 ) .or. + + ( NINT(r8arh(3,1)*1000) .ne. 2286 ) .or. + + ( NINT(r8arh(1,2)) .ne. 2 ) .or. + + ( NINT(r8arh(3,2)*1000) .ne. 2286 ) .or. + + ( NINT(r8arh(1,3)) .ne. 0 ) .or. + + ( NINT(r8arh(3,3)*1000) .ne. 2256 ) .or. + + ( NINT(r8arh(1,4)) .ne. 2 ) .or. + + ( NINT(r8arh(3,4)*1000) .ne. 2256 ) .or. + + ( NINT(r8arh(1,37)) .ne. 0 ) .or. + + ( NINT(r8arh(3,37)*1000) .ne. 2225 ) .or. + + ( NINT(r8arh(1,38)) .ne. 2 ) .or. + + ( NINT(r8arh(3,38)*1000) .ne. 2225 ) .or. + + ( nr8rdr .ne. 20 ) .or. + + ( NINT(r8ardr(1,4)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,6)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,9)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,10)) .ne. 0 ) .or. + + ( NINT(r8ardr(1,18)) .ne. 0 ) .or. + + ( nr8rd .ne. 0 ) ) + + decodeOK = .false. + + ELSE IF ( isct .eq. 6 ) THEN IF ( IFBGET ( 11 ) .eq. 0 ) THEN print *, ' IFBGET -> OK' @@ -192,100 +192,100 @@ print *, ' LCMGDF -> FAILED!!' ENDIF - IF ( ( nr8rr .ne. 1 ) .or. - + ( NINT(r8arr(2,1)) .ne. 10 ) .or. - + ( NINT(r8arr(4,1)) .ne. 12 ) .or. - + ( NINT(r8arr(5,1)) .ne. 49 ) ) decodeOK = .false. - - IF ( ( nr8rf .ne. 20 ) .or. - + ( NINT(r8arf(1,1)) .ne. 4 ) .or. - + ( NINT(r8arf(2,1)) .ne. 2014 ) .or. - + ( NINT(r8arf(3,1)) .ne. 10 ) .or. - + ( NINT(r8arf(4,1)) .ne. 5 ) .or. - + ( NINT(r8arf(5,1)) .ne. 18 ) .or. - + ( NINT(r8arf(4,3)) .ne. 6 ) .or. - + ( NINT(r8arf(5,3)) .ne. 6 ) .or. - + ( NINT(r8arf(4,9)) .ne. 7 ) .or. - + ( NINT(r8arf(5,9)) .ne. 18 ) .or. - + ( NINT(r8arf(1,16)) .ne. 4 ) .or. - + ( NINT(r8arf(4,16)) .ne. 9 ) .or. - + ( NINT(r8arf(5,16)) .ne. 12 ) .or. - + ( NINT(r8arf(4,18)) .ne. 10 ) .or. - + ( NINT(r8arf(5,18)) .ne. 0 ) ) decodeOK = .false. - - ELSE IF ( isct .eq. 7 ) THEN - - IF ( ( nr8rhr .ne. 20 ) .or. - + ( NINT(r8arhr(1,1)) .ne. 0 ) .or. - + ( NINT(r8arhr(1,5)) .ne. 0 ) .or. - + ( NINT(r8arhr(1,13)) .ne. 0 ) .or. - + ( NINT(r8arhr(1,18)) .ne. 0 ) .or. - + ( nr8rh .ne. 0 ) .or. - + ( nr8rdr .ne. 20 ) .or. - + ( NINT(r8ardr(1,1)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,2)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,11)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,12)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,13)) .ne. 1 ) .or. - + ( NINT(r8ardr(1,15)) .ne. 1 ) .or. - + ( nr8rd .ne. 20 ) .or. - + ( NINT(r8ard(3,1)*100) .ne. 10421 ) .or. - + ( NINT(r8ard(3,4)*100) .ne. 8976 ) .or. - + ( NINT(r8ard(3,11)*100) .ne. 5069 ) .or. - + ( NINT(r8ard(3,12)*100) .ne. 4616 ) .or. - + ( NINT(r8ard(1,13)) .ne. 0 ) .or. - + ( NINT(r8ard(2,13)) .ne. 0 ) .or. - + ( NINT(r8ard(3,13)*100) .ne. 4163 ) .or. - + ( NINT(r8ard(4,13)) .ne. 1 ) .or. - + ( NINT(r8ard(5,13)) .ne. 26 ) .or. - + ( NINT(r8ard(3,15)*100) .ne. 3766 ) ) - + decodeOK = .false. - - ELSE IF ( isct .eq. 10 ) THEN - - IF ( IFBGET ( 11 ) .ne. 0 ) THEN - print *, ' IFBGET -> OK' - ELSE - print *, ' IFBGET -> FAILED!!' - ENDIF - ENDIF - - ENDDO - -C* Verify that all available subsets were successfully read. - - IF ( ( decodeOK ) .and. ( isct .eq. 10 ) ) THEN - print *, ' IREADNS -> OK' - print *, ' RTRCPT -> OK' - print *, ' UFBINT -> OK' - print *, ' UFBREP -> OK' - print *, ' UFBSEQ -> OK' - ELSE - print *, ' IREADNS -> FAILED!!' - print *, ' RTRCPT -> FAILED!!' - print *, ' UFBINT -> FAILED!!' - print *, ' UFBREP -> FAILED!!' - print *, ' UFBSEQ -> FAILED!!' - ENDIF - - CALL NEMDEFS ( 11, 'HSMSL', celem(1), cunit(1), ierndh ) - CALL NEMDEFS ( 11, 'SHRV', celem(2), cunit(2), iernds ) - CALL NEMDEFS ( 11, 'DCHG', celem(3), cunit(3), ierndd ) - IF ( ( ierndh .eq. 0 ) .and. ( iernds .eq. 0 ) .and. - + ( ierndd .eq. 0 ) .and. - + ( celem(1)(1:36) .eq. - + 'HEIGHT OF STATION GROUND ABOVE MSL ' ) .and. - + ( cunit(1)(1:9) .eq. 'METERS ' ) .and. - + ( celem(2)(1:24) .eq. - + 'SHEF DATA REVISION FLAG ' ) .and. - + ( cunit(2)(1:12) .eq. 'CODE TABLE ' ) .and. - + ( celem(3)(1:15) .eq. - + 'DISCHARGE ' ) .and. - + ( cunit(3)(1:20) .eq. 'METERS**3/SECOND ' ) ) THEN - print *, ' NEMDEFS -> OK' - ELSE - print *, ' NEMDEFS -> FAILED!!' - ENDIF - - STOP - END + IF ( ( nr8rr .ne. 1 ) .or. + + ( NINT(r8arr(2,1)) .ne. 10 ) .or. + + ( NINT(r8arr(4,1)) .ne. 12 ) .or. + + ( NINT(r8arr(5,1)) .ne. 49 ) ) decodeOK = .false. + + IF ( ( nr8rf .ne. 20 ) .or. + + ( NINT(r8arf(1,1)) .ne. 4 ) .or. + + ( NINT(r8arf(2,1)) .ne. 2014 ) .or. + + ( NINT(r8arf(3,1)) .ne. 10 ) .or. + + ( NINT(r8arf(4,1)) .ne. 5 ) .or. + + ( NINT(r8arf(5,1)) .ne. 18 ) .or. + + ( NINT(r8arf(4,3)) .ne. 6 ) .or. + + ( NINT(r8arf(5,3)) .ne. 6 ) .or. + + ( NINT(r8arf(4,9)) .ne. 7 ) .or. + + ( NINT(r8arf(5,9)) .ne. 18 ) .or. + + ( NINT(r8arf(1,16)) .ne. 4 ) .or. + + ( NINT(r8arf(4,16)) .ne. 9 ) .or. + + ( NINT(r8arf(5,16)) .ne. 12 ) .or. + + ( NINT(r8arf(4,18)) .ne. 10 ) .or. + + ( NINT(r8arf(5,18)) .ne. 0 ) ) decodeOK = .false. + + ELSE IF ( isct .eq. 7 ) THEN + + IF ( ( nr8rhr .ne. 20 ) .or. + + ( NINT(r8arhr(1,1)) .ne. 0 ) .or. + + ( NINT(r8arhr(1,5)) .ne. 0 ) .or. + + ( NINT(r8arhr(1,13)) .ne. 0 ) .or. + + ( NINT(r8arhr(1,18)) .ne. 0 ) .or. + + ( nr8rh .ne. 0 ) .or. + + ( nr8rdr .ne. 20 ) .or. + + ( NINT(r8ardr(1,1)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,2)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,11)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,12)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,13)) .ne. 1 ) .or. + + ( NINT(r8ardr(1,15)) .ne. 1 ) .or. + + ( nr8rd .ne. 20 ) .or. + + ( NINT(r8ard(3,1)*100) .ne. 10421 ) .or. + + ( NINT(r8ard(3,4)*100) .ne. 8976 ) .or. + + ( NINT(r8ard(3,11)*100) .ne. 5069 ) .or. + + ( NINT(r8ard(3,12)*100) .ne. 4616 ) .or. + + ( NINT(r8ard(1,13)) .ne. 0 ) .or. + + ( NINT(r8ard(2,13)) .ne. 0 ) .or. + + ( NINT(r8ard(3,13)*100) .ne. 4163 ) .or. + + ( NINT(r8ard(4,13)) .ne. 1 ) .or. + + ( NINT(r8ard(5,13)) .ne. 26 ) .or. + + ( NINT(r8ard(3,15)*100) .ne. 3766 ) ) + + decodeOK = .false. + + ELSE IF ( isct .eq. 10 ) THEN + + IF ( IFBGET ( 11 ) .ne. 0 ) THEN + print *, ' IFBGET -> OK' + ELSE + print *, ' IFBGET -> FAILED!!' + ENDIF + ENDIF + + ENDDO + +C* Verify that all available subsets were successfully read. + + IF ( ( decodeOK ) .and. ( isct .eq. 10 ) ) THEN + print *, ' IREADNS -> OK' + print *, ' RTRCPT -> OK' + print *, ' UFBINT -> OK' + print *, ' UFBREP -> OK' + print *, ' UFBSEQ -> OK' + ELSE + print *, ' IREADNS -> FAILED!!' + print *, ' RTRCPT -> FAILED!!' + print *, ' UFBINT -> FAILED!!' + print *, ' UFBREP -> FAILED!!' + print *, ' UFBSEQ -> FAILED!!' + ENDIF + + CALL NEMDEFS ( 11, 'HSMSL', celem(1), cunit(1), ierndh ) + CALL NEMDEFS ( 11, 'SHRV', celem(2), cunit(2), iernds ) + CALL NEMDEFS ( 11, 'DCHG', celem(3), cunit(3), ierndd ) + IF ( ( ierndh .eq. 0 ) .and. ( iernds .eq. 0 ) .and. + + ( ierndd .eq. 0 ) .and. + + ( celem(1)(1:36) .eq. + + 'HEIGHT OF STATION GROUND ABOVE MSL ' ) .and. + + ( cunit(1)(1:9) .eq. 'METERS ' ) .and. + + ( celem(2)(1:24) .eq. + + 'SHEF DATA REVISION FLAG ' ) .and. + + ( cunit(2)(1:12) .eq. 'CODE TABLE ' ) .and. + + ( celem(3)(1:15) .eq. + + 'DISCHARGE ' ) .and. + + ( cunit(3)(1:20) .eq. 'METERS**3/SECOND ' ) ) THEN + print *, ' NEMDEFS -> OK' + ELSE + print *, ' NEMDEFS -> FAILED!!' + ENDIF + + STOP + END diff --git a/test/test_IN_4.F b/test/test_IN_4.F index 88dd231e..8c055a86 100644 --- a/test/test_IN_4.F +++ b/test/test_IN_4.F @@ -7,163 +7,163 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADSB, IUPBS01, IUPBS3, IBFMS - INTEGER*4 MXBF, nbyt, ierr + INTEGER*4 IREADSB, IUPBS01, IUPBS3, IBFMS + INTEGER*4 MXBF, nbyt, ierr #endif - PARAMETER ( MXBF = 20000 ) - PARAMETER ( MXBFD4 = MXBF/4 ) - PARAMETER ( MXDS3 = 60 ) + PARAMETER ( MXBF = 20000 ) + PARAMETER ( MXBFD4 = MXBF/4 ) + PARAMETER ( MXDS3 = 60 ) - PARAMETER ( MXR8PM = 10 ) - PARAMETER ( MXR8LV = 255 ) + PARAMETER ( MXR8PM = 10 ) + PARAMETER ( MXR8LV = 255 ) - REAL*8 r8arr ( MXR8PM, MXR8LV ), - + r8arr2 ( MXR8PM, MXR8LV ) + REAL*8 r8arr ( MXR8PM, MXR8LV ), + + r8arr2 ( MXR8PM, MXR8LV ) - INTEGER ibfmg ( MXBFD4 ) + INTEGER ibfmg ( MXBFD4 ) - CHARACTER cmgtag*8, bfmg(MXBF), cds3(MXDS3)*6, - + tag1*8, tag2*8, tag3*8 + CHARACTER cmgtag*8, bfmg(MXBF), cds3(MXDS3)*6, + + tag1*8, tag2*8, tag3*8 - CHARACTER*20 filnam / 'testfiles/IN_4' / - CHARACTER filost / 'r' / + CHARACTER*20 filnam / 'testfiles/IN_4' / + CHARACTER filost / 'r' / - EQUIVALENCE ( bfmg (1), ibfmg (1) ) + EQUIVALENCE ( bfmg (1), ibfmg (1) ) C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_4' - print *, ' using CRBMG with OPENBF IO = ''SEC3''' - print *, ' using bitmap and marker operators' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_4' + print *, ' using CRBMG with OPENBF IO = ''SEC3''' + print *, ' using bitmap and marker operators' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* Open the test file. - - CALL COBFL ( filnam, filost ) - print *, ' COBFL -> OK' - - CALL DATELEN ( 10 ) - - OPEN ( UNIT = 11, FILE = '/dev/null' ) - CALL OPENBF ( 11, 'SEC3', 11 ) - - print *, ' OPENBF -> OK' - - CALL MTINFO ( '../tables', 90, 91 ) - print *, ' MTINFO -> OK' - -C* Read the BUFR message from the BUFR file. - - CALL CRBMG ( bfmg, MXBF, nbyt, ierr ) - IF ( ierr .ne. 0 ) THEN - print *, ' CRBMG -> FAILED!!' - ELSE - print *, ' CRBMG -> OK' - - IF ( ( IUPBS01 ( ibfmg, 'MTYP' ) .eq. 5 ) .and. - + ( IUPBS01 ( ibfmg, 'MTV' ) .eq. 12 ) .and. - + ( IUPBS01 ( ibfmg, 'LENM' ) .eq. 3588 ) ) THEN - print *, ' IUPBS01 -> OK' - ELSE - print *, ' IUPBS01 -> FAILED!!' - ENDIF - - IF ( ( IUPBS3 ( ibfmg, 'NSUB' ) .eq. 31 ) .and. - + ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 1 ) ) THEN - print *, ' IUPBS3 -> OK' - ELSE - print *, ' IUPBS3 -> FAILED!!' - ENDIF - - CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 ) - IF ( ( nds3 .eq. 51 ) .and. - + ( cds3(1) .eq. '310023' ) .and. - + ( cds3(5) .eq. '031031' ) .and. - + ( cds3(32) .eq. '237000' ) .and. - + ( cds3(44) .eq. '224255' ) ) THEN - print *, ' UPDS3 -> OK' - ELSE - print *, ' UPDS3 -> FAILED!!' - ENDIF - - CALL READERME ( ibfmg, 11, cmgtag, imgdt, ierme ) - IF ( ( ierme .eq. 0 ) .and. - + ( cmgtag .eq. 'MSTTB001' ) ) THEN - print *, ' READERME -> OK' - ELSE - print *, ' READERME -> FAILED!!' - ENDIF - - IF ( imgdt .eq. 2016041815 ) THEN - print *, ' DATELEN -> OK' - ELSE - print *, ' DATELEN -> FAILED!!' - ENDIF - -C* Read the data subset from the BUFR message. - - IF ( IREADSB (11) .ne. 0 ) THEN - print *, ' IREADSB -> FAILED!!' - ELSE - print *, ' IREADSB -> OK' - - CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, - + nr8lv, 'CLONH SAID SAZA HITE' ) - IF ( ( nr8lv .eq. 1 ) .and. - + ( NINT(r8arr(1,1)*100000) .eq. -4246453 ).and. - + ( NINT(r8arr(2,1)) .eq. 57 ) .and. - + ( NINT(r8arr(3,1)*100) .eq. 5407 ) .and. - + ( IBFMS(r8arr(4,1)) .eq. 1 ) ) THEN - print *, ' UFBINT -> OK' - print *, ' IBFMS -> OK' - ELSE - print *, ' UFBINT -> FAILED!!' - print *, ' IBFMS -> FAILED!!' - ENDIF - - CALL UFBREP ( 11, r8arr, MXR8PM, MXR8LV, nr8lv, - + 'PCCF' ) - CALL UFBREP ( 11, r8arr2, MXR8PM, MXR8LV, nr8lv2, - + '224255' ) - IF ( ( nr8lv .eq. 180 ) .and. - + ( NINT(r8arr(1,12)) .eq. 86 ) .and. - + ( NINT(r8arr(1,15)) .eq. 38 ) .and. - + ( NINT(r8arr(1,102)) .eq. 88 ) .and. - + ( NINT(r8arr(1,141)) .eq. 10 ) .and. - + ( nr8lv2 .eq. 72 ) .and. - + ( NINT(r8arr2(1,12)*10) .eq. 6 ) .and. - + ( NINT(r8arr2(1,33)*10) .eq. 4 ) ) THEN - print *, ' UFBREP -> OK' - ELSE - print *, ' UFBREP -> FAILED!!' - ENDIF - - CALL GETTAGRE ( 11, 'PCCF', 57, tag1, ntag1, ier1 ) - CALL GETTAGRE ( 11, 'PCCF', 154, tag2, ntag2, ier2 ) - CALL GETTAGRE ( 11, '224255', 65, tag3, ntag3, ier3 ) - IF ( ( ier1 .eq. 0 ) .and. - + ( ier2 .eq. 0 ) .and. - + ( ier3 .eq. 0 ) .and. - + (tag1 .eq. 'TMBRST ') .and. (ntag1 .eq. 7) .and. - + (tag2 .eq. 'SPRD ') .and. (ntag2 .eq. 4) .and. - + (tag3 .eq. 'RDNE ') .and. (ntag3 .eq. 10) ) THEN - print *, ' GETTAGRE -> OK' - ELSE - print *, ' GETTAGRE -> FAILED!!' - ENDIF - - ENDIF - - ENDIF - - CALL CCBFL( ) - print *, ' CCBFL -> OK' - - STOP - END +C* Open the test file. + + CALL COBFL ( filnam, filost ) + print *, ' COBFL -> OK' + + CALL DATELEN ( 10 ) + + OPEN ( UNIT = 11, FILE = '/dev/null' ) + CALL OPENBF ( 11, 'SEC3', 11 ) + + print *, ' OPENBF -> OK' + + CALL MTINFO ( '../tables', 90, 91 ) + print *, ' MTINFO -> OK' + +C* Read the BUFR message from the BUFR file. + + CALL CRBMG ( bfmg, MXBF, nbyt, ierr ) + IF ( ierr .ne. 0 ) THEN + print *, ' CRBMG -> FAILED!!' + ELSE + print *, ' CRBMG -> OK' + + IF ( ( IUPBS01 ( ibfmg, 'MTYP' ) .eq. 5 ) .and. + + ( IUPBS01 ( ibfmg, 'MTV' ) .eq. 12 ) .and. + + ( IUPBS01 ( ibfmg, 'LENM' ) .eq. 3588 ) ) THEN + print *, ' IUPBS01 -> OK' + ELSE + print *, ' IUPBS01 -> FAILED!!' + ENDIF + + IF ( ( IUPBS3 ( ibfmg, 'NSUB' ) .eq. 31 ) .and. + + ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 1 ) ) THEN + print *, ' IUPBS3 -> OK' + ELSE + print *, ' IUPBS3 -> FAILED!!' + ENDIF + + CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 ) + IF ( ( nds3 .eq. 51 ) .and. + + ( cds3(1) .eq. '310023' ) .and. + + ( cds3(5) .eq. '031031' ) .and. + + ( cds3(32) .eq. '237000' ) .and. + + ( cds3(44) .eq. '224255' ) ) THEN + print *, ' UPDS3 -> OK' + ELSE + print *, ' UPDS3 -> FAILED!!' + ENDIF + + CALL READERME ( ibfmg, 11, cmgtag, imgdt, ierme ) + IF ( ( ierme .eq. 0 ) .and. + + ( cmgtag .eq. 'MSTTB001' ) ) THEN + print *, ' READERME -> OK' + ELSE + print *, ' READERME -> FAILED!!' + ENDIF + + IF ( imgdt .eq. 2016041815 ) THEN + print *, ' DATELEN -> OK' + ELSE + print *, ' DATELEN -> FAILED!!' + ENDIF + +C* Read the data subset from the BUFR message. + + IF ( IREADSB (11) .ne. 0 ) THEN + print *, ' IREADSB -> FAILED!!' + ELSE + print *, ' IREADSB -> OK' + + CALL UFBINT ( 11, r8arr, MXR8PM, MXR8LV, + + nr8lv, 'CLONH SAID SAZA HITE' ) + IF ( ( nr8lv .eq. 1 ) .and. + + ( NINT(r8arr(1,1)*100000) .eq. -4246453 ).and. + + ( NINT(r8arr(2,1)) .eq. 57 ) .and. + + ( NINT(r8arr(3,1)*100) .eq. 5407 ) .and. + + ( IBFMS(r8arr(4,1)) .eq. 1 ) ) THEN + print *, ' UFBINT -> OK' + print *, ' IBFMS -> OK' + ELSE + print *, ' UFBINT -> FAILED!!' + print *, ' IBFMS -> FAILED!!' + ENDIF + + CALL UFBREP ( 11, r8arr, MXR8PM, MXR8LV, nr8lv, + + 'PCCF' ) + CALL UFBREP ( 11, r8arr2, MXR8PM, MXR8LV, nr8lv2, + + '224255' ) + IF ( ( nr8lv .eq. 180 ) .and. + + ( NINT(r8arr(1,12)) .eq. 86 ) .and. + + ( NINT(r8arr(1,15)) .eq. 38 ) .and. + + ( NINT(r8arr(1,102)) .eq. 88 ) .and. + + ( NINT(r8arr(1,141)) .eq. 10 ) .and. + + ( nr8lv2 .eq. 72 ) .and. + + ( NINT(r8arr2(1,12)*10) .eq. 6 ) .and. + + ( NINT(r8arr2(1,33)*10) .eq. 4 ) ) THEN + print *, ' UFBREP -> OK' + ELSE + print *, ' UFBREP -> FAILED!!' + ENDIF + + CALL GETTAGRE ( 11, 'PCCF', 57, tag1, ntag1, ier1 ) + CALL GETTAGRE ( 11, 'PCCF', 154, tag2, ntag2, ier2 ) + CALL GETTAGRE ( 11, '224255', 65, tag3, ntag3, ier3 ) + IF ( ( ier1 .eq. 0 ) .and. + + ( ier2 .eq. 0 ) .and. + + ( ier3 .eq. 0 ) .and. + + (tag1 .eq. 'TMBRST ') .and. (ntag1 .eq. 7) .and. + + (tag2 .eq. 'SPRD ') .and. (ntag2 .eq. 4) .and. + + (tag3 .eq. 'RDNE ') .and. (ntag3 .eq. 10) ) THEN + print *, ' GETTAGRE -> OK' + ELSE + print *, ' GETTAGRE -> FAILED!!' + ENDIF + + ENDIF + + ENDIF + + CALL CCBFL( ) + print *, ' CCBFL -> OK' + + STOP + END diff --git a/test/test_IN_5.F b/test/test_IN_5.F index 4ccc5acd..a60bd501 100644 --- a/test/test_IN_5.F +++ b/test/test_IN_5.F @@ -7,49 +7,49 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADNS + INTEGER*4 IREADNS #endif - PARAMETER ( MXR8PM = 6 ) - PARAMETER ( MXR8LV = 50 ) - - CHARACTER cmgtag*8, - + cmeang1*40, cmeang2*40, cmeang3*40, cmeang4*40 + PARAMETER ( MXR8PM = 6 ) + PARAMETER ( MXR8LV = 50 ) + + CHARACTER cmgtag*8, + + cmeang1*40, cmeang2*40, cmeang3*40, cmeang4*40 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_5' - print *, ' using OPENBF IO = ''IN'' and LUNIN = LUNDX' - print *, ' using PREPBUFR and code/flag table meaning strings' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_5' + print *, ' using OPENBF IO = ''IN'' and LUNIN = LUNDX' + print *, ' using PREPBUFR and code/flag table meaning strings' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - OPEN ( UNIT = 11, FILE = 'testfiles/IN_5', FORM ='UNFORMATTED') + OPEN ( UNIT = 11, FILE = 'testfiles/IN_5', FORM ='UNFORMATTED') - CALL OPENBF ( 11, 'IN', 11 ) + CALL OPENBF ( 11, 'IN', 11 ) - print *, ' OPENBF -> OK' + print *, ' OPENBF -> OK' CALL MTINFO ( '../tables', 90, 91 ) print *, ' MTINFO -> OK' CALL CODFLG ( 'Y' ) - print *, ' CODFLG -> OK' + print *, ' CODFLG -> OK' - IF ( IREADNS ( 11, cmgtag, imgdt ) .ne. 0 ) THEN + IF ( IREADNS ( 11, cmgtag, imgdt ) .ne. 0 ) THEN - print *, ' IREADNS -> FAILED!!' + print *, ' IREADNS -> FAILED!!' - ELSE + ELSE - print *, ' IREADNS -> OK' + print *, ' IREADNS -> OK' -C* Retrieve and check some code/flag meaning strings. +C* Retrieve and check some code/flag meaning strings. CALL GETCFMNG + ( 11, 'PRC', 106, ' ', -1, cmeang1, lcmg1, ier1 ) @@ -71,12 +71,12 @@ + ( ier4 .eq. 0 ) .and. ( lcmg4 .eq. 20 ) .and. + ( cmeang4(1:lcmg4) .eq. + 'Stennis Space Center' ) ) THEN - print *, ' GETCFMNG -> OK' + print *, ' GETCFMNG -> OK' ELSE - print *, ' GETCFMNG -> FAILED!!' + print *, ' GETCFMNG -> FAILED!!' ENDIF - ENDIF + ENDIF - STOP - END + STOP + END diff --git a/test/test_IN_6.F b/test/test_IN_6.F index d3e6f08e..30c05e9c 100644 --- a/test/test_IN_6.F +++ b/test/test_IN_6.F @@ -7,25 +7,25 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 NMSUB + INTEGER*4 NMSUB #endif - CHARACTER cmgtag*8 + CHARACTER cmgtag*8 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_6' - print *, ' using UFBMEM, RDMEMM and UFBMNS' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_6' + print *, ' using UFBMEM, RDMEMM and UFBMNS' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - OPEN ( UNIT = 21, FILE = 'testfiles/IN_6_infile1', + OPEN ( UNIT = 21, FILE = 'testfiles/IN_6_infile1', + FORM = 'UNFORMATTED') - OPEN ( UNIT = 22, FILE = 'testfiles/IN_6_infile2', + OPEN ( UNIT = 22, FILE = 'testfiles/IN_6_infile2', + FORM = 'UNFORMATTED') CALL DATEBF ( 22, iyr, imon, iday, ihour, imgdt ) @@ -36,7 +36,7 @@ print *, ' DATEBF -> FAILED!!' END IF REWIND ( 22 ) - + C* Open the input files. CALL UFBMEM ( 21, 0, icnt1, iunt1 ) @@ -77,5 +77,5 @@ print *, ' NMSUB -> FAILED!!' END IF - STOP - END + STOP + END diff --git a/test/test_IN_7.F b/test/test_IN_7.F index e85d8811..496a5287 100644 --- a/test/test_IN_7.F +++ b/test/test_IN_7.F @@ -31,7 +31,7 @@ SUBROUTINE ERRWRT(str) CHARACTER*(*) str - INTEGER str_len + INTEGER str_len str_len = LEN(str) errstr ( errstr_len + 1 : errstr_len + str_len + 1 ) = str @@ -45,40 +45,40 @@ SUBROUTINE ERRWRT(str) USE Share_errstr #ifdef INTSIZE_8 - INTEGER*4 ISETPRM, IGETPRM, IREADNS + INTEGER*4 ISETPRM, IGETPRM, IREADNS #endif - PARAMETER ( MXR8PM = 15 ) - PARAMETER ( MXR8LV = 5 ) - - REAL*8 r8arr ( MXR8PM, MXR8LV ), r8val + PARAMETER ( MXR8PM = 15 ) + PARAMETER ( MXR8LV = 5 ) - CHARACTER cmgtag*8 + REAL*8 r8arr ( MXR8PM, MXR8LV ), r8val - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: reading IN_7' - print *, ' using 2-03-YYY changed reference values' - print *, ' using inline ERRWRT to check error messages' - print *, ' using UFBPOS, UFBTAB, and VALX' - print *, '----------------------------------------------------' + CHARACTER cmgtag*8 + + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: reading IN_7' + print *, ' using 2-03-YYY changed reference values' + print *, ' using inline ERRWRT to check error messages' + print *, ' using UFBPOS, UFBTAB, and VALX' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif iret1 = ISETPRM ( 'MXNRV', 5 ) errstr_len = 1 - iret2 = ISETPRM ( 'DUMMY', 20 ) + iret2 = ISETPRM ( 'DUMMY', 20 ) IF ( ( iret1 .eq. 0 ) .and. ( iret2 .eq. -1 ) .and. + ( INDEX( errstr(1:errstr_len), + 'ISETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) - + .ne. 0 ) ) THEN - print *, ' ISETPRM -> OK' - ELSE - print *, ' ISETPRM -> FAILED!!' + + .ne. 0 ) ) THEN + print *, ' ISETPRM -> OK' + ELSE + print *, ' ISETPRM -> FAILED!!' END IF - OPEN ( UNIT = 11, FILE = 'testfiles/IN_7', FORM ='UNFORMATTED') + OPEN ( UNIT = 11, FILE = 'testfiles/IN_7', FORM ='UNFORMATTED') OPEN ( UNIT = 12, FILE = 'testfiles/IN_7_bufrtab' ) CALL OPENBF ( 11, 'IN', 12 ) @@ -90,19 +90,19 @@ SUBROUTINE ERRWRT(str) IF ( ( iret1 .eq. 5 ) .and. ( iret2 .eq. -1 ) .and. + ( INDEX( errstr(1:errstr_len), + 'IGETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) - + .ne. 0 ) ) THEN - print *, ' IGETPRM -> OK' - ELSE - print *, ' IGETPRM -> FAILED!!' + + .ne. 0 ) ) THEN + print *, ' IGETPRM -> OK' + ELSE + print *, ' IGETPRM -> FAILED!!' END IF C> Read some data values from the 1st messaage, which uses the C> 2-03-YYY operator to change one of the reference values. IF ( IREADNS ( 11, cmgtag, imgdt ) .ne. 0 ) THEN - print *, ' IREADNS -> FAILED!!' + print *, ' IREADNS -> FAILED!!' ELSE - print *, ' IREADNS -> OK' + print *, ' IREADNS -> OK' CALL UFBREP ( 11, r8arr, MXR8PM, MXR8LV, nr8a, 'TIDER' ) errstr_len = 1 CALL UFBREP ( 11, r8val, 1, 1, nr8v, 'DUMMY' ) @@ -117,12 +117,12 @@ SUBROUTINE ERRWRT(str) + ( idx1 .gt. 0 ) .and. ( idx2 .gt. 0 ) .and. + ( NINT ( r8arr(1,1) ) .eq. -10000 ) .and. + ( NINT ( r8arr(1,2) ) .eq. 16 ) ) THEN - print *, ' UFBREP -> OK' + print *, ' UFBREP -> OK' ELSE - print *, ' UFBREP -> FAILED!!' + print *, ' UFBREP -> FAILED!!' END IF END IF - + C> Jump ahead to the 5th subset of the 23rd message and read C> some data values. @@ -144,13 +144,13 @@ SUBROUTINE ERRWRT(str) + ( NINT ( r8arr(2,1)*100000 ) .eq. -3785017 ) .and. + ( NINT ( r8arr(3,1)*100 ) .eq. 30035 ) .and. + ( NINT ( r8arr(4,1) ) .eq. 2187000 ) ) THEN - print *, ' UFBPOS -> OK' - print *, ' UFBINT -> OK' + print *, ' UFBPOS -> OK' + print *, ' UFBINT -> OK' ELSE - print *, ' UFBPOS -> FAILED!!' - print *, ' UFBINT -> FAILED!!' + print *, ' UFBPOS -> FAILED!!' + print *, ' UFBINT -> FAILED!!' END IF - + C> Jump ahead to the 2nd subset of the 30th message and read C> some data values. @@ -171,13 +171,13 @@ SUBROUTINE ERRWRT(str) + ( NINT ( r8arr(1,1)*100 ) .eq. 3163 ) .and. + ( NINT ( r8arr(2,1)*100 ) .eq. -11017 ) .and. + ( NINT ( r8arr(3,1) ) .eq. 1205 ) ) THEN - print *, ' UFBPOS -> OK' - print *, ' UFBSTP -> OK' + print *, ' UFBPOS -> OK' + print *, ' UFBSTP -> OK' ELSE - print *, ' UFBPOS -> FAILED!!' - print *, ' UFBSTP -> FAILED!!' + print *, ' UFBPOS -> FAILED!!' + print *, ' UFBSTP -> FAILED!!' END IF - + C> Jump backwards to the 88th subset of the 29th message and read C> some data values. @@ -198,20 +198,20 @@ SUBROUTINE ERRWRT(str) + ( NINT ( r8arr(6,1)*100000 ) .eq. 2967000 ) .and. + ( NINT ( r8arr(7,1)*100000 ) .eq. -9512833 ) .and. + ( NINT ( r8arr(5,1) ) .eq. 482011039 ) ) THEN - print *, ' UFBPOS -> OK' - print *, ' UFBSEQ -> OK' + print *, ' UFBPOS -> OK' + print *, ' UFBSEQ -> OK' ELSE - print *, ' UFBPOS -> FAILED!!' - print *, ' UFBSEQ -> FAILED!!' + print *, ' UFBPOS -> FAILED!!' + print *, ' UFBSEQ -> FAILED!!' END IF C> Rewind the file and get a total count of the subsets. CALL UFBTAB ( -11, r8val, 1, 1, nsub, ' ' ) IF ( ( nsub .eq. 402 ) .and. ( IBFMS ( r8val ) .eq. 1 ) ) THEN - print *, ' UFBTAB -> OK' + print *, ' UFBTAB -> OK' ELSE - print *, ' UFBTAB -> FAILED!!' + print *, ' UFBTAB -> FAILED!!' END IF C> Test the error handling inside of VALX. @@ -219,11 +219,11 @@ SUBROUTINE ERRWRT(str) errstr_len = 1 r8val = VALX ( '75.DUMMY' ) IF ( ( INDEX( errstr(1:errstr_len), - + 'VALX - ERROR READING STRING' ) .ne. 0 ) ) THEN - print *, ' VALX -> OK' - ELSE - print *, ' VALX -> FAILED!!' + + 'VALX - ERROR READING STRING' ) .ne. 0 ) ) THEN + print *, ' VALX -> OK' + ELSE + print *, ' VALX -> FAILED!!' END IF - STOP - END + STOP + END diff --git a/test/test_IN_8.F90 b/test/test_IN_8.F90 index ab6b76d1..b3f0431a 100644 --- a/test/test_IN_8.F90 +++ b/test/test_IN_8.F90 @@ -62,7 +62,7 @@ program test_IN_8 print *, ' UFBEVN -> FAILED!!' endif -! now, get all of the temperature data from this subset which meets the conditions of being on +! now, get all of the temperature data from this subset which meets the conditions of being on ! a level where the pressure is between 490mb and 44mb, and check some of those values call ufbevn ( 11, r8vals, MXR8PM, MXR8LV, MXR8EN, ilv, 'POB<490 POB>44 POB TOB TQM TPC TRC' ) diff --git a/test/test_OUT_1.F b/test/test_OUT_1.F index ada6d599..f277dca3 100644 --- a/test/test_OUT_1.F +++ b/test/test_OUT_1.F @@ -6,201 +6,201 @@ C C Jeff Ator - REAL*8 r8ymd ( 3, 1 ), - + r8ltl ( 2, 1 ), - + r8flv ( 1, 5 ), - + r8oth ( 10, 1 ) + REAL*8 r8ymd ( 3, 1 ), + + r8ltl ( 2, 1 ), + + r8flv ( 1, 5 ), + + r8oth ( 10, 1 ) #ifdef INTSIZE_8 - INTEGER*4 LCMGDF + INTEGER*4 LCMGDF #endif - INTEGER nsc(5), nrf(5), nbt(5), ierns(5) + INTEGER nsc(5), nrf(5), nbt(5), ierns(5) - CHARACTER acrn*10, libvrsn*8, tagpr*6 + CHARACTER acrn*10, libvrsn*8, tagpr*6 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_1' - print *, ' using OPENBF IO = ''OUT'' and LUNIN != LUNDX' - print *, ' using 2-03-YYY to change reference values' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_1' + print *, ' using OPENBF IO = ''OUT'' and LUNIN != LUNDX' + print *, ' using 2-03-YYY to change reference values' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - CALL BVERS ( libvrsn ) - IF ( LGT( libvrsn, '10.1.1' ) ) THEN -C* Specify the use of big-endian blocking. - print *, ' SETBLOCK' - CALL SETBLOCK (1) - ENDIF + CALL BVERS ( libvrsn ) + IF ( LGT( libvrsn, '10.1.1' ) ) THEN +C* Specify the use of big-endian blocking. + print *, ' SETBLOCK' + CALL SETBLOCK (1) + ENDIF -C* Open the BUFR table and output file. +C* Open the BUFR table and output file. - OPEN ( UNIT = 11, FILE = 'out1.bufr', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_1_bufrtab' ) + OPEN ( UNIT = 11, FILE = 'out1.bufr', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_1_bufrtab' ) - CALL OPENBF ( 11, 'OUT', 12 ) - print *, ' OPENBF' + CALL OPENBF ( 11, 'OUT', 12 ) + print *, ' OPENBF' -C* Write a standard, compressed BUFR message with 3 subsets. +C* Write a standard, compressed BUFR message with 3 subsets. C* Compression will be implemented using WRITCP. - CALL STDMSG ('Y') - print *, ' STDMSG' + CALL STDMSG ('Y') + print *, ' STDMSG' -C* First subset. +C* First subset. - CALL OPENMB ( 11, 'FR004029', 2012031212 ) - print *, ' OPENMB' + CALL OPENMB ( 11, 'FR004029', 2012031212 ) + print *, ' OPENMB' IF ( LCMGDF ( 11, 'FR004029' ) .eq. 1 ) THEN - print *, ' LCMGDF' + print *, ' LCMGDF' ELSE CALL BORT ( 'LCMGDF FAILURE!' ) - ENDIF + ENDIF - CALL GETTAGPR ( 11, 'MNTH', 1, tagpr, iertgp ) - IF ( ( iertgp .eq. 0 ) .and. ( tagpr .eq. 'YYMMDD' ) ) THEN - print *, ' GETTAGPR' + CALL GETTAGPR ( 11, 'MNTH', 1, tagpr, iertgp ) + IF ( ( iertgp .eq. 0 ) .and. ( tagpr .eq. 'YYMMDD' ) ) THEN + print *, ' GETTAGPR' ELSE CALL BORT ( 'GETTAGPR FAILURE!' ) - ENDIF - -C* The output of the following calls will be checked below, after -C* making additional calls to this same subroutine to verify -C* reference values that will be modified with the 2-03 operator. - - CALL NEMSPECS ( 11, 'ACRN', 1, nsa, nra, nba, iernsa ) - CALL NEMSPECS ( 11, 'MDEVG', 1, nsm, nrm, nbm, iernsm ) - - r8ymd(1,1) = 2012 - r8ymd(2,1) = 3 - r8ymd(3,1) = 12 - CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) - r8ltl(1,1) = -35.77 - r8ltl(2,1) = 172.38 - CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) - print *, ' UFBSEQ' - -C* The r8flv array tests the 2-03 operator. r8flv(1,2) contains -C* the new reference value, which is applied to the FLVLST values -C* in r8flv(1,3) and r8flv(1,4) when writing the message. - - r8flv(1,1) = 3500 - r8flv(1,2) = -1000 - r8flv(1,3) = 4000 - r8flv(1,4) = 5750 - r8flv(1,5) = 10722 - CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') - print *, ' UFBREP' - - r8oth(1,1) = 13 - r8oth(2,1) = 45 - r8oth(3,1) = 235.77 - r8oth(4,1) = 1 - r8oth(5,1) = 5.322 - r8oth(6,1) = 1 - r8oth(7,1) = 3 - r8oth(8,1) = 5 - r8oth(9,1) = 35 - r8oth(10,1) = 10.7 - CALL UFBINT ( 11, r8oth, 10, 1, nlv, - + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') - print *, ' UFBINT' - - CALL WRITCP ( 11 ) - print *, ' WRITCP' - -C* We need to run the following check after the call to WRITCP, -C* because new reference values aren't stored into a message (nor -C* applied when packing any other values within that message) until -C* WRITCP calls WRITSB, which in turn calls WRTREE, which in turn + ENDIF + +C* The output of the following calls will be checked below, after +C* making additional calls to this same subroutine to verify +C* reference values that will be modified with the 2-03 operator. + + CALL NEMSPECS ( 11, 'ACRN', 1, nsa, nra, nba, iernsa ) + CALL NEMSPECS ( 11, 'MDEVG', 1, nsm, nrm, nbm, iernsm ) + + r8ymd(1,1) = 2012 + r8ymd(2,1) = 3 + r8ymd(3,1) = 12 + CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) + r8ltl(1,1) = -35.77 + r8ltl(2,1) = 172.38 + CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) + print *, ' UFBSEQ' + +C* The r8flv array tests the 2-03 operator. r8flv(1,2) contains +C* the new reference value, which is applied to the FLVLST values +C* in r8flv(1,3) and r8flv(1,4) when writing the message. + + r8flv(1,1) = 3500 + r8flv(1,2) = -1000 + r8flv(1,3) = 4000 + r8flv(1,4) = 5750 + r8flv(1,5) = 10722 + CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') + print *, ' UFBREP' + + r8oth(1,1) = 13 + r8oth(2,1) = 45 + r8oth(3,1) = 235.77 + r8oth(4,1) = 1 + r8oth(5,1) = 5.322 + r8oth(6,1) = 1 + r8oth(7,1) = 3 + r8oth(8,1) = 5 + r8oth(9,1) = 35 + r8oth(10,1) = 10.7 + CALL UFBINT ( 11, r8oth, 10, 1, nlv, + + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') + print *, ' UFBINT' + + CALL WRITCP ( 11 ) + print *, ' WRITCP' + +C* We need to run the following check after the call to WRITCP, +C* because new reference values aren't stored into a message (nor +C* applied when packing any other values within that message) until +C* WRITCP calls WRITSB, which in turn calls WRTREE, which in turn C* calls IPKS. - DO jj = 1, 5 - CALL NEMSPECS ( 11, 'FLVLST', jj, nsc(jj), nrf(jj), - + nbt(jj), ierns(jj) ) - END DO - IF ( ( iernsa .eq. 0 ) .and. ( iernsm .eq. 0 ) .and. - + ( nba .eq. 80 ) .and. ( nbm .eq. 17 ) .and. - + ( nsm .eq. 3 ) .and. ( ierns(1) .eq. 0 ) .and. - + ( nrf(1) .eq. -1024 ) .and. ( ierns(2) .eq. 0 ) .and. - + ( nrf(2) .eq. -1024 ) .and. ( nbt(2) .eq. 12 ) .and. - + ( ierns(3) .eq. 0 ) .and. ( nrf(3) .eq. -1000 ) .and. - + ( ierns(4) .eq. 0 ) .and. ( nrf(4) .eq. -1000 ) .and. - + ( ierns(5) .eq. 0 ) .and. ( nrf(5) .eq. -1024 ) .and. - + ( nbt(3) .eq. 16 ) .and. ( nbt(5) .eq. 16 ) ) THEN - print *, ' NEMSPECS' + DO jj = 1, 5 + CALL NEMSPECS ( 11, 'FLVLST', jj, nsc(jj), nrf(jj), + + nbt(jj), ierns(jj) ) + END DO + IF ( ( iernsa .eq. 0 ) .and. ( iernsm .eq. 0 ) .and. + + ( nba .eq. 80 ) .and. ( nbm .eq. 17 ) .and. + + ( nsm .eq. 3 ) .and. ( ierns(1) .eq. 0 ) .and. + + ( nrf(1) .eq. -1024 ) .and. ( ierns(2) .eq. 0 ) .and. + + ( nrf(2) .eq. -1024 ) .and. ( nbt(2) .eq. 12 ) .and. + + ( ierns(3) .eq. 0 ) .and. ( nrf(3) .eq. -1000 ) .and. + + ( ierns(4) .eq. 0 ) .and. ( nrf(4) .eq. -1000 ) .and. + + ( ierns(5) .eq. 0 ) .and. ( nrf(5) .eq. -1024 ) .and. + + ( nbt(3) .eq. 16 ) .and. ( nbt(5) .eq. 16 ) ) THEN + print *, ' NEMSPECS' ELSE CALL BORT ( 'NEMSPECS FAILURE!' ) - END IF + END IF - acrn = 'TESTUPS008' - CALL WRITLC ( 11, acrn, 'ACRN' ) - print *, ' WRITLC' + acrn = 'TESTUPS008' + CALL WRITLC ( 11, acrn, 'ACRN' ) + print *, ' WRITLC' -C* Second subset. +C* Second subset. - CALL OPENMB ( 11, 'FR004029', 2012031212 ) + CALL OPENMB ( 11, 'FR004029', 2012031212 ) - CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) + CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) - r8ltl(2,1) = 172.42 - CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) + r8ltl(2,1) = 172.42 + CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) - r8flv(1,1) = 3600 - r8flv(1,4) = 5760 - r8flv(1,5) = 10730 - CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') + r8flv(1,1) = 3600 + r8flv(1,4) = 5760 + r8flv(1,5) = 10730 + CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') - r8oth(2,1) = 48 - r8oth(3,1) = 234.69 - r8oth(5,1) = 5.001 - r8oth(8,1) = 3 - r8oth(9,1) = 30 - r8oth(10,1) = 12.2 - CALL UFBINT ( 11, r8oth, 10, 1, nlv, - + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') + r8oth(2,1) = 48 + r8oth(3,1) = 234.69 + r8oth(5,1) = 5.001 + r8oth(8,1) = 3 + r8oth(9,1) = 30 + r8oth(10,1) = 12.2 + CALL UFBINT ( 11, r8oth, 10, 1, nlv, + + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') - CALL WRITCP ( 11 ) + CALL WRITCP ( 11 ) - acrn = 'TESTAAL225' - CALL WRITLC ( 11, acrn, 'ACRN' ) + acrn = 'TESTAAL225' + CALL WRITLC ( 11, acrn, 'ACRN' ) -C* Third subset. +C* Third subset. - CALL OPENMB ( 11, 'FR004029', 2012031212 ) + CALL OPENMB ( 11, 'FR004029', 2012031212 ) - CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) + CALL UFBSEQ ( 11, r8ymd, 3, 1, nlv, 'YYMMDD' ) - r8ltl(2,1) = 172.44 - CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) + r8ltl(2,1) = 172.44 + CALL UFBSEQ ( 11, r8ltl, 2, 1, nlv, 'LTLONH' ) - r8flv(1,1) = 3610 - r8flv(1,2) = -1200 - r8flv(1,4) = 5775 - r8flv(1,5) = 10730 - CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') + r8flv(1,1) = 3610 + r8flv(1,2) = -1200 + r8flv(1,4) = 5775 + r8flv(1,5) = 10730 + CALL UFBREP ( 11, r8flv, 1, 5, nlv, 'FLVLST') - r8oth(2,1) = 51 - r8oth(3,1) = 234.11 - r8oth(5,1) = 5.012 - r8oth(8,1) = 6 - r8oth(10,1) = 12.1 - CALL UFBINT ( 11, r8oth, 10, 1, nlv, - + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') + r8oth(2,1) = 51 + r8oth(3,1) = 234.11 + r8oth(5,1) = 5.012 + r8oth(8,1) = 6 + r8oth(10,1) = 12.1 + CALL UFBINT ( 11, r8oth, 10, 1, nlv, + + 'HOUR MINU TMDB DGOT MDEVG ROLQ INTV DPOF WDIR WSPD') - CALL WRITCP ( 11 ) + CALL WRITCP ( 11 ) - acrn = 'TESTSWA193' - CALL WRITLC ( 11, acrn, 'ACRN' ) + acrn = 'TESTSWA193' + CALL WRITLC ( 11, acrn, 'ACRN' ) - CALL CLOSBF ( 11 ) - print *, ' CLOSBF' + CALL CLOSBF ( 11 ) + print *, ' CLOSBF' - STOP - END + STOP + END diff --git a/test/test_OUT_2.F b/test/test_OUT_2.F index 4f07a2dc..39bdcaea 100644 --- a/test/test_OUT_2.F +++ b/test/test_OUT_2.F @@ -7,128 +7,128 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IGETSC + INTEGER*4 IGETSC #endif - REAL*8 r8ymd ( 3, 1 ), - + r8ltl ( 2, 1 ), - + r8oth ( 10, 1 ) + REAL*8 r8ymd ( 3, 1 ), + + r8ltl ( 2, 1 ), + + r8oth ( 10, 1 ) - CHARACTER libvrsn*8 + CHARACTER libvrsn*8 - REAL*8 rpid, PKFTBV, xmiss, GETBMISS - CHARACTER cpid*8 - EQUIVALENCE (rpid,cpid) + REAL*8 rpid, PKFTBV, xmiss, GETBMISS + CHARACTER cpid*8 + EQUIVALENCE (rpid,cpid) C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_2' - print *, ' using OPENBF IO = ''APX'' and embedded tables' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_2' + print *, ' using OPENBF IO = ''APX'' and embedded tables' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - CALL BVERS ( libvrsn ) - print *, ' BVERS' - IF ( LGT( libvrsn, '10.1.1' ) ) THEN -C* Specify the use of big-endian blocking. - CALL SETBLOCK (1) - print *, ' SETBLOCK' -C* Modify the "missing" value. - xmiss = 9999. - CALL SETBMISS (xmiss) - print *, ' SETBMISS' - ENDIF + CALL BVERS ( libvrsn ) + print *, ' BVERS' + IF ( LGT( libvrsn, '10.1.1' ) ) THEN +C* Specify the use of big-endian blocking. + CALL SETBLOCK (1) + print *, ' SETBLOCK' +C* Modify the "missing" value. + xmiss = 9999. + CALL SETBMISS (xmiss) + print *, ' SETBMISS' + ENDIF -C* Open the BUFR table and output file. +C* Open the BUFR table and output file. - OPEN ( UNIT = 11, FILE = 'out2.bufr', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_2_bufrtab' ) + OPEN ( UNIT = 11, FILE = 'out2.bufr', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_2_bufrtab' ) - CALL OPENBF ( 11, 'APX', 12 ) - print *, ' OPENBF' + CALL OPENBF ( 11, 'APX', 12 ) + print *, ' OPENBF' - IF ( IGETSC ( 11 ) .eq. 0 ) THEN - print *, ' IGETSC' + IF ( IGETSC ( 11 ) .eq. 0 ) THEN + print *, ' IGETSC' ELSE CALL BORT ( 'IGETSC FAILURE!' ) - ENDIF + ENDIF - CALL PKVS01 ( 'OGCE', 160 ) - print *, ' PKVS01' + CALL PKVS01 ( 'OGCE', 160 ) + print *, ' PKVS01' -C* Write an edition 4 BUFR message with 2 subsets. +C* Write an edition 4 BUFR message with 2 subsets. - CALL PKVS01 ( 'BEN', 4 ) - print *, ' CNVED4' + CALL PKVS01 ( 'BEN', 4 ) + print *, ' CNVED4' -C* First subset. +C* First subset. - CALL OPENMB ( 11, 'NC031112', 2012101712 ) - print *, ' OPENMB' + CALL OPENMB ( 11, 'NC031112', 2012101712 ) + print *, ' OPENMB' - CALL NEMSPECS ( 11, 'TMBRST', 1, nsc, nrf, nbt, ierns ) - IF ( ( ierns .eq. 0 ) .and. - + ( nsc .eq. 3 ) .and. ( nbt .eq. 19 ) ) THEN - print *, ' NEMSPECS' + CALL NEMSPECS ( 11, 'TMBRST', 1, nsc, nrf, nbt, ierns ) + IF ( ( ierns .eq. 0 ) .and. + + ( nsc .eq. 3 ) .and. ( nbt .eq. 19 ) ) THEN + print *, ' NEMSPECS' ELSE CALL BORT ( 'NEMSPECS FAILURE!' ) - END IF - - r8ymd(1,1) = 2012 - r8ymd(2,1) = 10 - r8ymd(3,1) = 17 - CALL UFBINT ( 11, r8ymd, 3, 1, nlv, 'YEAR MNTH DAYS' ) - r8ltl(1,1) = -22.67 - r8ltl(2,1) = 72.02 - CALL UFBINT ( 11, r8ltl, 2, 1, nlv, 'CLATH CLONH' ) - - r8oth(1,1) = 13 - r8oth(2,1) = 45 - r8oth(3,1) = 216.744 - r8oth(4,1) = 85 - r8oth(5,1) = 110 - r8oth(6,1) = 17 - r8oth(7,1) = PKFTBV(12,3) + PKFTBV(12,9) - print *, ' PKFTBV' - r8oth(8,1) = -0.661527 - CALL UFBINT ( 11, r8oth, 10, 1, nlv, - + 'HOUR MINU TMBRST SAID SACYLN ORBN OBQL SLHD1') - print *, ' UFBINT' - - CALL WRITSB ( 11 ) - print *, ' WRITSB' - -C* Second subset. - - CALL OPENMB ( 11, 'NC031112', 2012101712 ) - - CALL UFBINT ( 11, r8ymd, 3, 1, nlv, 'YEAR MNTH DAYS' ) - r8ltl(2,1) = 72.13 - CALL UFBINT ( 11, r8ltl, 2, 1, nlv, 'CLATH CLONH' ) - - r8oth(2,1) = 48 - r8oth(3,1) = 214.003 - r8oth(8,1) = 0.002582 - CALL UFBINT ( 11, r8oth, 10, 1, nlv, - + 'HOUR MINU TMBRST SAID SACYLN ORBN OBQL SLHD1') - - cpid = 'SUBSET#2' - CALL UFBINT ( 11, rpid, 1, 1, nlv, 'RPID' ) - - IF ( NINT(xmiss) .eq. NINT(GETBMISS()) ) THEN - print *, ' GETBMISS' + END IF + + r8ymd(1,1) = 2012 + r8ymd(2,1) = 10 + r8ymd(3,1) = 17 + CALL UFBINT ( 11, r8ymd, 3, 1, nlv, 'YEAR MNTH DAYS' ) + r8ltl(1,1) = -22.67 + r8ltl(2,1) = 72.02 + CALL UFBINT ( 11, r8ltl, 2, 1, nlv, 'CLATH CLONH' ) + + r8oth(1,1) = 13 + r8oth(2,1) = 45 + r8oth(3,1) = 216.744 + r8oth(4,1) = 85 + r8oth(5,1) = 110 + r8oth(6,1) = 17 + r8oth(7,1) = PKFTBV(12,3) + PKFTBV(12,9) + print *, ' PKFTBV' + r8oth(8,1) = -0.661527 + CALL UFBINT ( 11, r8oth, 10, 1, nlv, + + 'HOUR MINU TMBRST SAID SACYLN ORBN OBQL SLHD1') + print *, ' UFBINT' + + CALL WRITSB ( 11 ) + print *, ' WRITSB' + +C* Second subset. + + CALL OPENMB ( 11, 'NC031112', 2012101712 ) + + CALL UFBINT ( 11, r8ymd, 3, 1, nlv, 'YEAR MNTH DAYS' ) + r8ltl(2,1) = 72.13 + CALL UFBINT ( 11, r8ltl, 2, 1, nlv, 'CLATH CLONH' ) + + r8oth(2,1) = 48 + r8oth(3,1) = 214.003 + r8oth(8,1) = 0.002582 + CALL UFBINT ( 11, r8oth, 10, 1, nlv, + + 'HOUR MINU TMBRST SAID SACYLN ORBN OBQL SLHD1') + + cpid = 'SUBSET#2' + CALL UFBINT ( 11, rpid, 1, 1, nlv, 'RPID' ) + + IF ( NINT(xmiss) .eq. NINT(GETBMISS()) ) THEN + print *, ' GETBMISS' ELSE CALL BORT ( 'GETBMISS FAILURE!' ) - ENDIF + ENDIF - CALL WRITSB ( 11 ) + CALL WRITSB ( 11 ) - CALL CLOSBF ( 11 ) - print *, ' CLOSBF' + CALL CLOSBF ( 11 ) + print *, ' CLOSBF' - STOP - END + STOP + END diff --git a/test/test_OUT_3.F b/test/test_OUT_3.F index 187fa981..02f72f36 100644 --- a/test/test_OUT_3.F +++ b/test/test_OUT_3.F @@ -7,202 +7,202 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 ISETPRM, IGETPRM + INTEGER*4 ISETPRM, IGETPRM #endif - REAL*8 r8vals ( 11, 4 ), r8bitmap ( 26 ) + REAL*8 r8vals ( 11, 4 ), r8bitmap ( 26 ) C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_3' - print *, ' using dynamic allocation' - print *, ' using EXITBUFR with multiple allocations' - print *, ' using 2-22, 2-36 and 2-37 operators' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_3' + print *, ' using dynamic allocation' + print *, ' using EXITBUFR with multiple allocations' + print *, ' using 2-22, 2-36 and 2-37 operators' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* First message. +C* First message. - IF ( ( ISETPRM ( 'NFILES', 2 ) .eq. 0 ) .and. + IF ( ( ISETPRM ( 'NFILES', 2 ) .eq. 0 ) .and. + ( ISETPRM ( 'MXMSGL', 8000 ) .eq. 0 ) ) THEN - print *, ' ISETPRM' - ELSE - CALL BORT ( 'ISETPRM FAILURE!' ) - END IF + print *, ' ISETPRM' + ELSE + CALL BORT ( 'ISETPRM FAILURE!' ) + END IF - CALL PKVS01 ( 'MTV', 18 ) - CALL PKVS01 ( 'USN', 2 ) - print *, ' PKVS01' + CALL PKVS01 ( 'MTV', 18 ) + CALL PKVS01 ( 'USN', 2 ) + print *, ' PKVS01' -C* Open the BUFR table and output file. +C* Open the BUFR table and output file. - OPEN ( UNIT = 11, FILE = 'out3.bufr', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_3_bufrtab' ) + OPEN ( UNIT = 11, FILE = 'out3.bufr', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_3_bufrtab' ) - CALL OPENBF ( 11, 'OUT', 12 ) - print *, ' OPENBF' + CALL OPENBF ( 11, 'OUT', 12 ) + print *, ' OPENBF' - IF ( ( IGETPRM ( 'NFILES' ) .eq. 2 ) .and. + IF ( ( IGETPRM ( 'NFILES' ) .eq. 2 ) .and. + ( IGETPRM ( 'MXMSGL' ) .eq. 8000 ) ) THEN - print *, ' IGETPRM' - ELSE - CALL BORT ( 'IGETPRM FAILURE!' ) - END IF - -C* Write a standard message. - - CALL STDMSG ('Y') - print *, ' STDMSG' - -C* Store the data values. - - CALL OPENMB ( 11, 'FN005000', 2015030212 ) - print *, ' OPENMB' - - r8vals(1,1) = 2015 - r8vals(2,1) = 3 - r8vals(3,1) = 2 - r8vals(4,1) = 12 - r8vals(5,1) = 57 - r8vals(6,1) = -12.538 - r8vals(7,1) = 157.66 - r8vals(8,1) = 20170. - r8vals(9,1) = 37. - r8vals(10,1) = 2.1 - r8vals(11,1) = 244.5 - CALL UFBINT ( 11, r8vals, 11, 1, nlv, - + 'YEAR MNTH DAYS HOUR MINU CLATH CLONH PRLC WDIR WSPD CCST' ) - print *, ' UFBINT' - - DO ii = 1, 26 - r8bitmap(ii) = 0. - END DO - r8bitmap(16) = 1. - r8bitmap(17) = 1. - r8bitmap(18) = 1. - r8bitmap(21) = 1. - CALL UFBREP ( 11, r8bitmap, 1, 26, nlv, 'DPRI' ) - - r8vals(1,1) = 7. - r8vals(2,1) = 51. - r8vals(1,2) = 254. - r8vals(2,2) = 1. - r8vals(1,3) = 254. - r8vals(2,3) = 3. - CALL UFBREP ( 11, r8vals, 11, 3, nlv, 'GCLONG GNAP' ) - - r8vals(1,1) = 97. - r8vals(1,2) = 96. - r8vals(1,3) = 93. - r8vals(1,4) = 93. - CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'PCCF' ) - - r8vals(1,1) = 77. - r8vals(1,2) = 84. - r8vals(1,3) = 83. - r8vals(1,4) = 61. - CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'NCTH' ) - print *, ' UFBREP' - - CALL WRITSB ( 11 ) - print *, ' WRITSB' - - CALL EXITBUFR - print *, ' EXITBUFR' - -C* Second message. - - IF ( ( ISETPRM ( 'NFILES', 5 ) .eq. 0 ) .and. + print *, ' IGETPRM' + ELSE + CALL BORT ( 'IGETPRM FAILURE!' ) + END IF + +C* Write a standard message. + + CALL STDMSG ('Y') + print *, ' STDMSG' + +C* Store the data values. + + CALL OPENMB ( 11, 'FN005000', 2015030212 ) + print *, ' OPENMB' + + r8vals(1,1) = 2015 + r8vals(2,1) = 3 + r8vals(3,1) = 2 + r8vals(4,1) = 12 + r8vals(5,1) = 57 + r8vals(6,1) = -12.538 + r8vals(7,1) = 157.66 + r8vals(8,1) = 20170. + r8vals(9,1) = 37. + r8vals(10,1) = 2.1 + r8vals(11,1) = 244.5 + CALL UFBINT ( 11, r8vals, 11, 1, nlv, + + 'YEAR MNTH DAYS HOUR MINU CLATH CLONH PRLC WDIR WSPD CCST' ) + print *, ' UFBINT' + + DO ii = 1, 26 + r8bitmap(ii) = 0. + END DO + r8bitmap(16) = 1. + r8bitmap(17) = 1. + r8bitmap(18) = 1. + r8bitmap(21) = 1. + CALL UFBREP ( 11, r8bitmap, 1, 26, nlv, 'DPRI' ) + + r8vals(1,1) = 7. + r8vals(2,1) = 51. + r8vals(1,2) = 254. + r8vals(2,2) = 1. + r8vals(1,3) = 254. + r8vals(2,3) = 3. + CALL UFBREP ( 11, r8vals, 11, 3, nlv, 'GCLONG GNAP' ) + + r8vals(1,1) = 97. + r8vals(1,2) = 96. + r8vals(1,3) = 93. + r8vals(1,4) = 93. + CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'PCCF' ) + + r8vals(1,1) = 77. + r8vals(1,2) = 84. + r8vals(1,3) = 83. + r8vals(1,4) = 61. + CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'NCTH' ) + print *, ' UFBREP' + + CALL WRITSB ( 11 ) + print *, ' WRITSB' + + CALL EXITBUFR + print *, ' EXITBUFR' + +C* Second message. + + IF ( ( ISETPRM ( 'NFILES', 5 ) .eq. 0 ) .and. + ( ISETPRM ( 'MXMSGL', 12000 ) .eq. 0 ) ) THEN - print *, ' ISETPRM' - ELSE - CALL BORT ( 'ISETPRM FAILURE!' ) - END IF + print *, ' ISETPRM' + ELSE + CALL BORT ( 'ISETPRM FAILURE!' ) + END IF - CALL PKVS01 ( 'BEN', 4 ) - CALL PKVS01 ( 'MSBTI', 40 ) - CALL PKVS01 ( 'MTV', 17 ) - print *, ' PKVS01' + CALL PKVS01 ( 'BEN', 4 ) + CALL PKVS01 ( 'MSBTI', 40 ) + CALL PKVS01 ( 'MTV', 17 ) + print *, ' PKVS01' -C* Open the BUFR table and output file. +C* Open the BUFR table and output file. - OPEN ( UNIT = 11, FILE = 'out3.bufr', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_3_bufrtab' ) + OPEN ( UNIT = 11, FILE = 'out3.bufr', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_3_bufrtab' ) - CALL OPENBF ( 11, 'APX', 12 ) - print *, ' OPENBF' + CALL OPENBF ( 11, 'APX', 12 ) + print *, ' OPENBF' - IF ( ( IGETPRM ( 'NFILES' ) .eq. 5 ) .and. + IF ( ( IGETPRM ( 'NFILES' ) .eq. 5 ) .and. + ( IGETPRM ( 'MXMSGL' ) .eq. 12000 ) ) THEN - print *, ' IGETPRM' + print *, ' IGETPRM' ELSE CALL BORT ( 'IGETPRM FAILURE!' ) - END IF - -C* Write a standard message. - - CALL STDMSG ('Y') - print *, ' STDMSG' - -C* Store the data values. - - CALL OPENMB ( 11, 'FN005010', 2015030215 ) - print *, ' OPENMB' - - r8vals(1,1) = 2015 - r8vals(2,1) = 3 - r8vals(3,1) = 2 - r8vals(4,1) = 15 - r8vals(5,1) = 44 - r8vals(6,1) = -12.538 - r8vals(7,1) = 157.66 - r8vals(8,1) = 19930. - r8vals(9,1) = 305. - r8vals(10,1) = 12.5 - r8vals(11,1) = 233.0 - CALL UFBINT ( 11, r8vals, 11, 1, nlv, - + 'YEAR MNTH DAYS HOUR MINU CLATH CLONH PRLC WDIR WSPD CCST' ) - print *, ' UFBINT' - - DO ii = 1, 26 - r8bitmap(ii) = 0. - END DO - r8bitmap(16) = 1. - r8bitmap(17) = 1. - r8bitmap(18) = 1. - r8bitmap(26) = 1. - CALL UFBREP ( 11, r8bitmap, 1, 26, nlv, 'DPRI' ) - - r8vals(1,1) = 7. - r8vals(2,1) = 51. - r8vals(1,2) = 254. - r8vals(2,2) = 1. - r8vals(1,3) = 254. - r8vals(2,3) = 3. - CALL UFBREP ( 11, r8vals, 11, 3, nlv, 'GCLONG GNAP' ) - - r8vals(1,1) = 92. - r8vals(1,2) = 91. - r8vals(1,3) = 91. - r8vals(1,4) = 98. - CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'PCCF' ) - - r8vals(1,1) = 3. - r8vals(1,2) = 4. - r8vals(1,3) = 4. - r8vals(1,4) = 3. - CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'MAQC' ) - print *, ' UFBREP' - - CALL WRITSB ( 11 ) - print *, ' WRITSB' - - CALL CLOSBF ( 11 ) - print *, ' CLOSBF' - - STOP - END + END IF + +C* Write a standard message. + + CALL STDMSG ('Y') + print *, ' STDMSG' + +C* Store the data values. + + CALL OPENMB ( 11, 'FN005010', 2015030215 ) + print *, ' OPENMB' + + r8vals(1,1) = 2015 + r8vals(2,1) = 3 + r8vals(3,1) = 2 + r8vals(4,1) = 15 + r8vals(5,1) = 44 + r8vals(6,1) = -12.538 + r8vals(7,1) = 157.66 + r8vals(8,1) = 19930. + r8vals(9,1) = 305. + r8vals(10,1) = 12.5 + r8vals(11,1) = 233.0 + CALL UFBINT ( 11, r8vals, 11, 1, nlv, + + 'YEAR MNTH DAYS HOUR MINU CLATH CLONH PRLC WDIR WSPD CCST' ) + print *, ' UFBINT' + + DO ii = 1, 26 + r8bitmap(ii) = 0. + END DO + r8bitmap(16) = 1. + r8bitmap(17) = 1. + r8bitmap(18) = 1. + r8bitmap(26) = 1. + CALL UFBREP ( 11, r8bitmap, 1, 26, nlv, 'DPRI' ) + + r8vals(1,1) = 7. + r8vals(2,1) = 51. + r8vals(1,2) = 254. + r8vals(2,2) = 1. + r8vals(1,3) = 254. + r8vals(2,3) = 3. + CALL UFBREP ( 11, r8vals, 11, 3, nlv, 'GCLONG GNAP' ) + + r8vals(1,1) = 92. + r8vals(1,2) = 91. + r8vals(1,3) = 91. + r8vals(1,4) = 98. + CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'PCCF' ) + + r8vals(1,1) = 3. + r8vals(1,2) = 4. + r8vals(1,3) = 4. + r8vals(1,4) = 3. + CALL UFBREP ( 11, r8vals, 11, 4, nlv, 'MAQC' ) + print *, ' UFBREP' + + CALL WRITSB ( 11 ) + print *, ' WRITSB' + + CALL CLOSBF ( 11 ) + print *, ' CLOSBF' + + STOP + END diff --git a/test/test_OUT_4.F b/test/test_OUT_4.F index 1e3d5543..b49a0bff 100644 --- a/test/test_OUT_4.F +++ b/test/test_OUT_4.F @@ -7,65 +7,65 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 ISETPRM, IREADSB, IGETMXBY, ICBFMS + INTEGER*4 ISETPRM, IREADSB, IGETMXBY, ICBFMS #endif PARAMETER ( MXVAL1 = 200 ) PARAMETER ( MXVAL2 = 12 ) PARAMETER ( MXLVL = 4490 ) - REAL*8 r8arr1 ( MXVAL1 ), r8arr2 ( MXVAL2, MXLVL ) + REAL*8 r8arr1 ( MXVAL1 ), r8arr2 ( MXVAL2, MXLVL ) PARAMETER ( MXBFMG = 50000 ) INTEGER mgbf ( MXBFMG ) - CHARACTER cmgtag*8, smid*9, dummystr*9 + CHARACTER cmgtag*8, smid*9, dummystr*9 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_4' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_4' print *, ' using dynamic allocation' - print *, ' using OPENBF IO = ''NODX'' and IO = ''QUIET''' - print *, ' using STRCPT, WRDXTB and WRITSA' - print *, '----------------------------------------------------' + print *, ' using OPENBF IO = ''NODX'' and IO = ''QUIET''' + print *, ' using STRCPT, WRDXTB and WRITSA' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif - IF ( ( ISETPRM ( 'NFILES', 4 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MXMSGL', 400000 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MAXSS', 250000 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MAXMEM', 100000 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MAXMSG', 100 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MXDXTS', 5 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MXCDV', 100 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MXCSB', 100 ) .eq. 0 ) .and. - + ( ISETPRM ( 'MXLCC', 8 ) .eq. 0 ) ) THEN - print *, ' ISETPRM' - ELSE - CALL BORT ( 'ISETPRM FAILURE!' ) - END IF - -C* Open the BUFR input and output files. - - OPEN ( UNIT = 11, FILE = 'testfiles/OUT_4_infile1' ) - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_4_infile2' ) - OPEN ( UNIT = 13, FILE = 'out4.bufr', FORM ='UNFORMATTED' ) - - CALL OPENBF ( 11, 'IN', 11 ) - CALL OPENBF ( 12, 'SEC3', 12 ) - CALL OPENBF ( 13, 'NODX', 11 ) - CALL OPENBF ( 13, 'QUIET', -1 ) - print *, ' OPENBF' + IF ( ( ISETPRM ( 'NFILES', 4 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MXMSGL', 400000 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MAXSS', 250000 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MAXMEM', 100000 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MAXMSG', 100 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MXDXTS', 5 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MXCDV', 100 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MXCSB', 100 ) .eq. 0 ) .and. + + ( ISETPRM ( 'MXLCC', 8 ) .eq. 0 ) ) THEN + print *, ' ISETPRM' + ELSE + CALL BORT ( 'ISETPRM FAILURE!' ) + END IF + +C* Open the BUFR input and output files. + + OPEN ( UNIT = 11, FILE = 'testfiles/OUT_4_infile1' ) + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_4_infile2' ) + OPEN ( UNIT = 13, FILE = 'out4.bufr', FORM ='UNFORMATTED' ) + + CALL OPENBF ( 11, 'IN', 11 ) + CALL OPENBF ( 12, 'SEC3', 12 ) + CALL OPENBF ( 13, 'NODX', 11 ) + CALL OPENBF ( 13, 'QUIET', -1 ) + print *, ' OPENBF' CALL MTINFO ( '../tables', 90, 91 ) - print *, ' MTINFO' + print *, ' MTINFO' CALL MAXOUT ( MXBFMG*4 ) - print *, ' MAXOUT' + print *, ' MAXOUT' IF ( IGETMXBY ( ) .eq. MXBFMG*4 ) THEN print *, ' IGETMXBY' @@ -81,10 +81,10 @@ C* Append a (tank) receipt time to Section 1 of each output message - CALL STRCPT ( 'Y', 2020, 11, 4, 15, 29 ) - print *, ' STRCPT' + CALL STRCPT ( 'Y', 2020, 11, 4, 15, 29 ) + print *, ' STRCPT' -C* Process 1 message with 1 subset from infile1. +C* Process 1 message with 1 subset from infile1. CALL READMG ( 11, cmgtag, imgdt, iermg ) @@ -103,21 +103,21 @@ ELSE print *, ' READSB' - CALL OPENMB ( 13, 'NC007000', 2020022514 ) - print *, ' OPENMB' + CALL OPENMB ( 13, 'NC007000', 2020022514 ) + print *, ' OPENMB' CALL UFBSEQ ( 11, r8arr1, MXVAL1, 1, nlv, 'NC007000' ) CALL UFBSEQ ( 13, r8arr1, MXVAL1, 1, nlv, 'NC007000' ) - print *, ' UFBSEQ' + print *, ' UFBSEQ' CALL WRITSB ( 13 ) END IF END IF - CALL CLOSMG ( 13 ) - print *, ' CLOSMG' + CALL CLOSMG ( 13 ) + print *, ' CLOSMG' -C* Process 1 message with 4 subset from infile2. +C* Process 1 message with 4 subset from infile2. CALL READMG ( 12, cmgtag, imgdt, iermg ) @@ -129,7 +129,7 @@ C* output file. CALL WRDXTB ( 12, 13 ) - print *, ' WRDXTB' + print *, ' WRDXTB' IF ( iermg .ne. 0 ) THEN @@ -187,5 +187,5 @@ CALL CLOSBF ( 13 ) print *, ' CLOSBF' - STOP - END + STOP + END diff --git a/test/test_OUT_5.F b/test/test_OUT_5.F index 4db7e555..13c8236b 100644 --- a/test/test_OUT_5.F +++ b/test/test_OUT_5.F @@ -7,28 +7,28 @@ C Jeff Ator #ifdef INTSIZE_8 - INTEGER*4 IREADNS + INTEGER*4 IREADNS #endif INTEGER jdate(5), jdump(5) - CHARACTER cmgtag*8, tabdb(1000)*128 + CHARACTER cmgtag*8, tabdb(1000)*128 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_5' - print *, ' using DUMPBF and GETABDB' - print *, ' using UFDUMP, UFBDMP and DXDUMP' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_5' + print *, ' using DUMPBF and GETABDB' + print *, ' using UFDUMP, UFBDMP and DXDUMP' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* Open the output log (ASCII) file. +C* Open the output log (ASCII) file. - OPEN ( UNIT = 13, FILE = 'out5.bufr' ) + OPEN ( UNIT = 13, FILE = 'out5.bufr' ) C* Make a "FIRST" call to subroutine OPENBF to dynamically C* allocate internal arrays, in case this code is being run to @@ -38,19 +38,19 @@ CALL OPENBF ( 13, 'FIRST', 13 ) -C* Open the input (BUFR) file. Note that since we're about to +C* Open the input (BUFR) file. Note that since we're about to C* call subroutine DUMPBF for this file, then we don't need to C* first call subroutine OPENBF for this file, because subroutine C* DUMPBF will do that internally. - OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' ) + OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' ) CALL DATELEN ( 10 ) - print *, ' DATELEN' + print *, ' DATELEN' WRITE ( 13, FMT = '(///,A)' ) '------------ DUMPBF ------------' CALL DUMPBF ( 11, jdate, jdump ) - print *, ' DUMPBF' + print *, ' DUMPBF' WRITE ( 13, FMT = '(A,5I5)' ) 'jdate =', (jdate(ii), ii=1,5) WRITE ( 13, FMT = '(A,5I5)' ) 'jdump =', (jdump(ii), ii=1,5) @@ -59,13 +59,13 @@ C* internal Fortran CLOSE on the logical unit number), so we now C* need to reopen the file with a new call to subroutine OPENBF. - OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' ) + OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' ) CALL OPENBF ( 11, 'IN', 11 ) - print *, ' OPENBF' + print *, ' OPENBF' WRITE ( 13, FMT = '(///,A)' ) '------------ GETABDB -----------' CALL GETABDB ( 11, tabdb, 1000, jtab ) - print *, ' GETABDB' + print *, ' GETABDB' DO ii = 1, jtab WRITE ( 13, FMT = '(A,I4,2A)' ) + 'tabdb entry #', ii, ":", tabdb(ii) @@ -73,11 +73,11 @@ WRITE ( 13, FMT = '(///,A,/)' ) '----------- DXDUMP -----------' CALL DXDUMP ( 11, 13 ) - print *, ' DXDUMP' - - print *, ' IREADNS' - print *, ' UFDUMP' - print *, ' UFBDMP' + print *, ' DXDUMP' + + print *, ' IREADNS' + print *, ' UFDUMP' + print *, ' UFBDMP' nsub = 0 DO WHILE ( IREADNS ( 11, cmgtag, imgdt ) .eq. 0 ) nsub = nsub + 1 diff --git a/test/test_OUT_6.F b/test/test_OUT_6.F index df0b9a86..369fc681 100644 --- a/test/test_OUT_6.F +++ b/test/test_OUT_6.F @@ -6,48 +6,48 @@ C C Jeff Ator - REAL*8 r8f5fc ( 8, 5 ), r8dbss ( 4, 3 ), + REAL*8 r8f5fc ( 8, 5 ), r8dbss ( 4, 3 ), + r8wind ( 2, 1 ), r8val - CHARACTER ptidc*16 + CHARACTER ptidc*16 C*---------------------------------------------------------------------- - print *, '----------------------------------------------------' - print *, 'testing BUFRLIB: writing OUT_6' - print *, ' using OPENMG and UFBSTP' - print *, ' storing integer values larger than 32 bits' - print *, '----------------------------------------------------' + print *, '----------------------------------------------------' + print *, 'testing BUFRLIB: writing OUT_6' + print *, ' using OPENMG and UFBSTP' + print *, ' storing integer values larger than 32 bits' + print *, '----------------------------------------------------' #ifdef INTSIZE_8 - CALL SETIM8B ( .true. ) + CALL SETIM8B ( .true. ) #endif -C* Open the BUFR table and output file. +C* Open the BUFR table and output file. - OPEN ( UNIT = 11, FILE = 'out6.bufr', FORM ='UNFORMATTED') - OPEN ( UNIT = 12, FILE = 'testfiles/OUT_6_bufrtab' ) + OPEN ( UNIT = 11, FILE = 'out6.bufr', FORM ='UNFORMATTED') + OPEN ( UNIT = 12, FILE = 'testfiles/OUT_6_bufrtab' ) - CALL OPENBF ( 11, 'OUT', 12 ) - print *, ' OPENBF' + CALL OPENBF ( 11, 'OUT', 12 ) + print *, ' OPENBF' - CALL OPENMG ( 11, 'F5FCMESG', 2021022312 ) - print *, ' OPENMG' + CALL OPENMG ( 11, 'F5FCMESG', 2021022312 ) + print *, ' OPENMG' CALL MINIMG ( 11, 55 ) - print *, ' MINIMG' - + print *, ' MINIMG' + C* Store the subset data. r8wind ( 1, 1 ) = 290. r8wind ( 2, 1 ) = 6.5 - print *, ' UFBINT' - CALL UFBINT ( 11, r8wind, 2, 1, nlv, 'WDIR WSPD' ) - + print *, ' UFBINT' + CALL UFBINT ( 11, r8wind, 2, 1, nlv, 'WDIR WSPD' ) + r8val = 17. CALL SETVALNB ( 11, 'WDIR', 1, 'HOUR', 1, r8val, iersvb ) r8val = 16. CALL SETVALNB ( 11, 'TMDB', 1, 'HOUR', -1, r8val, iersvb ) - print *, ' SETVALNB' + print *, ' SETVALNB' r8dbss ( 1, 1 ) = 1.0 r8dbss ( 2, 1 ) = 34.1 @@ -61,11 +61,11 @@ r8dbss ( 2, 3 ) = 34.2 r8dbss ( 3, 3 ) = 284.6 r8dbss ( 4, 3 ) = 5.0644 - CALL UFBSTP ( 11, r8dbss, 4, 3, nlv, 'DBSS SALN SST1 WCON' ) - print *, ' UFBSTP' + CALL UFBSTP ( 11, r8dbss, 4, 3, nlv, 'DBSS SALN SST1 WCON' ) + print *, ' UFBSTP' r8f5fc ( 1, 1 ) = 0.08593800 - r8f5fc ( 2, 1 ) = 0.00390625 + r8f5fc ( 2, 1 ) = 0.00390625 r8f5fc ( 3, 1 ) = 32.50110000_8 r8f5fc ( 4, 1 ) = 0.8883 r8f5fc ( 5, 1 ) = -0.3818 @@ -73,7 +73,7 @@ r8f5fc ( 7, 1 ) = -0.6438 r8f5fc ( 8, 1 ) = 3.11 r8f5fc ( 1, 2 ) = 0.08984400 - r8f5fc ( 2, 2 ) = 0.00390625 + r8f5fc ( 2, 2 ) = 0.00390625 r8f5fc ( 3, 2 ) = 26.45480000_8 r8f5fc ( 4, 2 ) = 0.8795 r8f5fc ( 5, 2 ) = -0.4412 @@ -81,7 +81,7 @@ r8f5fc ( 7, 2 ) = -0.7761 r8f5fc ( 8, 2 ) = 3.12 r8f5fc ( 1, 3 ) = 0.09375000 - r8f5fc ( 2, 3 ) = 0.00390625 + r8f5fc ( 2, 3 ) = 0.00390625 r8f5fc ( 3, 3 ) = 41.96410000_8 r8f5fc ( 4, 3 ) = 0.9124 r8f5fc ( 5, 3 ) = -0.3137 @@ -89,7 +89,7 @@ r8f5fc ( 7, 3 ) = -0.5316 r8f5fc ( 8, 3 ) = 3.13 r8f5fc ( 1, 4 ) = 0.09765600 - r8f5fc ( 2, 4 ) = 0.00390625 + r8f5fc ( 2, 4 ) = 0.00390625 r8f5fc ( 3, 4 ) = 28.98830000_8 r8f5fc ( 4, 4 ) = 0.8917 r8f5fc ( 5, 4 ) = -0.3020 @@ -97,7 +97,7 @@ r8f5fc ( 7, 4 ) = -0.4804 r8f5fc ( 8, 4 ) = 3.14 r8f5fc ( 1, 5 ) = 0.10156300 - r8f5fc ( 2, 5 ) = 0.00390628 + r8f5fc ( 2, 5 ) = 0.00390628 r8f5fc ( 3, 5 ) = 11.71090000_8 r8f5fc ( 4, 5 ) = 0.8273 r8f5fc ( 5, 5 ) = -0.2884 @@ -105,19 +105,19 @@ r8f5fc ( 7, 5 ) = -0.4184 r8f5fc ( 8, 5 ) = 3.15 CALL DRFINI ( 11, 5, 1, '{F5FCRSEQ}' ) - print *, ' DRFINI' + print *, ' DRFINI' CALL UFBSEQ ( 11, r8f5fc, 8, 5, nlv, 'F5FCRSEQ' ) - print *, ' UFBSEQ' - - CALL WRITSB ( 11 ) - print *, ' WRITSB' + print *, ' UFBSEQ' + + CALL WRITSB ( 11 ) + print *, ' WRITSB' - ptidc = '300534061608630' - CALL WRITLC ( 11, ptidc, 'PTIDC' ) - print *, ' WRITLC' + ptidc = '300534061608630' + CALL WRITLC ( 11, ptidc, 'PTIDC' ) + print *, ' WRITLC' - CALL CLOSBF ( 11 ) - print *, ' CLOSBF' + CALL CLOSBF ( 11 ) + print *, ' CLOSBF' - STOP - END + STOP + END diff --git a/test/test_OUT_7.F90 b/test/test_OUT_7.F90 index 19434d72..37effe1e 100644 --- a/test/test_OUT_7.F90 +++ b/test/test_OUT_7.F90 @@ -9,7 +9,7 @@ program test_OUT_7 #ifdef INTSIZE_8 - integer*4 ireadmg, icopysb + integer*4 ireadmg, icopysb #endif character cmgtag*8 @@ -46,7 +46,7 @@ program test_OUT_7 open ( unit = 50, file = 'out7.bufr', form = 'unformatted') call openbf ( 50, 'OUT', 23 ) - + ! Read the input files into internal memory arrays. call ufbmex ( 21, 23, 0, icnt1, imesg ) @@ -117,7 +117,7 @@ program test_OUT_7 do while ( istart < isub(ii) ) ! calling copysb (or icopysb) with the 2nd argument negative prevents writing to that output file, but ! the read pointer in the input (1st argument) file is still advanced to the next subset - call copysb ( 21, -50, ier ) + call copysb ( 21, -50, ier ) istart = istart + 1 end do if ( ( icopysb ( 21, 50 ) ) /= 0 ) call bort ( 'ICOPYSB FAILURE!!' ) diff --git a/test/test_c_interface_2.c b/test/test_c_interface_2.c index 07c7584e..2a7547f9 100644 --- a/test/test_c_interface_2.c +++ b/test/test_c_interface_2.c @@ -34,32 +34,32 @@ int main() { mtinfo_f( "../tables", TABLE_1_FILE_UNIT, TABLE_2_FILE_UNIT ); if ( ( ireadmg_f( BUFR_FILE_UNIT, msg_subset, &iddate, SUBSET_STRING_LEN ) != 0 ) || - ( strncmp( msg_subset, "MSTTB001", 8) != 0 ) || ( iddate != 16041815 ) ) { - printf( "%s\n", "ireadmg check FAILED!" ); - exit(1); + ( strncmp( msg_subset, "MSTTB001", 8) != 0 ) || ( iddate != 16041815 ) ) { + printf( "%s\n", "ireadmg check FAILED!" ); + exit(1); } else { - if ( ireadsb_f( BUFR_FILE_UNIT ) != 0 ) { - printf( "%s\n", "ireadsb check FAILED!" ); - exit(1); - } - else { - ufbint_f( BUFR_FILE_UNIT, (void**) &r8arr_ptr, 3, 180, &iret, "CLONH SAID SAZA" ); - if ( ( ( (int) round( r8arr[0][0] * 100000 ) ) != -4246453 ) || - ( ( (int) round( r8arr[0][1] ) ) != 57 ) || - ( ( (int) round( r8arr[0][2] * 100 ) ) != 5407 ) ) { - printf( "%s\n", "ufbint check FAILED!" ); - exit(1); - } - ufbrep_f( BUFR_FILE_UNIT, (void**) &r8arr_ptr, 3, 180, &iret, "PCCF" ); - if ( ( ( (int) round( r8arr[11][0] ) ) != 86 ) || - ( ( (int) round( r8arr[14][0] ) ) != 38 ) || - ( ( (int) round( r8arr[101][0] ) ) != 88 ) || - ( ( (int) round( r8arr[140][0] ) ) != 10 ) ) { - printf( "%s\n", "ufbrep check FAILED!" ); - exit(1); - } - } + if ( ireadsb_f( BUFR_FILE_UNIT ) != 0 ) { + printf( "%s\n", "ireadsb check FAILED!" ); + exit(1); + } + else { + ufbint_f( BUFR_FILE_UNIT, (void**) &r8arr_ptr, 3, 180, &iret, "CLONH SAID SAZA" ); + if ( ( ( (int) round( r8arr[0][0] * 100000 ) ) != -4246453 ) || + ( ( (int) round( r8arr[0][1] ) ) != 57 ) || + ( ( (int) round( r8arr[0][2] * 100 ) ) != 5407 ) ) { + printf( "%s\n", "ufbint check FAILED!" ); + exit(1); + } + ufbrep_f( BUFR_FILE_UNIT, (void**) &r8arr_ptr, 3, 180, &iret, "PCCF" ); + if ( ( ( (int) round( r8arr[11][0] ) ) != 86 ) || + ( ( (int) round( r8arr[14][0] ) ) != 38 ) || + ( ( (int) round( r8arr[101][0] ) ) != 88 ) || + ( ( (int) round( r8arr[140][0] ) ) != 10 ) ) { + printf( "%s\n", "ufbrep check FAILED!" ); + exit(1); + } + } } closbf_f( BUFR_FILE_UNIT ); diff --git a/utils/debufr.c.in b/utils/debufr.c.in index 65f4bae9..daf67b30 100644 --- a/utils/debufr.c.in +++ b/utils/debufr.c.in @@ -17,7 +17,7 @@ * 2021-03-02 | J. Ator | Add missing include files, remove unused errflg variable, and other general cleanup. * 2022-04-05 | J. Ator | Increase MXFLEN to 500, use MXFLEN_TBLFIL. * - * @author J. Ator @date 2018-03-01 + * @author J. Ator @date 2018-03-01 */ #include @@ -56,8 +56,8 @@ * @param s5 - Extra C-Fortran interface argument containing length of basic variable. * @param s6 - Extra C-Fortran interface argument containing length of forcemt variable. * @param s7 - Extra C-Fortran interface argument containing length of cfms variable. - * - * @author J. Ator @date 2018-03-01 + * + * @author J. Ator @date 2018-03-01 */ void fdebufr( char *ofile, char *tbldir, f77int *lentd, char *tblfil, char *prmstg, char *basic, char *forcemt, char *cfms, size_t s1, size_t s2, size_t s3, size_t s4, size_t s5, size_t s6, size_t s7); @@ -71,52 +71,52 @@ void prtusage( char *prgnam ); /** * This function prints program usage information to standard output. - * + * * @param prgnam - [path/]name of program executable. * - * @author J. Ator @date 2018-03-01 + * @author J. Ator @date 2018-03-01 */ void prtusage( char *prgnam ) { - printf( "\nUSAGE:\n" ); - printf( " %s [-v] [-h] [-b] [-c] [-m] [-o outfile] [-t tabledir] [-f tablefil] [-p prmstg] bufrfile\n\n", prgnam ); - printf( "\nWHERE:\n" ); - printf( " -v prints program version information and exits\n\n" ); - printf( " -h prints program help and usage information and exits\n\n" ); - printf( " -b specifies the \"basic\" option, meaning that only the\n" ); - printf( " information in Sections 0-3 will be decoded from each\n" ); - printf( " BUFR message in the bufrfile, and no attempt will be\n" ); - printf( " made to decode the data in Section 4\n\n" ); - printf( " -c specifies that code and flag table meanings should not\n" ); - printf( " be read from master BUFR tables and included in the output;\n" ); - printf( " otherwise this feature is enabled by default\n\n" ); - printf( " -m specifies that master BUFR tables will be used to\n" ); - printf( " decode the data messages in the file, regardless of\n" ); - printf( " whether it contains any embedded DX BUFR table messages.\n" ); - printf( " This option can be used to view the actual contents of\n" ); - printf( " DX BUFR table messages, which otherwise would not be\n" ); - printf( " printed in the output listing.\n\n" ); - printf( " outfile [path/]name of file to contain verbose output listing.\n" ); - printf( " The default is \"bufrfilename.debufr.out\" in the current\n" ); - printf( " working directory, where bufrfilename is the basename of\n" ); - printf( " the bufrfile (i.e. bufrfile with any preceding [path/]\n" ); - printf( " removed).\n\n" ); - printf( " tabledir [path/]name of directory containing tables to be used\n" ); - printf( " for decoding. This directory contains the DX BUFR tables\n" ); - printf( " file to be used (if one was specified via the -f option),\n" ); - printf( " or it may contain all of the master BUFR tables when these\n" ); - printf( " are being used to decode a file. If unspecified, the\n" ); - printf( " default directory location is\n" ); - printf( " \"@MASTER_TABLE_DIR@\"\n\n" ); - printf( " tablefil file within tabledir containing DX BUFR tables to be used\n" ); - printf( " for decoding.\n\n" ); - printf( " prmstg string of comma-separated PARAMETER=VALUE pairs, up to a\n" ); - printf( " maximum of 20. For each pair, the dynamic allocation\n" ); - printf( " PARAMETER will be set to VALUE within the underlying\n" ); - printf( " BUFRLIB software, overriding the default value that would\n" ); - printf( " otherwise be used. A complete list of parameters that can\n" ); - printf( " be dynamically sized is included within the documentation\n" ); - printf( " for BUFRLIB function isetprm.\n\n" ); - printf( " bufrfile [path/]name of BUFR file to be decoded\n\n" ); + printf( "\nUSAGE:\n" ); + printf( " %s [-v] [-h] [-b] [-c] [-m] [-o outfile] [-t tabledir] [-f tablefil] [-p prmstg] bufrfile\n\n", prgnam ); + printf( "\nWHERE:\n" ); + printf( " -v prints program version information and exits\n\n" ); + printf( " -h prints program help and usage information and exits\n\n" ); + printf( " -b specifies the \"basic\" option, meaning that only the\n" ); + printf( " information in Sections 0-3 will be decoded from each\n" ); + printf( " BUFR message in the bufrfile, and no attempt will be\n" ); + printf( " made to decode the data in Section 4\n\n" ); + printf( " -c specifies that code and flag table meanings should not\n" ); + printf( " be read from master BUFR tables and included in the output;\n" ); + printf( " otherwise this feature is enabled by default\n\n" ); + printf( " -m specifies that master BUFR tables will be used to\n" ); + printf( " decode the data messages in the file, regardless of\n" ); + printf( " whether it contains any embedded DX BUFR table messages.\n" ); + printf( " This option can be used to view the actual contents of\n" ); + printf( " DX BUFR table messages, which otherwise would not be\n" ); + printf( " printed in the output listing.\n\n" ); + printf( " outfile [path/]name of file to contain verbose output listing.\n" ); + printf( " The default is \"bufrfilename.debufr.out\" in the current\n" ); + printf( " working directory, where bufrfilename is the basename of\n" ); + printf( " the bufrfile (i.e. bufrfile with any preceding [path/]\n" ); + printf( " removed).\n\n" ); + printf( " tabledir [path/]name of directory containing tables to be used\n" ); + printf( " for decoding. This directory contains the DX BUFR tables\n" ); + printf( " file to be used (if one was specified via the -f option),\n" ); + printf( " or it may contain all of the master BUFR tables when these\n" ); + printf( " are being used to decode a file. If unspecified, the\n" ); + printf( " default directory location is\n" ); + printf( " \"@MASTER_TABLE_DIR@\"\n\n" ); + printf( " tablefil file within tabledir containing DX BUFR tables to be used\n" ); + printf( " for decoding.\n\n" ); + printf( " prmstg string of comma-separated PARAMETER=VALUE pairs, up to a\n" ); + printf( " maximum of 20. For each pair, the dynamic allocation\n" ); + printf( " PARAMETER will be set to VALUE within the underlying\n" ); + printf( " BUFRLIB software, overriding the default value that would\n" ); + printf( " otherwise be used. A complete list of parameters that can\n" ); + printf( " be dynamically sized is included within the documentation\n" ); + printf( " for BUFRLIB function isetprm.\n\n" ); + printf( " bufrfile [path/]name of BUFR file to be decoded\n\n" ); } /** @@ -129,7 +129,7 @@ void prtusage( char *prgnam ) { * the data messages in the file. Otherwise, or whenever the -m option * is specified, [master BUFR tables](@ref dfbfmstab) are read and used * to decode the data messages in the file. - * + * * Usage
* 

  *
@@ -193,144 +193,144 @@ void prtusage( char *prgnam ) {
  *
  * @return 0 for successs, error code otherwise.
  *
- * @author J. Ator @date 2018-03-01 
+ * @author J. Ator @date 2018-03-01
  */
 int main( int argc, char *argv[ ] ) {
 
-	int ch;
+        int ch;
 
-	char basic = 'N';
-	char forcemt = 'N';
-	char cfms = 'Y';
-	char io = 'r';
-	char tbldir[MXFLEN] =
-		"@MASTER_TABLE_DIR_C@";
-	char outfile[MXFLEN];
-	char wkstr[MXFLEN];
-	char wkstr2[MXFLEN];
-	char tblfil[MXFLEN_TBLFIL];
-	char prmstg[300] = "NULLPSTG";
-	char bvstr[9] = "        ";
+        char basic = 'N';
+        char forcemt = 'N';
+        char cfms = 'Y';
+        char io = 'r';
+        char tbldir[MXFLEN] =
+                "@MASTER_TABLE_DIR_C@";
+        char outfile[MXFLEN];
+        char wkstr[MXFLEN];
+        char wkstr2[MXFLEN];
+        char tblfil[MXFLEN_TBLFIL];
+        char prmstg[300] = "NULLPSTG";
+        char bvstr[9] = "        ";
 
-	unsigned short ii;
+        unsigned short ii;
 
-	f77int lentd;
-	
-	/*
-	**  Get and process the valid options from the command line:
-	*/
-	wkstr[0] = '\0';  /* initialize to empty string */
-	outfile[0] = '\0';  /* initialize to empty string */
-	while ( ( ch = getopt ( argc, argv, "vhbcmo:t:f:p:" ) ) != EOF ) {
-	    switch ( ch ) {
-		case 'v':
-		    bvers ( bvstr, sizeof(bvstr) );
-		    /* append a trailing NULL to bvstr for printf */
-		    for ( ii = 0; ii < sizeof(bvstr); ii++ ) {
-			if ( ( bvstr[ii] != '.' ) && ( !isdigit(bvstr[ii]) ) ) {
-			  bvstr[ii] = '\0';
-			  break;
-			}
-		    }
-		    printf( "This is debufr v3.1.2, built with BUFRLIB v%s\n",
-			    bvstr );
-		    return 0;
-		case 'h':
-		    printf( "\nPROGRAM %s\n", argv[0] );
-		    printf( "\nABSTRACT: This program decodes a BUFR file and generates a verbose\n" );
-		    printf( "  listing of the contents.  If a DX BUFR tables file is specified\n" );
-		    printf( "  (using the -f option) or if the specified BUFR file contains an\n" );
-		    printf( "  embedded DX BUFR tables message as the first message in the file,\n" );
-		    printf( "  then this DX BUFR tables information is used to decode the data\n" );
-		    printf( "  messages in the file.  Otherwise, or whenever the -m option is\n" );
-		    printf( "  specified, master BUFR tables are read and used to decode the\n" );
-		    printf( "  data messages in the file.\n" );
-		    prtusage( argv[0] );
-		    return 0;
-		    break;
-		case 'b':
-		    basic = 'Y';
-		    break;
-		case 'm':
-		    forcemt = 'Y';
-		    break;
-		case 'c':
-		    cfms = 'N';
-		    break;
-		case 'o':
-		    strcpy ( outfile, optarg );
-		    break;
-		case 't':
-		    strcpy ( tbldir, optarg );
-		    break;
-		case 'f':
-		    strcpy ( wkstr, optarg );
-		    break;
-		case 'p':
-		    strcpy ( prmstg, optarg );
-		    break;
-	    }
-	}
+        f77int lentd;
 
-	/*
-	**  There should be one remaining command line argument specifying the
-	**  input BUFR file.
-	*/
-	if ( (optind+1) != argc ) {
-	    printf( "\nERROR: You must specify an input BUFR file to be decoded!\n" );
-	    prtusage( argv[0] );
-	    return -1;
+        /*
+        **  Get and process the valid options from the command line:
+        */
+        wkstr[0] = '\0';  /* initialize to empty string */
+        outfile[0] = '\0';  /* initialize to empty string */
+        while ( ( ch = getopt ( argc, argv, "vhbcmo:t:f:p:" ) ) != EOF ) {
+            switch ( ch ) {
+                case 'v':
+                    bvers ( bvstr, sizeof(bvstr) );
+                    /* append a trailing NULL to bvstr for printf */
+                    for ( ii = 0; ii < sizeof(bvstr); ii++ ) {
+                        if ( ( bvstr[ii] != '.' ) && ( !isdigit(bvstr[ii]) ) ) {
+                          bvstr[ii] = '\0';
+                          break;
+                        }
+                    }
+                    printf( "This is debufr v3.1.2, built with BUFRLIB v%s\n",
+                            bvstr );
+                    return 0;
+                case 'h':
+                    printf( "\nPROGRAM %s\n", argv[0] );
+                    printf( "\nABSTRACT: This program decodes a BUFR file and generates a verbose\n" );
+                    printf( "  listing of the contents.  If a DX BUFR tables file is specified\n" );
+                    printf( "  (using the -f option) or if the specified BUFR file contains an\n" );
+                    printf( "  embedded DX BUFR tables message as the first message in the file,\n" );
+                    printf( "  then this DX BUFR tables information is used to decode the data\n" );
+                    printf( "  messages in the file.  Otherwise, or whenever the -m option is\n" );
+                    printf( "  specified, master BUFR tables are read and used to decode the\n" );
+                    printf( "  data messages in the file.\n" );
+                    prtusage( argv[0] );
+                    return 0;
+                    break;
+                case 'b':
+                    basic = 'Y';
+                    break;
+                case 'm':
+                    forcemt = 'Y';
+                    break;
+                case 'c':
+                    cfms = 'N';
+                    break;
+                case 'o':
+                    strcpy ( outfile, optarg );
+                    break;
+                case 't':
+                    strcpy ( tbldir, optarg );
+                    break;
+                case 'f':
+                    strcpy ( wkstr, optarg );
+                    break;
+                case 'p':
+                    strcpy ( prmstg, optarg );
+                    break;
+            }
         }
 
-	/*
-	**  Open the input BUFR file.
-	*/
-	cobfl( argv[optind], &io );
+        /*
+        **  There should be one remaining command line argument specifying the
+        **  input BUFR file.
+        */
+        if ( (optind+1) != argc ) {
+            printf( "\nERROR: You must specify an input BUFR file to be decoded!\n" );
+            prtusage( argv[0] );
+            return -1;
+        }
 
-	/*
-	**  Check whether a DX tables file was specified.
-	*/
-	if ( strlen( wkstr ) > 0 ) {
-	    sprintf( tblfil, "%s%c%s", tbldir, '/', wkstr );
-	}
-	else {
-	    strcpy( tblfil, "NULLFILE" );
-	}
+        /*
+        **  Open the input BUFR file.
+        */
+        cobfl( argv[optind], &io );
 
-	/*
-	**  Check whether an output file was specified.  If not, make a default
-	**  filename in the current working directory using the basename of the
-	**  input BUFR file.
-	*/
-	if ( strlen( outfile ) == 0 ) {
-	    strcpy( wkstr2, argv[optind] );
-	    strcpy( outfile, basename( wkstr2 ) );
-	    strcat( outfile, ".debufr.out" );
-	}
+        /*
+        **  Check whether a DX tables file was specified.
+        */
+        if ( strlen( wkstr ) > 0 ) {
+            sprintf( tblfil, "%s%c%s", tbldir, '/', wkstr );
+        }
+        else {
+            strcpy( tblfil, "NULLFILE" );
+        }
+
+        /*
+        **  Check whether an output file was specified.  If not, make a default
+        **  filename in the current working directory using the basename of the
+        **  input BUFR file.
+        */
+        if ( strlen( outfile ) == 0 ) {
+            strcpy( wkstr2, argv[optind] );
+            strcpy( outfile, basename( wkstr2 ) );
+            strcat( outfile, ".debufr.out" );
+        }
 
-	/*
-	**  Confirm that the output directory is writeable.
-	*/
-	strcpy( wkstr2, outfile );
-	strcpy( wkstr, dirname( wkstr2 ) );
-	if ( access( wkstr, W_OK ) != 0 ) {
-	    printf( "\nERROR: Cannot write output file to directory %s\n",
-		( strcmp( wkstr, "." ) == 0 ? getcwd( wkstr2, MXFLEN ) : wkstr ) );
-	    prtusage( argv[0] );
-	    return -1;
-	}
+        /*
+        **  Confirm that the output directory is writeable.
+        */
+        strcpy( wkstr2, outfile );
+        strcpy( wkstr, dirname( wkstr2 ) );
+        if ( access( wkstr, W_OK ) != 0 ) {
+            printf( "\nERROR: Cannot write output file to directory %s\n",
+                ( strcmp( wkstr, "." ) == 0 ? getcwd( wkstr2, MXFLEN ) : wkstr ) );
+            prtusage( argv[0] );
+            return -1;
+        }
 
-	/*
-	**  Read and decode each message from the input BUFR file.
-	*/
-	lentd = (f77int) strlen(tbldir);
-	fdebufr( outfile, tbldir, &lentd, tblfil, prmstg, &basic, &forcemt, &cfms,
-		 strlen(outfile), strlen(tbldir), strlen(tblfil), strlen(prmstg), 1, 1, 1 );
+        /*
+        **  Read and decode each message from the input BUFR file.
+        */
+        lentd = (f77int) strlen(tbldir);
+        fdebufr( outfile, tbldir, &lentd, tblfil, prmstg, &basic, &forcemt, &cfms,
+                 strlen(outfile), strlen(tbldir), strlen(tblfil), strlen(prmstg), 1, 1, 1 );
 
-	/*
-	**  Close the input BUFR file.
-	*/
-	ccbfl( );
+        /*
+        **  Close the input BUFR file.
+        */
+        ccbfl( );
 
-	return 0;
+        return 0;
 }
diff --git a/utils/debufr.f b/utils/debufr.f
index 330682ad..7ecaa0b0 100644
--- a/utils/debufr.f
+++ b/utils/debufr.f
@@ -6,7 +6,7 @@
 C> openbt(), since the latter is not called by the former but
 C> rather is called directly from within the BUFRLIB software.
 
-	MODULE Share_Table_Info
+        MODULE Share_Table_Info
 
 C>          @var ctbldir
 C>          Directory containing DX BUFR tables to be used for
@@ -19,9 +19,9 @@ MODULE Share_Table_Info
 C>          Fortran logical unit number to use for referencing
 C>          a DX table.
 
-	    CHARACTER*120	ctbldir
-	    INTEGER		ltbd, ludx
-	END MODULE
+            CHARACTER*120       ctbldir
+            INTEGER             ltbd, ludx
+        END MODULE
 
 C> This subroutine reads, decodes, and generates a verbose output
 C> listing of the contents of every BUFR message from within the
@@ -84,394 +84,394 @@ MODULE Share_Table_Info
 C> | 2021-02-24 | J. Ator | Use all formatted writes, for consistent output between builds using 4-byte vs. 8-byte integers |
 C> | 2022-11-30 | J. Ator | Check return code from isetprm() |
 
-	SUBROUTINE FDEBUFR ( ofile, tbldir, lentd, tblfil, prmstg,
-     +			     basic, forcemt, cfms )
+        SUBROUTINE FDEBUFR ( ofile, tbldir, lentd, tblfil, prmstg,
+     +                       basic, forcemt, cfms )
 
-	USE Share_Table_Info
+        USE Share_Table_Info
 
-	PARAMETER ( MXBF = 2500000 )
-	PARAMETER ( MXBFD4 = MXBF/4 )
-	PARAMETER ( MXDS3 = 500 )
-	PARAMETER ( MXPRMS = 20 )
+        PARAMETER ( MXBF = 2500000 )
+        PARAMETER ( MXBFD4 = MXBF/4 )
+        PARAMETER ( MXDS3 = 500 )
+        PARAMETER ( MXPRMS = 20 )
 
-	CHARACTER*(*)	ofile, tbldir, tblfil, prmstg
+        CHARACTER*(*)   ofile, tbldir, tblfil, prmstg
 
-	LOGICAL		exists
+        LOGICAL         exists
 
-	CHARACTER*120	cmorgc, cmgses, cmmtyp, cmmsbt, cmmsbti
-	CHARACTER*20	ptag ( MXPRMS ), pvtag(2), cprmnm
-	CHARACTER*8	cmgtag
-	CHARACTER*6	cds3 ( MXDS3 )
-	CHARACTER*1	basic, forcemt, opened, usemt, cfms,
-     +			bfmg ( MXBF )
+        CHARACTER*120   cmorgc, cmgses, cmmtyp, cmmsbt, cmmsbti
+        CHARACTER*20    ptag ( MXPRMS ), pvtag(2), cprmnm
+        CHARACTER*8     cmgtag
+        CHARACTER*6     cds3 ( MXDS3 )
+        CHARACTER*1     basic, forcemt, opened, usemt, cfms,
+     +                  bfmg ( MXBF )
 
-	INTEGER		ibfmg ( MXBFD4 )
+        INTEGER         ibfmg ( MXBFD4 )
+
+        EQUIVALENCE     ( bfmg (1), ibfmg (1) )
 
-	EQUIVALENCE	( bfmg (1), ibfmg (1) )
- 
 C-----------------------------------------------------------------------
 C-----------------------------------------------------------------------
 
-C	Open the output file.
+C       Open the output file.
 
-	OPEN ( UNIT = 51, FILE = ofile )
+        OPEN ( UNIT = 51, FILE = ofile )
 
-C	Note that in the below OPEN statement we just need to specify
-C	a dummy placeholder file.
+C       Note that in the below OPEN statement we just need to specify
+C       a dummy placeholder file.
 
-	lunit = 92
-	OPEN ( UNIT = lunit, FILE = '/dev/null' )
+        lunit = 92
+        OPEN ( UNIT = lunit, FILE = '/dev/null' )
 
-	CALL DATELEN ( 10 )
+        CALL DATELEN ( 10 )
 
-C	Initialize the values in the Share_Table_Info module.
+C       Initialize the values in the Share_Table_Info module.
 
-	ludx = 93
-	ltbd = lentd
-	ctbldir = tbldir(1:lentd)
+        ludx = 93
+        ltbd = lentd
+        ctbldir = tbldir(1:lentd)
 
-C	Initialize some other values.
+C       Initialize some other values.
 
-	nmsg = 0
-	nsubt = 0
+        nmsg = 0
+        nsubt = 0
 
-	opened = 'N'
-	usemt = 'N'
+        opened = 'N'
+        usemt = 'N'
 
-	DO WHILE ( .true. )
+        DO WHILE ( .true. )
 
-C	    Get the next message from the input BUFR file.
+C           Get the next message from the input BUFR file.
 
-	    CALL CRBMG ( bfmg, MXBF, nbyt, ierr )
+            CALL CRBMG ( bfmg, MXBF, nbyt, ierr )
 
-	    IF ( ierr .ne. 0 )  THEN
+            IF ( ierr .ne. 0 )  THEN
 
-		IF ( ierr .eq. -1 ) THEN
-		    WRITE  ( UNIT = 51, FMT = '( /, 2A, I7, A, I9, A )')
-     +		      'Reached end of BUFR file; it contained a total ',
-     +		      'of', nmsg, ' messages and', nsubt, ' subsets'
-		ELSE
-		    WRITE  ( UNIT = 51, FMT = '( /, 2A, I4 )' )
-     +		      'Error while reading BUFR file; the return code ',
-     +		      'from CRBMG = ', ierr
-		ENDIF
+                IF ( ierr .eq. -1 ) THEN
+                    WRITE  ( UNIT = 51, FMT = '( /, 2A, I7, A, I9, A )')
+     +                'Reached end of BUFR file; it contained a total ',
+     +                'of', nmsg, ' messages and', nsubt, ' subsets'
+                ELSE
+                    WRITE  ( UNIT = 51, FMT = '( /, 2A, I4 )' )
+     +                'Error while reading BUFR file; the return code ',
+     +                'from CRBMG = ', ierr
+                ENDIF
 
-		IF ( ( basic .eq. 'N' ) .and. ( opened .eq. 'Y' ) ) THEN
-		    WRITE (51, FMT = '( /, A, / )' )
-     +			'Here is the DX table that was generated:'
-		    CALL DXDUMP ( lunit, 51 )
-		ENDIF
+                IF ( ( basic .eq. 'N' ) .and. ( opened .eq. 'Y' ) ) THEN
+                    WRITE (51, FMT = '( /, A, / )' )
+     +                  'Here is the DX table that was generated:'
+                    CALL DXDUMP ( lunit, 51 )
+                ENDIF
 
-C		Close the output file and return.
+C               Close the output file and return.
 
-		CLOSE ( 51 )
-		RETURN
-	    ENDIF
+                CLOSE ( 51 )
+                RETURN
+            ENDIF
 
-	    IF ( opened .eq. 'N' ) THEN
+            IF ( opened .eq. 'N' ) THEN
 
-		IF ( ( ISETPRM ( 'MAXCD', MXDS3 ) .ne. 0 ) .or.
-     +		     ( ISETPRM ( 'MXMSGL', MXBF ) .ne. 0 ) .or.
-     +		     ( ISETPRM ( 'MAXSS', 300000 ) .ne. 0 ) .or.
-     +		     ( ISETPRM ( 'NFILES', 2 ) .ne. 0 ) ) THEN
-		    PRINT *, 'ERROR: BAD RETURN FROM ISETPRM'
-		    RETURN
-		ENDIF
+                IF ( ( ISETPRM ( 'MAXCD', MXDS3 ) .ne. 0 ) .or.
+     +               ( ISETPRM ( 'MXMSGL', MXBF ) .ne. 0 ) .or.
+     +               ( ISETPRM ( 'MAXSS', 300000 ) .ne. 0 ) .or.
+     +               ( ISETPRM ( 'NFILES', 2 ) .ne. 0 ) ) THEN
+                    PRINT *, 'ERROR: BAD RETURN FROM ISETPRM'
+                    RETURN
+                ENDIF
 
-C		Process any dynamic allocation parameters that were
-C		passed in on the command line.
+C               Process any dynamic allocation parameters that were
+C               passed in on the command line.
 
-		IF ( prmstg(1:8) .ne. 'NULLPSTG' ) THEN
-		   CALL PARSTR ( prmstg, ptag, MXPRMS, nptag, ',',
-     +				 .false. ) 
-		   IF ( nptag .gt. 0 ) THEN
-			DO ii = 1, nptag
-			  CALL PARSTR ( ptag(ii), pvtag, 2, npvtag, '=',
-     +					.false. )
-			  IF ( npvtag .eq. 2 ) THEN
-			    CALL STRSUC ( pvtag(1), cprmnm, lcprmnm )
-			    CALL STRNUM ( pvtag(2), ipval )
-			    IF ( ( lcprmnm .gt. 0 ) .and.
-     +				 ( ipval .ne. -1 ) ) THEN
-			      IF ( ISETPRM ( cprmnm(1:lcprmnm), ipval )
-     +				  .ne. 0 ) THEN
-			       PRINT *, 'ERROR: BAD RETURN FROM ISETPRM'
+                IF ( prmstg(1:8) .ne. 'NULLPSTG' ) THEN
+                   CALL PARSTR ( prmstg, ptag, MXPRMS, nptag, ',',
+     +                           .false. )
+                   IF ( nptag .gt. 0 ) THEN
+                        DO ii = 1, nptag
+                          CALL PARSTR ( ptag(ii), pvtag, 2, npvtag, '=',
+     +                                  .false. )
+                          IF ( npvtag .eq. 2 ) THEN
+                            CALL STRSUC ( pvtag(1), cprmnm, lcprmnm )
+                            CALL STRNUM ( pvtag(2), ipval )
+                            IF ( ( lcprmnm .gt. 0 ) .and.
+     +                           ( ipval .ne. -1 ) ) THEN
+                              IF ( ISETPRM ( cprmnm(1:lcprmnm), ipval )
+     +                            .ne. 0 ) THEN
+                               PRINT *, 'ERROR: BAD RETURN FROM ISETPRM'
      +                          // ' FOR PARAMETER: ', cprmnm(1:lcprmnm)
-			       RETURN
-			      ENDIF
-			    ENDIF
-			  ENDIF
-			ENDDO
-		   ENDIF
-		ENDIF
+                               RETURN
+                              ENDIF
+                            ENDIF
+                          ENDIF
+                        ENDDO
+                   ENDIF
+                ENDIF
 
-C		Decide how to process the file.
+C               Decide how to process the file.
 
-		IF ( ( IDXMSG ( ibfmg ) .eq. 1 ) .and.
-     +			( forcemt .eq. 'N' ) ) THEN
+                IF ( ( IDXMSG ( ibfmg ) .eq. 1 ) .and.
+     +                  ( forcemt .eq. 'N' ) ) THEN
 
-C		    The first message in the file is a DX dictionary
-C		    message, so assume there's an embedded table at the
-C		    front of the file and use this table to decode it.
+C                   The first message in the file is a DX dictionary
+C                   message, so assume there's an embedded table at the
+C                   front of the file and use this table to decode it.
 
-		    CALL OPENBF ( lunit, 'INUL', lunit )
-		ELSE IF ( ( tblfil(1:8) .ne. 'NULLFILE' ) .and.
-     +			    ( forcemt .eq. 'N' ) ) THEN
+                    CALL OPENBF ( lunit, 'INUL', lunit )
+                ELSE IF ( ( tblfil(1:8) .ne. 'NULLFILE' ) .and.
+     +                      ( forcemt .eq. 'N' ) ) THEN
 
-C		    A DX dictionary tables file was specified on the
-C		    command line, so use it to decode the BUFR file.
+C                   A DX dictionary tables file was specified on the
+C                   command line, so use it to decode the BUFR file.
 
-		    INQUIRE ( FILE = tblfil, EXIST = exists )
-		    IF ( .not. exists ) THEN
-			PRINT *, 'ERROR: COULD NOT FIND FILE ', tblfil
-			RETURN
-		    ENDIF
-		    OPEN ( UNIT = 91, FILE = tblfil, IOSTAT = ier )
-		    IF ( ier .ne. 0 ) THEN
-			PRINT *, 'ERROR: COULD NOT OPEN FILE ', tblfil
-			RETURN
-		    ENDIF
-		    CALL OPENBF ( lunit, 'IN', 91 )
-		ELSE
+                    INQUIRE ( FILE = tblfil, EXIST = exists )
+                    IF ( .not. exists ) THEN
+                        PRINT *, 'ERROR: COULD NOT FIND FILE ', tblfil
+                        RETURN
+                    ENDIF
+                    OPEN ( UNIT = 91, FILE = tblfil, IOSTAT = ier )
+                    IF ( ier .ne. 0 ) THEN
+                        PRINT *, 'ERROR: COULD NOT OPEN FILE ', tblfil
+                        RETURN
+                    ENDIF
+                    CALL OPENBF ( lunit, 'IN', 91 )
+                ELSE
 
-C		    Decode the file using the master tables in tbldir.
+C                   Decode the file using the master tables in tbldir.
 
-		    usemt = 'Y'
-		    CALL OPENBF ( lunit, 'SEC3', lunit )
-		ENDIF
+                    usemt = 'Y'
+                    CALL OPENBF ( lunit, 'SEC3', lunit )
+                ENDIF
 
-		opened = 'Y'
+                opened = 'Y'
 
-		CALL MTINFO ( tbldir, 90, 91 )
-		IF ( cfms .eq. 'Y' ) CALL CODFLG ( 'Y' )
-	    ENDIF
+                CALL MTINFO ( tbldir, 90, 91 )
+                IF ( cfms .eq. 'Y' ) CALL CODFLG ( 'Y' )
+            ENDIF
 
-	    IF ( basic .eq. 'N' ) THEN
+            IF ( basic .eq. 'N' ) THEN
 
-C	        Pass the message to the decoder.
+C               Pass the message to the decoder.
 
-		CALL READERME ( ibfmg, lunit, cmgtag, imgdt, ierme )
-	    ENDIF
+                CALL READERME ( ibfmg, lunit, cmgtag, imgdt, ierme )
+            ENDIF
 
-C	    If this is a DX dictionary message, then don't generate any
-C	    output unless master tables are being used for decoding.
+C           If this is a DX dictionary message, then don't generate any
+C           output unless master tables are being used for decoding.
 
-	    IF (  ( IDXMSG ( ibfmg ) .ne. 1 ) .or.
-     +		    ( usemt .eq. 'Y' )  ) THEN
+            IF (  ( IDXMSG ( ibfmg ) .ne. 1 ) .or.
+     +              ( usemt .eq. 'Y' )  ) THEN
 
-		nmsg = nmsg + 1
+                nmsg = nmsg + 1
 
-		WRITE  ( UNIT = 51, FMT = '( /, A, I7 )' )
-     +		    'Found BUFR message #', nmsg
+                WRITE  ( UNIT = 51, FMT = '( /, A, I7 )' )
+     +              'Found BUFR message #', nmsg
 
 C               Decode and output the data from Section 0.
 
-		WRITE ( 51, FMT= '( /, A, I9 )' )
-     +		       '        Message length:   ',
+                WRITE ( 51, FMT= '( /, A, I9 )' )
+     +                 '        Message length:   ',
      +                  IUPBS01 ( ibfmg, 'LENM' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '      Section 0 length:        ',
-     +			IUPBS01 ( ibfmg, 'LEN0' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '          BUFR edition:        ',
-     +			IUPBS01 ( ibfmg, 'BEN' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '      Section 0 length:        ',
+     +                  IUPBS01 ( ibfmg, 'LEN0' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '          BUFR edition:        ',
+     +                  IUPBS01 ( ibfmg, 'BEN' )
 
 C               Decode and output the data from Section 1.
 
-		WRITE ( 51, FMT= '( /, A, I4 )' )
-     +		       '      Section 1 length:        ',
-     +			IUPBS01 ( ibfmg, 'LEN1' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '          Master table:        ',
-     +			IUPBS01 ( ibfmg, 'BMT' )
-
-		iogce = IUPBS01 ( ibfmg, 'OGCE' )
-		igses = IUPBS01 ( ibfmg, 'GSES' )
-		IF ( ( basic .eq. 'Y' ) .or.
-     +		     ( cfms .eq. 'N' ) ) THEN
-		    WRITE ( 51, FMT= '( A, I5 )' )
-     +		       '    Originating center:       ', iogce
-		    WRITE ( 51, FMT= '( A, I4 )' )
-     +		       ' Originating subcenter:        ', igses
-		ELSE
-		    CALL GETCFMNG ( lunit, 'ORIGC', iogce, ' ', -1,
-     +				    cmorgc, lcmorgc, ierorgc )
-		    IF ( ierorgc .eq. 0 ) THEN
-		        WRITE ( 51, FMT= '( A, I5, 3A )' )
-     +			   '    Originating center:       ', iogce,
-     +			   ' (= ', cmorgc(1:lcmorgc), ')'
-		    ELSE
-		        WRITE ( 51, FMT= '( A, I5 )' )
-     +			   '    Originating center:       ', iogce
-		    ENDIF
-		    CALL GETCFMNG ( lunit, 'GSES', igses,
-     +				    'ORIGC', iogce,
-     +				    cmgses, lcmgses, iergses )
-		    IF ( iergses .eq. 0 ) THEN
-		        WRITE ( 51, FMT= '( A, I4, 3A )' )
-     +			   ' Originating subcenter:        ', igses,
-     +				' (= ', cmgses(1:lcmgses), ')'
-		    ELSE
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +		           ' Originating subcenter:        ', igses
-		    ENDIF
-		ENDIF
-
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       ' Update sequence numbr:        ',
-     +			IUPBS01 ( ibfmg, 'USN' )
- 
-		IF ( IUPBS01 ( ibfmg, 'ISC2' ) .eq. 1 ) THEN
-		    WRITE ( 51, FMT = '( A )')
-     +		       '    Section 2 present?: Yes'
-		ELSE
-		    WRITE ( 51, FMT = '( A )')
-     +		       '    Section 2 present?: No'
-		ENDIF
- 
-		mtyp = IUPBS01 ( ibfmg, 'MTYP' )
-		msbt = IUPBS01 ( ibfmg, 'MSBT' )
-		msbti = IUPBS01 ( ibfmg, 'MSBTI' )
-		IF ( ( basic .eq. 'Y' ) .or.
-     +		     ( cfms .eq. 'N' ) ) THEN
-		    WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '         Data category:        ', mtyp
-		    WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '     Local subcategory:        ', msbt
-		    WRITE ( 51, FMT= '( A, I4 )' )
-     +		       ' Internatl subcategory:        ', msbti
-		ELSE
-		    CALL GETCFMNG ( lunit, 'TABLAT', mtyp, ' ', -1,
-     +				    cmmtyp, lcmmtyp, iermtyp )
-		    IF ( iermtyp .eq. 0 ) THEN
-		        WRITE ( 51, FMT= '( A, I4, 3A )' )
-     +			   '         Data category:        ', mtyp,
-     +			   ' (= ', cmmtyp(1:lcmmtyp), ')'
-		    ELSE
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +		           '         Data category:        ', mtyp
-		    ENDIF
-		    CALL GETCFMNG ( lunit, 'TABLASL', msbt,
-     +				    'TABLAT', mtyp,
-     +				    cmmsbt, lcmmsbt, iermsbt )
-		    IF ( ( iermsbt .eq. 0 ) .and.
-     +			 ( iogce .eq. 7 ) ) THEN
-		        WRITE ( 51, FMT= '( A, I4, 3A )' )
-     +			   '     Local subcategory:        ', msbt,
-     +				' (= ', cmmsbt(1:lcmmsbt), ')'
-		    ELSE
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +		           '     Local subcategory:        ', msbt
-		    ENDIF
-		    CALL GETCFMNG ( lunit, 'TABLASS', msbti,
-     +				    'TABLAT', mtyp,
-     +				    cmmsbti, lcmmsbti, iermsbti )
-		    IF ( iermsbti .eq. 0 ) THEN
-		        WRITE ( 51, FMT= '( A, I4, 3A )' )
-     +			   ' Internatl subcategory:        ', msbti,
-     +				' (= ', cmmsbti(1:lcmmsbti), ')'
-		    ELSE
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +		           ' Internatl subcategory:        ', msbti
-		    ENDIF
-		ENDIF
-
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '  Master table version:        ',
-     +			IUPBS01 ( ibfmg, 'MTV' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '   Local table version:        ',
-     +			IUPBS01 ( ibfmg, 'MTVL' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                  Year:        ',
-     +			IUPBS01 ( ibfmg, 'YEAR' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                 Month:        ',
-     +			IUPBS01 ( ibfmg, 'MNTH' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                   Day:        ',
-     +			IUPBS01 ( ibfmg, 'DAYS' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                  Hour:        ',
-     +			IUPBS01 ( ibfmg, 'HOUR' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                Minute:        ',
-     +			IUPBS01 ( ibfmg, 'MINU' )
-		WRITE ( 51, FMT= '( A, I4 )' )
-     +		       '                Second:        ',
-     +			IUPBS01 ( ibfmg, 'SECO' )
-		IF ( ( iogce .eq. 7 ) .and. ( igses .eq. 3 ) ) THEN
-		    CALL RTRCPTB ( ibfmg, iryr, irmo, irdy, irhr,
-     +				   irmi, irtret )
-		    IF ( irtret .eq. 0 ) THEN
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +			       '   NCEP tank rcpt year:        ', iryr
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +			       '  NCEP tank rcpt month:        ', irmo
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +			       '    NCEP tank rcpt day:        ', irdy
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +			       '   NCEP tank rcpt hour:        ', irhr
-		        WRITE ( 51, FMT= '( A, I4 )' )
-     +			       ' NCEP tank rcpt minute:        ', irmi
-		    END IF
-		END IF
+                WRITE ( 51, FMT= '( /, A, I4 )' )
+     +                 '      Section 1 length:        ',
+     +                  IUPBS01 ( ibfmg, 'LEN1' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '          Master table:        ',
+     +                  IUPBS01 ( ibfmg, 'BMT' )
+
+                iogce = IUPBS01 ( ibfmg, 'OGCE' )
+                igses = IUPBS01 ( ibfmg, 'GSES' )
+                IF ( ( basic .eq. 'Y' ) .or.
+     +               ( cfms .eq. 'N' ) ) THEN
+                    WRITE ( 51, FMT= '( A, I5 )' )
+     +                 '    Originating center:       ', iogce
+                    WRITE ( 51, FMT= '( A, I4 )' )
+     +                 ' Originating subcenter:        ', igses
+                ELSE
+                    CALL GETCFMNG ( lunit, 'ORIGC', iogce, ' ', -1,
+     +                              cmorgc, lcmorgc, ierorgc )
+                    IF ( ierorgc .eq. 0 ) THEN
+                        WRITE ( 51, FMT= '( A, I5, 3A )' )
+     +                     '    Originating center:       ', iogce,
+     +                     ' (= ', cmorgc(1:lcmorgc), ')'
+                    ELSE
+                        WRITE ( 51, FMT= '( A, I5 )' )
+     +                     '    Originating center:       ', iogce
+                    ENDIF
+                    CALL GETCFMNG ( lunit, 'GSES', igses,
+     +                              'ORIGC', iogce,
+     +                              cmgses, lcmgses, iergses )
+                    IF ( iergses .eq. 0 ) THEN
+                        WRITE ( 51, FMT= '( A, I4, 3A )' )
+     +                     ' Originating subcenter:        ', igses,
+     +                          ' (= ', cmgses(1:lcmgses), ')'
+                    ELSE
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                     ' Originating subcenter:        ', igses
+                    ENDIF
+                ENDIF
+
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 ' Update sequence numbr:        ',
+     +                  IUPBS01 ( ibfmg, 'USN' )
+
+                IF ( IUPBS01 ( ibfmg, 'ISC2' ) .eq. 1 ) THEN
+                    WRITE ( 51, FMT = '( A )')
+     +                 '    Section 2 present?: Yes'
+                ELSE
+                    WRITE ( 51, FMT = '( A )')
+     +                 '    Section 2 present?: No'
+                ENDIF
+
+                mtyp = IUPBS01 ( ibfmg, 'MTYP' )
+                msbt = IUPBS01 ( ibfmg, 'MSBT' )
+                msbti = IUPBS01 ( ibfmg, 'MSBTI' )
+                IF ( ( basic .eq. 'Y' ) .or.
+     +               ( cfms .eq. 'N' ) ) THEN
+                    WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '         Data category:        ', mtyp
+                    WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '     Local subcategory:        ', msbt
+                    WRITE ( 51, FMT= '( A, I4 )' )
+     +                 ' Internatl subcategory:        ', msbti
+                ELSE
+                    CALL GETCFMNG ( lunit, 'TABLAT', mtyp, ' ', -1,
+     +                              cmmtyp, lcmmtyp, iermtyp )
+                    IF ( iermtyp .eq. 0 ) THEN
+                        WRITE ( 51, FMT= '( A, I4, 3A )' )
+     +                     '         Data category:        ', mtyp,
+     +                     ' (= ', cmmtyp(1:lcmmtyp), ')'
+                    ELSE
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                     '         Data category:        ', mtyp
+                    ENDIF
+                    CALL GETCFMNG ( lunit, 'TABLASL', msbt,
+     +                              'TABLAT', mtyp,
+     +                              cmmsbt, lcmmsbt, iermsbt )
+                    IF ( ( iermsbt .eq. 0 ) .and.
+     +                   ( iogce .eq. 7 ) ) THEN
+                        WRITE ( 51, FMT= '( A, I4, 3A )' )
+     +                     '     Local subcategory:        ', msbt,
+     +                          ' (= ', cmmsbt(1:lcmmsbt), ')'
+                    ELSE
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                     '     Local subcategory:        ', msbt
+                    ENDIF
+                    CALL GETCFMNG ( lunit, 'TABLASS', msbti,
+     +                              'TABLAT', mtyp,
+     +                              cmmsbti, lcmmsbti, iermsbti )
+                    IF ( iermsbti .eq. 0 ) THEN
+                        WRITE ( 51, FMT= '( A, I4, 3A )' )
+     +                     ' Internatl subcategory:        ', msbti,
+     +                          ' (= ', cmmsbti(1:lcmmsbti), ')'
+                    ELSE
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                     ' Internatl subcategory:        ', msbti
+                    ENDIF
+                ENDIF
+
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '  Master table version:        ',
+     +                  IUPBS01 ( ibfmg, 'MTV' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '   Local table version:        ',
+     +                  IUPBS01 ( ibfmg, 'MTVL' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                  Year:        ',
+     +                  IUPBS01 ( ibfmg, 'YEAR' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                 Month:        ',
+     +                  IUPBS01 ( ibfmg, 'MNTH' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                   Day:        ',
+     +                  IUPBS01 ( ibfmg, 'DAYS' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                  Hour:        ',
+     +                  IUPBS01 ( ibfmg, 'HOUR' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                Minute:        ',
+     +                  IUPBS01 ( ibfmg, 'MINU' )
+                WRITE ( 51, FMT= '( A, I4 )' )
+     +                 '                Second:        ',
+     +                  IUPBS01 ( ibfmg, 'SECO' )
+                IF ( ( iogce .eq. 7 ) .and. ( igses .eq. 3 ) ) THEN
+                    CALL RTRCPTB ( ibfmg, iryr, irmo, irdy, irhr,
+     +                             irmi, irtret )
+                    IF ( irtret .eq. 0 ) THEN
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                         '   NCEP tank rcpt year:        ', iryr
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                         '  NCEP tank rcpt month:        ', irmo
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                         '    NCEP tank rcpt day:        ', irdy
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                         '   NCEP tank rcpt hour:        ', irhr
+                        WRITE ( 51, FMT= '( A, I4 )' )
+     +                         ' NCEP tank rcpt minute:        ', irmi
+                    END IF
+                END IF
 
 C               Decode and output the data from Section 3.
 
-		nsub = IUPBS3 ( ibfmg, 'NSUB' )
-		WRITE ( 51, FMT= '( /, A, I4 )' )
-     +		       ' Number of data subsets:        ', nsub
-		nsubt = nsubt + nsub
- 
-		IF ( IUPBS3 ( ibfmg, 'IOBS' ) .eq. 1 ) THEN
-		    WRITE ( 51, FMT = '( A )')
-     +		       '     Data are observed?: Yes'
-		ELSE
-		    WRITE ( 51, FMT = '( A )')
-     +		       '     Data are observed?: No'
-		ENDIF
- 
-		IF ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 1 ) THEN
-		    WRITE ( 51, FMT = '( A )')
-     +		       '   Data are compressed?: Yes'
-		ELSE
-		    WRITE ( 51, FMT = '( A )')
-     +		       '   Data are compressed?: No'
-		ENDIF
- 
-		CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 )
-		WRITE ( 51, FMT= '( A, I5 )' )
-     +		       '  Number of descriptors:       ', nds3
-		DO jj = 1, nds3
-		    WRITE ( 51, FMT = '( 5X, I4, A, A6)' )
-     +			jj, ": ", cds3 ( jj )
-		END DO
-
-		IF (  ( basic .eq. 'N' ) .and.
-     +		     ( ierme .ge. 0 )  ) THEN
-
-C		    Decode and output the data from Section 4.
-
-		    WRITE ( UNIT = 51,
-     +			    FMT = '( /, A, I7, 3A, I10, A, I6, A )' )
-     +			'BUFR message #', nmsg, ' of type ', cmgtag,
-     +			' and date ', imgdt, ' contains ', nsub,
-     +			' subsets:'
-		    DO WHILE ( IREADSB ( lunit ) .eq. 0 )
-			CALL UFDUMP ( lunit, 51 )
-		    ENDDO
-		ENDIF
-
-		WRITE  ( UNIT = 51, FMT = '( /, A, I7 )' )
-     +		    'End of BUFR message #', nmsg
-		WRITE  ( UNIT = 51, FMT = '( /, 120("-"))' )
-	    ENDIF
-
-	ENDDO
-
-	RETURN
-	END
+                nsub = IUPBS3 ( ibfmg, 'NSUB' )
+                WRITE ( 51, FMT= '( /, A, I4 )' )
+     +                 ' Number of data subsets:        ', nsub
+                nsubt = nsubt + nsub
+
+                IF ( IUPBS3 ( ibfmg, 'IOBS' ) .eq. 1 ) THEN
+                    WRITE ( 51, FMT = '( A )')
+     +                 '     Data are observed?: Yes'
+                ELSE
+                    WRITE ( 51, FMT = '( A )')
+     +                 '     Data are observed?: No'
+                ENDIF
+
+                IF ( IUPBS3 ( ibfmg, 'ICMP' ) .eq. 1 ) THEN
+                    WRITE ( 51, FMT = '( A )')
+     +                 '   Data are compressed?: Yes'
+                ELSE
+                    WRITE ( 51, FMT = '( A )')
+     +                 '   Data are compressed?: No'
+                ENDIF
+
+                CALL UPDS3 ( ibfmg, MXDS3, cds3, nds3 )
+                WRITE ( 51, FMT= '( A, I5 )' )
+     +                 '  Number of descriptors:       ', nds3
+                DO jj = 1, nds3
+                    WRITE ( 51, FMT = '( 5X, I4, A, A6)' )
+     +                  jj, ": ", cds3 ( jj )
+                END DO
+
+                IF (  ( basic .eq. 'N' ) .and.
+     +               ( ierme .ge. 0 )  ) THEN
+
+C                   Decode and output the data from Section 4.
+
+                    WRITE ( UNIT = 51,
+     +                      FMT = '( /, A, I7, 3A, I10, A, I6, A )' )
+     +                  'BUFR message #', nmsg, ' of type ', cmgtag,
+     +                  ' and date ', imgdt, ' contains ', nsub,
+     +                  ' subsets:'
+                    DO WHILE ( IREADSB ( lunit ) .eq. 0 )
+                        CALL UFDUMP ( lunit, 51 )
+                    ENDDO
+                ENDIF
+
+                WRITE  ( UNIT = 51, FMT = '( /, A, I7 )' )
+     +              'End of BUFR message #', nmsg
+                WRITE  ( UNIT = 51, FMT = '( /, 120("-"))' )
+            ENDIF
+
+        ENDDO
+
+        RETURN
+        END
 
 C> This subroutine overrides the placeholder subroutine of the same
 C> name within the BUFRLIB distribution package.
@@ -494,30 +494,30 @@ SUBROUTINE FDEBUFR ( ofile, tbldir, lentd, tblfil, prmstg,
 C> | -----|------------|----------|
 C> | 2012-12-07 | J. Ator | Original author |
 C>
-	SUBROUTINE OPENBT ( lundx, mtyp )
+        SUBROUTINE OPENBT ( lundx, mtyp )
 
-	USE Share_Table_Info
+        USE Share_Table_Info
 
-	CHARACTER*11	bftab
+        CHARACTER*11    bftab
 
-	CHARACTER*240	bftabfil
+        CHARACTER*240   bftabfil
 
-	LOGICAL		exists
+        LOGICAL         exists
 
 C-----------------------------------------------------------------------
 C-----------------------------------------------------------------------
 
-	WRITE ( bftab, '("bufrtab.",i3.3)' ) mtyp
-	bftabfil = ctbldir(1:ltbd) // '/' // bftab
+        WRITE ( bftab, '("bufrtab.",i3.3)' ) mtyp
+        bftabfil = ctbldir(1:ltbd) // '/' // bftab
 
-	INQUIRE ( FILE = bftabfil, EXIST = exists )
-	IF ( exists ) THEN
-	    lundx = ludx
-	    CLOSE ( lundx )
-	    OPEN ( UNIT = lundx, FILE = bftabfil )
-	ELSE
-	    lundx = 0
-	END IF
+        INQUIRE ( FILE = bftabfil, EXIST = exists )
+        IF ( exists ) THEN
+            lundx = ludx
+            CLOSE ( lundx )
+            OPEN ( UNIT = lundx, FILE = bftabfil )
+        ELSE
+            lundx = 0
+        END IF
 
-	RETURN
-	END
+        RETURN
+        END
diff --git a/utils/gettab.f90 b/utils/gettab.f90
index 7cbb0952..7a40b866 100644
--- a/utils/gettab.f90
+++ b/utils/gettab.f90
@@ -20,10 +20,10 @@ program gettab
 
 ! get the filename to open and read
 
-  call getarg(1,file); file=trim(adjustl(file)) 
+  call getarg(1,file); file=trim(adjustl(file))
   if (file == '') call bort('Usage: "gettab bufrfile" will print the internal BUFR table')
   inquire(file=file,exist=exist)
-  if (.not.exist) call bort(trim(file)//' does not exist') 
+  if (.not.exist) call bort(trim(file)//' does not exist')
 
 ! open the file and dump the bufr table to standard outout
 
diff --git a/utils/readbp.f90 b/utils/readbp.f90
index 99e62b16..14e401dd 100644
--- a/utils/readbp.f90
+++ b/utils/readbp.f90
@@ -5,7 +5,7 @@
 !> @author J. Woollen @date 1994-01-06
 
 !> Read PREPBUFR file containing embedded DX BUFR tables,
-!> and print each report one at a time. Options are listed 
+!> and print each report one at a time. Options are listed
 !> by running "readbp" without argumets.
 !>
 !> @return 0 for success, error code otherwise.
@@ -118,10 +118,10 @@ PROGRAM READBP
 ! check if file exists, then open it, else abort
 
       narg=0
-      if(file=='nofile') goto 1 
-      file = trim(adjustl(file)) 
+      if(file=='nofile') goto 1
+      file = trim(adjustl(file))
       inquire(file=file,exist=exist)
-      if (.not.exist) call bort(trim(file)//' does not exist') 
+      if (.not.exist) call bort(trim(file)//' does not exist')
 
 !  open the bufr input file
 !  ------------------------
@@ -255,9 +255,9 @@ PROGRAM READBP
       subroutine printx(str)
       character(*) :: str
       lens=len(str)
-      do i=1,lens-1             
-      write(*,'(a1)',advance="no")str(i:i)  
+      do i=1,lens-1
+      write(*,'(a1)',advance="no")str(i:i)
       enddo
-      write(*,'(a1)')str(lens:lens)  
+      write(*,'(a1)')str(lens:lens)
       end subroutine
 
diff --git a/utils/readmp.f90 b/utils/readmp.f90
index aa79ad17..3d482236 100644
--- a/utils/readmp.f90
+++ b/utils/readmp.f90
@@ -15,18 +15,18 @@ program readmp
   implicit none
 
   character(255)     :: file        !> name of filename to read
-  character(8)       :: subset      
-  character(1)       :: go          
+  character(8)       :: subset
+  character(1)       :: go
   integer, parameter :: lunit = 20
   integer            :: idate,ireadmg,ireadsb,i4dy
   logical            :: exist
 
 ! get the filename to open and read
 
-  call getarg(1,file); file=trim(adjustl(file)) 
+  call getarg(1,file); file=trim(adjustl(file))
   if (file == '') call bort('Usage: "gettab bufrfile" will print the internal BUFR table')
   inquire(file=file,exist=exist)
-  if (.not.exist) call bort(trim(file)//' does not exist') 
+  if (.not.exist) call bort(trim(file)//' does not exist')
   call getarg(2,go); go=trim(adjustl(go)) ! this for testing !
   open(lunit,file=file,form='unformatted')
 
@@ -42,4 +42,4 @@ program readmp
   enddo
   enddo
 
-  end program readmp 
+  end program readmp
diff --git a/utils/split_by_subset.f90 b/utils/split_by_subset.f90
index e4193aa3..0c2de07e 100644
--- a/utils/split_by_subset.f90
+++ b/utils/split_by_subset.f90
@@ -38,7 +38,7 @@ program split_by_subset
         open(lunit, file=trim(adjustl(finput)), form='unformatted')
         call openbf(lunit,'IN',lunit)
      else
-        call bort('File ' // trim(adjustl(finput)) // ' does not exist')       
+        call bort('File ' // trim(adjustl(finput)) // ' does not exist')
      endif
   else
      call bort('Usage: "split_by_subset bufrfile" will split a BUFR file into subsets')
diff --git a/utils/xbfmg.c b/utils/xbfmg.c
index 21235c5c..d3d62437 100644
--- a/utils/xbfmg.c
+++ b/utils/xbfmg.c
@@ -2,9 +2,9 @@
  *  @brief Split a BUFR file into separate BUFR files by message.
  *
  * ### Program History Log
- * Date | Programmer | Comments 
+ * Date | Programmer | Comments
  * -----|------------|----------
- * 2018-03-01 | J. Ator | Original author. 
+ * 2018-03-01 | J. Ator | Original author.
  * 2021-09-29 | J. Ator |  Use basename instead of pid in output filenames.
  * 2021-10-08 | J. Ator |  Simplify bvstr instantiation and initialization.
  *
@@ -27,33 +27,33 @@ void prtusage( char *prgnam );
 
 /**
  * This function prints program usage information to standard output.
- *   
+ *
  * @param prgnam - [path/]name of program executable.
  *
  * @author J. Ator @date 2018-03-01
  */
 void prtusage( char *prgnam ) {
-	printf( "\nUSAGE: %s [-v] [-h] [-g] bufrfile\n\n", prgnam );
-	printf( "WHERE:\n" );
-	printf( "    -v        prints program version information and exits\n" );
-	printf( "    -h        prints program help and usage information and exits\n" );
-	printf( "    -g        preserves within each output file any GTS bulletin header and\n" );
-	printf( "              control characters associated with the corresponding BUFR message\n" );
-	printf( "              from the input file\n" );
-	printf( "   bufrfile   [path/]name of input file containing one or more BUFR messages\n" );
-	printf( "              to be extracted into separate output files within the current\n" );
-	printf( "              working directory\n\n" );
-	printf( "The output will be stored within the current working directory using the\n" );
-	printf( "following filenames:\n\n" );
-	printf( "    (basename).xbfmg.out.000001\n" );
-	printf( "    (basename).xbfmg.out.000002\n" );
-	printf( "    (basename).xbfmg.out.000003\n" );
-	printf( "      .\n" );
-	printf( "      .\n" );
-	printf( "    (basename).xbfmg.out.(last#)\n\n" );
-	printf( "where:\n\n" );
-	printf( "    (basename) = basename of bufrfile\n" );
-	printf( "    (last#) = total number of BUFR messages in bufrfile\n\n" );
+        printf( "\nUSAGE: %s [-v] [-h] [-g] bufrfile\n\n", prgnam );
+        printf( "WHERE:\n" );
+        printf( "    -v        prints program version information and exits\n" );
+        printf( "    -h        prints program help and usage information and exits\n" );
+        printf( "    -g        preserves within each output file any GTS bulletin header and\n" );
+        printf( "              control characters associated with the corresponding BUFR message\n" );
+        printf( "              from the input file\n" );
+        printf( "   bufrfile   [path/]name of input file containing one or more BUFR messages\n" );
+        printf( "              to be extracted into separate output files within the current\n" );
+        printf( "              working directory\n\n" );
+        printf( "The output will be stored within the current working directory using the\n" );
+        printf( "following filenames:\n\n" );
+        printf( "    (basename).xbfmg.out.000001\n" );
+        printf( "    (basename).xbfmg.out.000002\n" );
+        printf( "    (basename).xbfmg.out.000003\n" );
+        printf( "      .\n" );
+        printf( "      .\n" );
+        printf( "    (basename).xbfmg.out.(last#)\n\n" );
+        printf( "where:\n\n" );
+        printf( "    (basename) = basename of bufrfile\n" );
+        printf( "    (last#) = total number of BUFR messages in bufrfile\n\n" );
 }
 
 /**
@@ -106,41 +106,41 @@ void prtusage( char *prgnam ) {
 
 int main( int argc, char *argv[] ) {
 
-	struct stat fileinfo;
+        struct stat fileinfo;
 
-	char *pc, *pmsg, *psb;
+        char *pc, *pmsg, *psb;
 
-	int save_GTSbull = 0;
+        int save_GTSbull = 0;
 
-	char outfile[MXFLEN];
-	char outfile_temp[MXFLEN];
-	char wkstr[MXFLEN];
+        char outfile[MXFLEN];
+        char outfile_temp[MXFLEN];
+        char wkstr[MXFLEN];
 
-	char *bvstr;
+        char *bvstr;
 
-	int ch;
+        int ch;
 
-	FILE *fp;
+        FILE *fp;
 
-	f77int msglen, wkint;
-	f77int c24 = 24, c1 = 1;
+        f77int msglen, wkint;
+        f77int c24 = 24, c1 = 1;
 
-	unsigned long i, filesize, noutfile;
+        unsigned long i, filesize, noutfile;
 
-	/*
-	**  Get the valid options from the command line:
-	*/
+        /*
+        **  Get the valid options from the command line:
+        */
         while ( ( ch = getopt ( argc, argv, "vgh" ) ) != EOF ) {
             switch ( ch ) {
-		case 'v':
-		    bvstr = ( char * ) calloc( 9, sizeof(char) );  /* allocate bvstr and initialize to all nulls */
-		    bvers( bvstr, sizeof(bvstr) );
-		    printf( "This is xbfmg v3.2.0, built with BUFRLIB v%s\n", bvstr );
-		    return 0;
-		case 'g':
-		    save_GTSbull = 1;
-		    break;
-		case 'h':
+                case 'v':
+                    bvstr = ( char * ) calloc( 9, sizeof(char) );  /* allocate bvstr and initialize to all nulls */
+                    bvers( bvstr, sizeof(bvstr) );
+                    printf( "This is xbfmg v3.2.0, built with BUFRLIB v%s\n", bvstr );
+                    return 0;
+                case 'g':
+                    save_GTSbull = 1;
+                    break;
+                case 'h':
                     printf( "\nPROGRAM %s\n", argv[0] );
                     printf( "\nABSTRACT: This program reads an input file containing one or more\n" );
                     printf( "  BUFR messages as given by the first argument.  It then extracts each\n" );
@@ -152,131 +152,131 @@ int main( int argc, char *argv[] ) {
             }
         }
 
-	/*
-	**  There should be one remaining command line argument specifying the input file.
-	*/
-	if ( (optind+1) != argc ) {
-	    printf( "\nERROR: You must specify an input BUFR file of BUFR messages!\n" );
+        /*
+        **  There should be one remaining command line argument specifying the input file.
+        */
+        if ( (optind+1) != argc ) {
+            printf( "\nERROR: You must specify an input BUFR file of BUFR messages!\n" );
             prtusage( argv[0] );
-	    return -1;
-	}
+            return -1;
+        }
 
-	/*
-	**  Get the filesize of the input file.
-	*/
-	if ( stat( argv[optind], &fileinfo ) != 0 ) {
-	    printf( "\nERROR: Could not stat the file %s!\n", argv[optind] );
-	    return -1;
-	}
-	filesize = fileinfo.st_size;
+        /*
+        **  Get the filesize of the input file.
+        */
+        if ( stat( argv[optind], &fileinfo ) != 0 ) {
+            printf( "\nERROR: Could not stat the file %s!\n", argv[optind] );
+            return -1;
+        }
+        filesize = fileinfo.st_size;
 
-	/*
-	**  Dynamically allocate memory in order to read in the input file.
-	*/
-	if ( ( pc = malloc( filesize + 1 ) ) == NULL ) {
-	    printf( "\nERROR: Could not allocate memory for file %s!\n", argv[optind] );
-	    return -1;
-	}
+        /*
+        **  Dynamically allocate memory in order to read in the input file.
+        */
+        if ( ( pc = malloc( filesize + 1 ) ) == NULL ) {
+            printf( "\nERROR: Could not allocate memory for file %s!\n", argv[optind] );
+            return -1;
+        }
 
-	/*
-	**  Read the input file into memory.
-	*/
-	if ( ( fp = fopen( argv[optind], "rb" ) ) == NULL ) {
-	    printf( "\nERROR: Could not open input file %s!\n", argv[optind] );
-	    return -1;
-	}
-	for ( i = 0; i < filesize; i++ ) {
-	    pc[i] = (char) fgetc( fp );
-	} 
-	pc[i] = '\0';
-	fclose( fp );
+        /*
+        **  Read the input file into memory.
+        */
+        if ( ( fp = fopen( argv[optind], "rb" ) ) == NULL ) {
+            printf( "\nERROR: Could not open input file %s!\n", argv[optind] );
+            return -1;
+        }
+        for ( i = 0; i < filesize; i++ ) {
+            pc[i] = (char) fgetc( fp );
+        }
+        pc[i] = '\0';
+        fclose( fp );
 
-	/*
-	**  Create an output file name template.
-	*/
-	strcpy( wkstr, argv[optind] );
-	strcpy( outfile_temp, basename( wkstr ) );
-	strcat( outfile_temp, ".xbfmg.out" );
+        /*
+        **  Create an output file name template.
+        */
+        strcpy( wkstr, argv[optind] );
+        strcpy( outfile_temp, basename( wkstr ) );
+        strcat( outfile_temp, ".xbfmg.out" );
 
-	/*
-	**  Call wrdlen function to initialize BUFRLIB and determine machine endianness.
-	*/
-	wrdlen( );
+        /*
+        **  Call wrdlen function to initialize BUFRLIB and determine machine endianness.
+        */
+        wrdlen( );
 
-	/*
-	**  Locate each BUFR message within the input file and write each one to a separate output file.
-	**
-	**  Note that we can't use the intrinsic C strstr function to locate the "BUFR" and "7777"
-	**  strings within the file, because the file could contain embedded NULL characters.
-	*/
-	noutfile = 0;
-	pmsg = psb = pc;
-	while ( 1 ) {
-	    while (  ( ( pmsg - pc + 4 ) < filesize )  &&
-		    ( ( *(pmsg)     != 'B' )  ||
-		      ( *(pmsg + 1) != 'U' )  || 
-		      ( *(pmsg + 2) != 'F' )  ||
-		      ( *(pmsg + 3) != 'R' ) )  )  {
-		if ( *pmsg == '\x01' ) psb = pmsg;
-		pmsg++;
-	    }
-	    if  ( ( pmsg - pc + 4 ) >= filesize )  {
-		free( pc );
-		return 0;
-	    }
+        /*
+        **  Locate each BUFR message within the input file and write each one to a separate output file.
+        **
+        **  Note that we can't use the intrinsic C strstr function to locate the "BUFR" and "7777"
+        **  strings within the file, because the file could contain embedded NULL characters.
+        */
+        noutfile = 0;
+        pmsg = psb = pc;
+        while ( 1 ) {
+            while (  ( ( pmsg - pc + 4 ) < filesize )  &&
+                    ( ( *(pmsg)     != 'B' )  ||
+                      ( *(pmsg + 1) != 'U' )  ||
+                      ( *(pmsg + 2) != 'F' )  ||
+                      ( *(pmsg + 3) != 'R' ) )  )  {
+                if ( *pmsg == '\x01' ) psb = pmsg;
+                pmsg++;
+            }
+            if  ( ( pmsg - pc + 4 ) >= filesize )  {
+                free( pc );
+                return 0;
+            }
 
-	    /*
-	    **  Open a new output file for this message.
-	    */
-	    sprintf( outfile, "%s.%06lu", outfile_temp, ++noutfile );
-	    if ( ( fp = fopen( outfile, "wb" ) ) == NULL ) {
-		printf( "\nERROR: Could not open output file %s!\n", outfile );
-		return -1;
-	    }
+            /*
+            **  Open a new output file for this message.
+            */
+            sprintf( outfile, "%s.%06lu", outfile_temp, ++noutfile );
+            if ( ( fp = fopen( outfile, "wb" ) ) == NULL ) {
+                printf( "\nERROR: Could not open output file %s!\n", outfile );
+                return -1;
+            }
 
-	    /*
-	    **  If requested, write the preceding GTS bulletin information to the output file.
-	    */
-	    if ( save_GTSbull ) {
-		while ( psb < pmsg ) {
-		    fputc( *psb++, fp );
-		}
-	    }
+            /*
+            **  If requested, write the preceding GTS bulletin information to the output file.
+            */
+            if ( save_GTSbull ) {
+                while ( psb < pmsg ) {
+                    fputc( *psb++, fp );
+                }
+            }
 
-	    /*
-	    **  Read the BUFR message length from Section 0.
-	    */
-	    memcpy( &wkint, ( pmsg + 4 ), 3 );
-	    msglen = iupb( &wkint, &c1, &c24 );
+            /*
+            **  Read the BUFR message length from Section 0.
+            */
+            memcpy( &wkint, ( pmsg + 4 ), 3 );
+            msglen = iupb( &wkint, &c1, &c24 );
 
-	    /*
-	    **  Write the BUFR message to the output file.
-	    */
-	    if  ( ( pmsg + msglen - pc - 1 ) <= filesize ) {
-		for ( i = 1; i <= msglen; i++ ) {
-		    fputc( *pmsg++, fp );
-		}
-	    }
+            /*
+            **  Write the BUFR message to the output file.
+            */
+            if  ( ( pmsg + msglen - pc - 1 ) <= filesize ) {
+                for ( i = 1; i <= msglen; i++ ) {
+                    fputc( *pmsg++, fp );
+                }
+            }
 
-	    /*
-	    **  Make sure that the "7777" indicator is in the expected place.
-	    */
-	    if ( ( *(pmsg - 4) != '7' ) || ( *(pmsg - 3) != '7' ) || 
-	         ( *(pmsg - 2) != '7' ) || ( *(pmsg - 1) != '7' ) )  {
-	        printf( "\nERROR: Could not find 7777 indicator in output file %s!\n",
-			outfile );
-	    }
+            /*
+            **  Make sure that the "7777" indicator is in the expected place.
+            */
+            if ( ( *(pmsg - 4) != '7' ) || ( *(pmsg - 3) != '7' ) ||
+                 ( *(pmsg - 2) != '7' ) || ( *(pmsg - 1) != '7' ) )  {
+                printf( "\nERROR: Could not find 7777 indicator in output file %s!\n",
+                        outfile );
+            }
 
-	    /*
-	    **  If requested, append GTS bulletin tail markers to the output file.
-	    */
-	    if ( save_GTSbull ) {
-		fputc( '\x0d', fp );
-		fputc( '\x0d', fp );
-		fputc( '\x0a', fp );
-		fputc( '\x03', fp );
-	    }
+            /*
+            **  If requested, append GTS bulletin tail markers to the output file.
+            */
+            if ( save_GTSbull ) {
+                fputc( '\x0d', fp );
+                fputc( '\x0d', fp );
+                fputc( '\x0a', fp );
+                fputc( '\x03', fp );
+            }
 
-	    fclose( fp );
-	}	
+            fclose( fp );
+        }
 }