diff --git a/src/arallocf.F90 b/src/arallocf.F90 index 38ec3a39..3272da16 100644 --- a/src/arallocf.F90 +++ b/src/arallocf.F90 @@ -67,7 +67,7 @@ subroutine arallocf common /quiet/ iprt - if ( iprt .ge. 1 ) then + if ( iprt >= 1 ) then call errwrt ('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt ('BUFRLIB: ARRAYS WILL BE DYNAMICALLY ALLOCATED USING THE FOLLOWING VALUES:') write ( errstr, '(a,i7)' ) ' MAXSS = ', maxss @@ -130,106 +130,106 @@ subroutine arallocf ! moda_usrint arrays. allocate( nval(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NVAL' ) + if ( iost /= 0 ) call bort( brtstr // 'NVAL' ) allocate( inv(maxss,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'INV' ) + if ( iost /= 0 ) call bort( brtstr // 'INV' ) allocate( nrfelm(maxss,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NRFELM' ) + if ( iost /= 0 ) call bort( brtstr // 'NRFELM' ) allocate( val(maxss,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'VAL' ) + if ( iost /= 0 ) call bort( brtstr // 'VAL' ) ! moda_usrbit arrays. allocate( nbit(maxss), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NBIT' ) + if ( iost /= 0 ) call bort( brtstr // 'NBIT' ) allocate( mbit(maxss), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MBIT' ) + if ( iost /= 0 ) call bort( brtstr // 'MBIT' ) ! moda_ival arrays. allocate( ival(maxss), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IVAL' ) + if ( iost /= 0 ) call bort( brtstr // 'IVAL' ) ! moda_msgcwd arrays. allocate( nmsg(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NMSG' ) + if ( iost /= 0 ) call bort( brtstr // 'NMSG' ) allocate( nsub(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NSUB' ) + if ( iost /= 0 ) call bort( brtstr // 'NSUB' ) allocate( msub(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSUB' ) + if ( iost /= 0 ) call bort( brtstr // 'MSUB' ) allocate( inode(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'INODE' ) + if ( iost /= 0 ) call bort( brtstr // 'INODE' ) allocate( idate(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDATE' ) + if ( iost /= 0 ) call bort( brtstr // 'IDATE' ) ! moda_stbfr arrays. allocate( iolun(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IOLUN' ) + if ( iost /= 0 ) call bort( brtstr // 'IOLUN' ) allocate( iomsg(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IOMSG' ) + if ( iost /= 0 ) call bort( brtstr // 'IOMSG' ) ! moda_ufbcpl arrays. allocate( luncpy(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'LUNCPY' ) + if ( iost /= 0 ) call bort( brtstr // 'LUNCPY' ) ! moda_sc3bfr arrays. allocate( isc3(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISC3' ) + if ( iost /= 0 ) call bort( brtstr // 'ISC3' ) allocate( tamnem(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TAMNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'TAMNEM' ) ! moda_unptyp arrays. allocate( msgunp(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGUNP' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGUNP' ) ! moda_lushr arrays. allocate( lus(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'LUS' ) + if ( iost /= 0 ) call bort( brtstr // 'LUS' ) ! moda_nulbfr arrays. allocate( null(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NULL' ) + if ( iost /= 0 ) call bort( brtstr // 'NULL' ) ! moda_stcode arrays. allocate( iscodes(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISCODES' ) + if ( iost /= 0 ) call bort( brtstr // 'ISCODES' ) ! moda_idrdm arrays. allocate( idrdm(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDRDM' ) + if ( iost /= 0 ) call bort( brtstr // 'IDRDM' ) ! moda_xtab arrays. allocate( xtab(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'XTAB' ) + if ( iost /= 0 ) call bort( brtstr // 'XTAB' ) ! moda_msglim arrays. allocate( msglim(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGLIM' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGLIM' ) ! Calculate mxmsgld4 from mxmsgl. - if ( mod(mxmsgl,4) .eq. 0 ) then + if ( mod(mxmsgl,4) == 0 ) then mxmsgld4 = mxmsgl/4 else mxmsgld4 = mxmsgl/4 + 1 @@ -238,38 +238,38 @@ subroutine arallocf ! moda_bitbuf arrays. allocate( ibay(mxmsgld4), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IBAY' ) + if ( iost /= 0 ) call bort( brtstr // 'IBAY' ) allocate( mbyt(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MBYT' ) + if ( iost /= 0 ) call bort( brtstr // 'MBYT' ) allocate( mbay(mxmsgld4,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MBAY' ) + if ( iost /= 0 ) call bort( brtstr // 'MBAY' ) ! moda_mgwa arrays. allocate( mgwa(mxmsgld4), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MGWA' ) + if ( iost /= 0 ) call bort( brtstr // 'MGWA' ) ! moda_mgwb arrays. allocate( mgwb(mxmsgld4), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MGWB' ) + if ( iost /= 0 ) call bort( brtstr // 'MGWB' ) ! moda_bufrmg arrays. allocate( msglen(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGLEN' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGLEN' ) allocate( msgtxt(mxmsgld4,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGTXT' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGTXT' ) ! moda_bufrsr arrays. allocate( jsr(nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JSR' ) + if ( iost /= 0 ) call bort( brtstr // 'JSR' ) allocate( jbay(mxmsgld4), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JBAY' ) + if ( iost /= 0 ) call bort( brtstr // 'JBAY' ) ! Calculate mxdxm and mxdxw from mxdxts and mxmsgld4. @@ -279,309 +279,309 @@ subroutine arallocf ! moda_msgmem arrays. allocate( msgp(0:maxmsg), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGP' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGP' ) allocate( msgs(maxmem), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MSGS' ) + if ( iost /= 0 ) call bort( brtstr // 'MSGS' ) allocate( mdx(mxdxw), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MDX' ) + if ( iost /= 0 ) call bort( brtstr // 'MDX' ) allocate( ipdxm(mxdxm), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IPDXM' ) + if ( iost /= 0 ) call bort( brtstr // 'IPDXM' ) allocate( ifdxts(mxdxts), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ifDXTS' ) + if ( iost /= 0 ) call bort( brtstr // 'ifDXTS' ) allocate( icdxts(mxdxts), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ICDXTS' ) + if ( iost /= 0 ) call bort( brtstr // 'ICDXTS' ) allocate( ipmsgs(mxdxts), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IPMSGS' ) + if ( iost /= 0 ) call bort( brtstr // 'IPMSGS' ) ! moda_tababd arrays. allocate( ntba(0:nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NTBA' ) + if ( iost /= 0 ) call bort( brtstr // 'NTBA' ) allocate( ntbb(0:nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NTBB' ) + if ( iost /= 0 ) call bort( brtstr // 'NTBB' ) allocate( ntbd(0:nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NTBD' ) + if ( iost /= 0 ) call bort( brtstr // 'NTBD' ) allocate( mtab(maxtba,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MTAB' ) + if ( iost /= 0 ) call bort( brtstr // 'MTAB' ) allocate( idna(maxtba,nfiles,2), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDNA' ) + if ( iost /= 0 ) call bort( brtstr // 'IDNA' ) allocate( idnb(maxtbb,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDNB' ) + if ( iost /= 0 ) call bort( brtstr // 'IDNB' ) allocate( idnd(maxtbd,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDND' ) + if ( iost /= 0 ) call bort( brtstr // 'IDND' ) allocate( taba(maxtba,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TABA' ) + if ( iost /= 0 ) call bort( brtstr // 'TABA' ) allocate( tabb(maxtbb,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TABB' ) + if ( iost /= 0 ) call bort( brtstr // 'TABB' ) allocate( tabd(maxtbd,nfiles), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TABD' ) + if ( iost /= 0 ) call bort( brtstr // 'TABD' ) ! moda_tables arrays. allocate( tag(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TAG' ) + if ( iost /= 0 ) call bort( brtstr // 'TAG' ) allocate( typ(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TYP' ) + if ( iost /= 0 ) call bort( brtstr // 'TYP' ) allocate( knt(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KNT' ) + if ( iost /= 0 ) call bort( brtstr // 'KNT' ) allocate( jump(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JUMP' ) + if ( iost /= 0 ) call bort( brtstr // 'JUMP' ) allocate( link(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'LINK' ) + if ( iost /= 0 ) call bort( brtstr // 'LINK' ) allocate( jmpb(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JMPB' ) + if ( iost /= 0 ) call bort( brtstr // 'JMPB' ) allocate( ibt(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IBT' ) + if ( iost /= 0 ) call bort( brtstr // 'IBT' ) allocate( irf(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IRF' ) + if ( iost /= 0 ) call bort( brtstr // 'IRF' ) allocate( isc(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISC' ) + if ( iost /= 0 ) call bort( brtstr // 'ISC' ) allocate( itp(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ITP' ) + if ( iost /= 0 ) call bort( brtstr // 'ITP' ) allocate( vali(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'VALI' ) + if ( iost /= 0 ) call bort( brtstr // 'VALI' ) allocate( knti(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KNTI' ) + if ( iost /= 0 ) call bort( brtstr // 'KNTI' ) allocate( iseq(maxjl,2), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISEQ' ) + if ( iost /= 0 ) call bort( brtstr // 'ISEQ' ) allocate( jseq(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JSEQ' ) + if ( iost /= 0 ) call bort( brtstr // 'JSEQ' ) ! moda_usrtmp arrays. allocate( iutmp(maxjl,maxrcr), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IUTMP' ) + if ( iost /= 0 ) call bort( brtstr // 'IUTMP' ) allocate( vutmp(maxjl,maxrcr), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'VUTMP' ) + if ( iost /= 0 ) call bort( brtstr // 'VUTMP' ) ! moda_ivttmp arrays. allocate( ttmp(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TTMP' ) + if ( iost /= 0 ) call bort( brtstr // 'TTMP' ) allocate( itmp(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ITMP' ) + if ( iost /= 0 ) call bort( brtstr // 'ITMP' ) allocate( vtmp(maxjl), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'VTMP' ) + if ( iost /= 0 ) call bort( brtstr // 'VTMP' ) ! moda_comprx arrays. allocate( kmin(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KMIN' ) + if ( iost /= 0 ) call bort( brtstr // 'KMIN' ) allocate( kmax(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KMAX' ) + if ( iost /= 0 ) call bort( brtstr // 'KMAX' ) allocate( kmis(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KMIS' ) + if ( iost /= 0 ) call bort( brtstr // 'KMIS' ) allocate( kbit(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KBIT' ) + if ( iost /= 0 ) call bort( brtstr // 'KBIT' ) allocate( ityp(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ITYP' ) + if ( iost /= 0 ) call bort( brtstr // 'ITYP' ) allocate( iwid(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IWID' ) + if ( iost /= 0 ) call bort( brtstr // 'IWID' ) allocate( character*(mxlcc) :: cstr(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CSTR' ) + if ( iost /= 0 ) call bort( brtstr // 'CSTR' ) allocate( jlnode(mxcdv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'JLNODE' ) + if ( iost /= 0 ) call bort( brtstr // 'JLNODE' ) ! moda_comprs arrays. allocate( matx(mxcdv,mxcsb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'MATX' ) + if ( iost /= 0 ) call bort( brtstr // 'MATX' ) allocate( character*(mxlcc) :: catx(mxcdv,mxcsb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CATX' ) + if ( iost /= 0 ) call bort( brtstr // 'CATX' ) ! moda_mstabs arrays. allocate( ibfxyn(mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IBFXYN' ) + if ( iost /= 0 ) call bort( brtstr // 'IBFXYN' ) allocate( cbscl(4,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBSCL' ) + if ( iost /= 0 ) call bort( brtstr // 'CBSCL' ) allocate( cbsref(12,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBSREF' ) + if ( iost /= 0 ) call bort( brtstr // 'CBSREF' ) allocate( cbbw(4,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBBW' ) + if ( iost /= 0 ) call bort( brtstr // 'CBBW' ) allocate( cbunit(24,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBUNIT' ) + if ( iost /= 0 ) call bort( brtstr // 'CBUNIT' ) allocate( cbmnem(8,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBMNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CBMNEM' ) allocate( cbelem(120,mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CBELEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CBELEM' ) allocate( idfxyn(mxmtbd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDFXYN' ) + if ( iost /= 0 ) call bort( brtstr // 'IDFXYN' ) allocate( cdseq(120,mxmtbd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CDSEQ' ) + if ( iost /= 0 ) call bort( brtstr // 'CDSEQ' ) allocate( cdmnem(8,mxmtbd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CDMNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CDMNEM' ) allocate( ndelem(mxmtbd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NDELEM' ) + if ( iost /= 0 ) call bort( brtstr // 'NDELEM' ) allocate( idefxy(mxmtbd*maxcd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDEFXY' ) + if ( iost /= 0 ) call bort( brtstr // 'IDEFXY' ) ! moda_rdmtb arrays. allocate( iefxyn(mxmtbd,maxcd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IEFXYN' ) + if ( iost /= 0 ) call bort( brtstr // 'IEFXYN' ) allocate( cmdscb(mxmtbb), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CMDSCB' ) + if ( iost /= 0 ) call bort( brtstr // 'CMDSCB' ) allocate( cmdscd(mxmtbd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CMDSCD' ) + if ( iost /= 0 ) call bort( brtstr // 'CMDSCD' ) allocate( ceelem(mxmtbd,maxcd), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CEELEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CEELEM' ) ! moda_nmikrp arrays. allocate( nem(maxcd,10), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NEM' ) + if ( iost /= 0 ) call bort( brtstr // 'NEM' ) allocate( irp(maxcd,10), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IRP' ) + if ( iost /= 0 ) call bort( brtstr // 'IRP' ) allocate( krp(maxcd,10), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'KRP' ) + if ( iost /= 0 ) call bort( brtstr // 'KRP' ) ! moda_s01cm arrays. allocate( ivmnem(mxs01v), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IVMNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'IVMNEM' ) allocate( cmnem(mxs01v), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CMNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CMNEM' ) ! moda_bitmaps arrays. allocate( inodtamc(mxtamc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'INODTAMC' ) + if ( iost /= 0 ) call bort( brtstr // 'INODTAMC' ) allocate( ntco(mxtamc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NTCO' ) + if ( iost /= 0 ) call bort( brtstr // 'NTCO' ) allocate( ctco(mxtamc,mxtco), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CTCO' ) + if ( iost /= 0 ) call bort( brtstr // 'CTCO' ) allocate( inodtco(mxtamc,mxtco), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'INODTCO' ) + if ( iost /= 0 ) call bort( brtstr // 'INODTCO' ) allocate( nbtmse(mxbtm), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NBTMSE' ) + if ( iost /= 0 ) call bort( brtstr // 'NBTMSE' ) allocate( istbtm(mxbtm), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISTBTM' ) + if ( iost /= 0 ) call bort( brtstr // 'ISTBTM' ) allocate( iszbtm(mxbtm), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISZBTM' ) + if ( iost /= 0 ) call bort( brtstr // 'ISZBTM' ) allocate( ibtmse(mxbtm,mxbtmse), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IBTMSE' ) + if ( iost /= 0 ) call bort( brtstr // 'IBTMSE' ) ! moda_nrv203 arrays. allocate( tagnrv(mxnrv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'TAGNRV' ) + if ( iost /= 0 ) call bort( brtstr // 'TAGNRV' ) allocate( inodnrv(mxnrv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'INODNRV' ) + if ( iost /= 0 ) call bort( brtstr // 'INODNRV' ) allocate( nrv(mxnrv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NRV' ) + if ( iost /= 0 ) call bort( brtstr // 'NRV' ) allocate( isnrv(mxnrv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'ISNRV' ) + if ( iost /= 0 ) call bort( brtstr // 'ISNRV' ) allocate( ienrv(mxnrv), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IENRV' ) + if ( iost /= 0 ) call bort( brtstr // 'IENRV' ) ! moda_rlccmn arrays. allocate( irnch(mxrst), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IRNCH' ) + if ( iost /= 0 ) call bort( brtstr // 'IRNCH' ) allocate( irbit(mxrst), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IRBIT' ) + if ( iost /= 0 ) call bort( brtstr // 'IRBIT' ) allocate( crtag(mxrst), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CRTAG' ) + if ( iost /= 0 ) call bort( brtstr // 'CRTAG' ) ! moda_h4wlc arrays. allocate( luh4wlc(mxh4wlc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'LUH4WLC' ) + if ( iost /= 0 ) call bort( brtstr // 'LUH4WLC' ) allocate( sth4wlc(mxh4wlc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'STH4WLC' ) + if ( iost /= 0 ) call bort( brtstr // 'STH4WLC' ) allocate( chh4wlc(mxh4wlc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CHH4WLC' ) + if ( iost /= 0 ) call bort( brtstr // 'CHH4WLC' ) ! moda_dscach arrays. allocate( cnem(mxcnem), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CNEM' ) + if ( iost /= 0 ) call bort( brtstr // 'CNEM' ) allocate( ndc(mxcnem), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'NDC' ) + if ( iost /= 0 ) call bort( brtstr // 'NDC' ) allocate( idcach(mxcnem,maxnc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDCACH' ) + if ( iost /= 0 ) call bort( brtstr // 'IDCACH' ) ! moda_s3list arrays. allocate( ids3(maxnc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'IDS3' ) + if ( iost /= 0 ) call bort( brtstr // 'IDS3' ) allocate( cds3(maxnc), stat=iost ) - if ( iost .ne. 0 ) call bort( brtstr // 'CDS3' ) + if ( iost /= 0 ) call bort( brtstr // 'CDS3' ) return end subroutine arallocf @@ -910,14 +910,14 @@ subroutine exitbufr ! Close any logical units that are open to the library. do jj = 1, nfiles - if ( iolun(jj) .ne. 0 ) call closbf( abs(iolun(jj)) ) + if ( iolun(jj) /= 0 ) call closbf( abs(iolun(jj)) ) end do ! Deallocate all allocated memory. call ardllocf - if ( cdmf .eq. 'Y' ) call dlloctbf_c + if ( cdmf == 'Y' ) call dlloctbf_c ! Reset the library. @@ -1005,61 +1005,61 @@ recursive integer function isetprm ( cprmnm, ipval ) result ( iret ) endif iret = 0 - if ( cprmnm .eq. 'MAXSS' ) then + if ( cprmnm == 'MAXSS' ) then maxss = ipval - else if ( cprmnm .eq. 'NFILES' ) then + else if ( cprmnm == 'NFILES' ) then nfiles = ipval - else if ( cprmnm .eq. 'MXMSGL' ) then + else if ( cprmnm == 'MXMSGL' ) then mxmsgl = ipval - else if ( cprmnm .eq. 'MXDXTS' ) then + else if ( cprmnm == 'MXDXTS' ) then mxdxts = ipval - else if ( cprmnm .eq. 'MAXMSG' ) then + else if ( cprmnm == 'MAXMSG' ) then maxmsg = ipval - else if ( cprmnm .eq. 'MAXMEM' ) then + else if ( cprmnm == 'MAXMEM' ) then maxmem = ipval - else if ( cprmnm .eq. 'MAXTBA' ) then + else if ( cprmnm == 'MAXTBA' ) then maxtba = ipval - else if ( cprmnm .eq. 'MAXTBB' ) then + else if ( cprmnm == 'MAXTBB' ) then maxtbb = ipval - else if ( cprmnm .eq. 'MAXTBD' ) then + else if ( cprmnm == 'MAXTBD' ) then maxtbd = ipval - else if ( cprmnm .eq. 'MAXJL' ) then + else if ( cprmnm == 'MAXJL' ) then maxjl = ipval - else if ( cprmnm .eq. 'MXCDV' ) then + else if ( cprmnm == 'MXCDV' ) then mxcdv = ipval - else if ( cprmnm .eq. 'MXLCC' ) then + else if ( cprmnm == 'MXLCC' ) then mxlcc = ipval - else if ( cprmnm .eq. 'MXCSB' ) then + else if ( cprmnm == 'MXCSB' ) then mxcsb = ipval - else if ( cprmnm .eq. 'MXMTBB' ) then + else if ( cprmnm == 'MXMTBB' ) then mxmtbb = ipval - else if ( cprmnm .eq. 'MXMTBD' ) then + else if ( cprmnm == 'MXMTBD' ) then mxmtbd = ipval - else if ( cprmnm .eq. 'MXMTBF' ) then + else if ( cprmnm == 'MXMTBF' ) then mxmtbf = ipval - else if ( cprmnm .eq. 'MAXCD' ) then + else if ( cprmnm == 'MAXCD' ) then maxcd = ipval - else if ( cprmnm .eq. 'MXS01V' ) then + else if ( cprmnm == 'MXS01V' ) then mxs01v = ipval - else if ( cprmnm .eq. 'MXBTM' ) then + else if ( cprmnm == 'MXBTM' ) then mxbtm = ipval - else if ( cprmnm .eq. 'MXBTMSE' ) then + else if ( cprmnm == 'MXBTMSE' ) then mxbtmse = ipval - else if ( cprmnm .eq. 'MXTAMC' ) then + else if ( cprmnm == 'MXTAMC' ) then mxtamc = ipval - else if ( cprmnm .eq. 'MXTCO' ) then + else if ( cprmnm == 'MXTCO' ) then mxtco = ipval - else if ( cprmnm .eq. 'MXNRV' ) then + else if ( cprmnm == 'MXNRV' ) then mxnrv = ipval - else if ( cprmnm .eq. 'MXRST' ) then + else if ( cprmnm == 'MXRST' ) then mxrst = ipval - else if ( cprmnm .eq. 'MXH4WLC' ) then + else if ( cprmnm == 'MXH4WLC' ) then mxh4wlc = ipval - else if ( cprmnm .eq. 'MXCNEM' ) then + else if ( cprmnm == 'MXCNEM' ) then mxcnem = ipval - else if ( cprmnm .eq. 'MAXNC' ) then + else if ( cprmnm == 'MAXNC' ) then maxnc = ipval - else if ( cprmnm .eq. 'MXNAF' ) then + else if ( cprmnm == 'MXNAF' ) then mxnaf = ipval else iret = -1 @@ -1122,61 +1122,61 @@ integer function igetprm ( cprmnm ) result ( iret ) character*64 errstr - if ( cprmnm .eq. 'MAXSS' ) then + if ( cprmnm == 'MAXSS' ) then iret = maxss - else if ( cprmnm .eq. 'NFILES' ) then + else if ( cprmnm == 'NFILES' ) then iret = nfiles - else if ( cprmnm .eq. 'MXMSGL' ) then + else if ( cprmnm == 'MXMSGL' ) then iret = mxmsgl - else if ( cprmnm .eq. 'MXDXTS' ) then + else if ( cprmnm == 'MXDXTS' ) then iret = mxdxts - else if ( cprmnm .eq. 'MAXMSG' ) then + else if ( cprmnm == 'MAXMSG' ) then iret = maxmsg - else if ( cprmnm .eq. 'MAXMEM' ) then + else if ( cprmnm == 'MAXMEM' ) then iret = maxmem - else if ( cprmnm .eq. 'MAXTBA' ) then + else if ( cprmnm == 'MAXTBA' ) then iret = maxtba - else if ( cprmnm .eq. 'MAXTBB' ) then + else if ( cprmnm == 'MAXTBB' ) then iret = maxtbb - else if ( cprmnm .eq. 'MAXTBD' ) then + else if ( cprmnm == 'MAXTBD' ) then iret = maxtbd - else if ( cprmnm .eq. 'MAXJL' ) then + else if ( cprmnm == 'MAXJL' ) then iret = maxjl - else if ( cprmnm .eq. 'MXCDV' ) then + else if ( cprmnm == 'MXCDV' ) then iret = mxcdv - else if ( cprmnm .eq. 'MXLCC' ) then + else if ( cprmnm == 'MXLCC' ) then iret = mxlcc - else if ( cprmnm .eq. 'MXCSB' ) then + else if ( cprmnm == 'MXCSB' ) then iret = mxcsb - else if ( cprmnm .eq. 'MXMTBB' ) then + else if ( cprmnm == 'MXMTBB' ) then iret = mxmtbb - else if ( cprmnm .eq. 'MXMTBD' ) then + else if ( cprmnm == 'MXMTBD' ) then iret = mxmtbd - else if ( cprmnm .eq. 'MXMTBF' ) then + else if ( cprmnm == 'MXMTBF' ) then iret = mxmtbf - else if ( cprmnm .eq. 'MAXCD' ) then + else if ( cprmnm == 'MAXCD' ) then iret = maxcd - else if ( cprmnm .eq. 'MXS01V' ) then + else if ( cprmnm == 'MXS01V' ) then iret = mxs01v - else if ( cprmnm .eq. 'MXBTM' ) then + else if ( cprmnm == 'MXBTM' ) then iret = mxbtm - else if ( cprmnm .eq. 'MXBTMSE' ) then + else if ( cprmnm == 'MXBTMSE' ) then iret = mxbtmse - else if ( cprmnm .eq. 'MXTAMC' ) then + else if ( cprmnm == 'MXTAMC' ) then iret = mxtamc - else if ( cprmnm .eq. 'MXTCO' ) then + else if ( cprmnm == 'MXTCO' ) then iret = mxtco - else if ( cprmnm .eq. 'MXNRV' ) then + else if ( cprmnm == 'MXNRV' ) then iret = mxnrv - else if ( cprmnm .eq. 'MXRST' ) then + else if ( cprmnm == 'MXRST' ) then iret = mxrst - else if ( cprmnm .eq. 'MXH4WLC' ) then + else if ( cprmnm == 'MXH4WLC' ) then iret = mxh4wlc - else if ( cprmnm .eq. 'MXCNEM' ) then + else if ( cprmnm == 'MXCNEM' ) then iret = mxcnem - else if ( cprmnm .eq. 'MAXNC' ) then + else if ( cprmnm == 'MAXNC' ) then iret = maxnc - else if ( cprmnm .eq. 'MXNAF' ) then + else if ( cprmnm == 'MXNAF' ) then iret = mxnaf else iret = -1 diff --git a/src/bitmaps.F90 b/src/bitmaps.F90 index 2cfe4ddc..1018c8af 100644 --- a/src/bitmaps.F90 +++ b/src/bitmaps.F90 @@ -27,20 +27,20 @@ subroutine strbtm ( n, lun ) node = inv( n, lun ) - if ( tag(node)(1:5) .eq. 'DPRI ' ) then + if ( tag(node)(1:5) == 'DPRI ' ) then ! Confirm that this is really an entry within a bitmap. Although it's rare, it is possible for a DPRI element ! to appear in a subset definition outside of a bitmap. isbtme = .false. - if ( ntamc .gt. 0 ) then + if ( ntamc > 0 ) then nodtam = lstjpb( node, lun, 'SUB' ) do ii = 1, ntamc - if ( nodtam .eq. inodtamc(ii) ) then + if ( nodtam == inodtamc(ii) ) then do jj = 1, ntco(ii) - if ( ( inodtco(ii,jj) .ge. inode(lun) ) .and. ( inodtco(ii,jj) .le. isc(inode(lun)) ) .and. & - ( inodtco(ii,jj) .lt. node ) ) then - if ( ctco(ii,jj) .eq. '236000' ) then + if ( ( inodtco(ii,jj) >= inode(lun) ) .and. ( inodtco(ii,jj) <= isc(inode(lun)) ) .and. & + ( inodtco(ii,jj) < node ) ) then + if ( ctco(ii,jj) == '236000' ) then isbtme = .true. - else if ( ( ctco(ii,jj) .eq. '235000' ) .or. ( ctco(ii,jj) .eq. '237255' ) ) then + else if ( ( ctco(ii,jj) == '235000' ) .or. ( ctco(ii,jj) == '237255' ) ) then isbtme = .false. end if end if @@ -54,7 +54,7 @@ subroutine strbtm ( n, lun ) endif if ( .not. linbtm ) then ! This is the start of a new bitmap. - if ( nbtm .ge. mxbtm ) call bort('BUFRLIB: STRBTM - MXBTM OVERFLOW') + if ( nbtm >= mxbtm ) call bort('BUFRLIB: STRBTM - MXBTM OVERFLOW') nbtm = nbtm + 1 istbtm(nbtm) = n iszbtm(nbtm) = 0 @@ -62,13 +62,13 @@ subroutine strbtm ( n, lun ) linbtm = .true. end if iszbtm(nbtm) = iszbtm(nbtm) + 1 - if ( ibfms(val(n,lun)) .eq. 0 ) then + if ( ibfms(val(n,lun)) == 0 ) then ! This is a "set" (value=0) entry in the bitmap. - if ( nbtmse(nbtm) .ge. mxbtmse ) call bort('BUFRLIB: STRBTM - MXBTMSE OVERFLOW') + if ( nbtmse(nbtm) >= mxbtmse ) call bort('BUFRLIB: STRBTM - MXBTMSE OVERFLOW') nbtmse(nbtm) = nbtmse(nbtm) + 1 ibtmse(nbtm,nbtmse(nbtm)) = iszbtm(nbtm) end if - else if ( itp(node) .gt. 1 ) then + else if ( itp(node) > 1 ) then linbtm = .false. end if @@ -135,21 +135,21 @@ recursive subroutine gettagre ( lunit, tagi, ntagi, tagre, ntagre, iret ) ! Get lun from lunit. call status( lunit, lun, il, im ) - if ( il .eq. 0 ) return - if ( inode(lun) .ne. inv(1,lun) ) return + if ( il == 0 ) return + if ( inode(lun) /= inv(1,lun) ) return ! Get tagre and ntagre from the (ntagi)th occurrence of tagi. call fstag( lun, tagi, ntagi, 1, ni, iret ) - if ( iret .ne. 0 ) return + if ( iret /= 0 ) return nre = nrfelm(ni,lun) - if ( nre .gt. 0 ) then + if ( nre > 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 + if ( tag(inv(ii,lun))(1:ltre) == tagre(1:ltre) ) then ntagre = ntagre + 1 end if end do @@ -196,8 +196,8 @@ integer function igetrfel ( n, lun ) result ( iret ) node = inv( n, lun ) - if ( itp(node) .gt. 1 ) then - if ( node .eq. lstnod ) then + if ( itp(node) > 1 ) then + if ( node == lstnod ) then lstnodct = lstnodct + 1 else lstnod = node @@ -205,38 +205,38 @@ integer function igetrfel ( n, lun ) result ( iret ) end if ! Does this subset definition contain any Table C operators with an X value of 21 or greater? idxta = 0 - if ( ntamc .gt. 0 ) then + if ( ntamc > 0 ) then nodtam = lstjpb( node, lun, 'SUB' ) do ii = 1, ntamc - if ( nodtam .eq. inodtamc(ii) ) then + if ( nodtam == inodtamc(ii) ) then idxta = ii ntc = ntco(ii) end if end do end if - if ( ( idxta .gt. 0 ) .and. ( nbtm .gt. 0 ) ) then + if ( ( idxta > 0 ) .and. ( nbtm > 0 ) ) then ! Check whether this element references a previous element in the same subset via an internal bitmap. To do this, ! we first need to determine the appropriate "follow" operator (if any) corresponding to this element. cflwopr = 'XXXXXX' - if ( imrkopr(tag(node)) .eq. 1 ) then + if ( imrkopr(tag(node)) == 1 ) then cflwopr = tag(node)(1:3) // '000' else call nemtab( lun, tag(node), idn, tab, nn ) - if ( tab .eq. 'B' ) then + if ( tab == 'B' ) then fxy = adn30(idn,6) - if ( fxy(2:3) .eq. '33' ) cflwopr = '222000' + if ( fxy(2:3) == '33' ) cflwopr = '222000' end if end if - if ( cflwopr .eq. 'XXXXXX' ) return + if ( cflwopr == 'XXXXXX' ) return ! Now, check whether the appropriate "follow" operator was actually present in the subset. If there are multiple ! occurrences, we want the one that most recently precedes 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) + if ( ( ctco(idxta,jj) == cflwopr ) .and. ( inodtco(idxta,jj) >= inode(lun) ) .and. & + ( inodtco(idxta,jj) <= isc(inode(lun)) ) .and. ( inodtco(idxta,jj) < node ) ) nodflw = inodtco(idxta,jj) enddo - if ( nodflw .eq. 0 ) then - if ( imrkopr(tag(node)) .eq. 1 ) then + if ( nodflw == 0 ) then + if ( imrkopr(tag(node)) == 1 ) then write(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND FOLLOW OPERATOR ",A," IN SUBSET")') cflwopr call bort(bort_str) endif @@ -247,30 +247,30 @@ integer function igetrfel ( n, lun ) result ( iret ) 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 + do while ( ( jj <= ntc ) .and. ( inodtco(idxta,jj) >= inode(lun) ) .and. & + ( inodtco(idxta,jj) <= isc(inode(lun)) ) .and. ( nodbmap == 0 ) ) + if ( ctco(idxta,jj) == '236000' ) then nodl236 = inodtco(idxta,jj) - if ( inodtco(idxta,jj) .eq. nodflw ) nodbmap = nodflw - else if ( ( ctco(idxta,jj) .eq. '235000' ) .or. ( ctco(idxta,jj) .eq. '237255' ) ) then + if ( inodtco(idxta,jj) == nodflw ) nodbmap = nodflw + else if ( ( ctco(idxta,jj) == '235000' ) .or. ( ctco(idxta,jj) == '237255' ) ) then nodl236 = 0 - else if ( ( ctco(idxta,jj) .eq. '237000' ) .and. ( inodtco(idxta,jj) .eq. nodflw ) .and. ( nodl236 .ne. 0 ) ) then + else if ( ( ctco(idxta,jj) == '237000' ) .and. ( inodtco(idxta,jj) == nodflw ) .and. ( nodl236 /= 0 ) ) then nodbmap = nodl236 end if jj = jj + 1 end do - if ( nodbmap .eq. 0 ) then + if ( nodbmap == 0 ) then ! There was no valid bitmap indicator, so we'll just look for a bitmap after the "follow" indicator. nodbmap = nodflw end if ! 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 + do while ( ( idxbtm == 0 ) .and. ( nn <= nval(lun) ) ) + if ( inv( nn, lun ) > nodbmap ) then ii = 1 - do while ( ( idxbtm .eq. 0 ) .and. ( ii .le. nbtm ) ) - if ( nn .eq. istbtm(ii) ) then + do while ( ( idxbtm == 0 ) .and. ( ii <= nbtm ) ) + if ( nn == istbtm(ii) ) then idxbtm = ii else ii = ii + 1 @@ -279,8 +279,8 @@ integer function igetrfel ( n, lun ) result ( iret ) end if nn = nn + 1 end do - if ( idxbtm .eq. 0 ) then - if ( imrkopr(tag(node)) .eq. 1 ) then + if ( idxbtm == 0 ) then + if ( imrkopr(tag(node)) == 1 ) then write(bort_str,'("BUFRLB: IGETRFEL - UNABLE TO FIND BITMAP FOR MARKER OPERATOR ",A)') tag(node) call bort(bort_str) endif @@ -288,47 +288,47 @@ integer function igetrfel ( n, lun ) result ( iret ) end if ! Use the bitmap to find the previous element in the subset that is referenced by the current element. ! Search backwards from the start of the bitmap, but make sure not to cross a 2-35-000 operator. - if ( lstnodct .gt. nbtmse(idxbtm) ) then - if ( imrkopr(tag(node)) .eq. 1 ) call bort( bort_str_mrkopr // tag(node) ) + if ( lstnodct > nbtmse(idxbtm) ) then + if ( imrkopr(tag(node)) == 1 ) call bort( bort_str_mrkopr // tag(node) ) return end if iemrk = iszbtm(idxbtm) - ibtmse(idxbtm,lstnodct) + 1 iect = 0 - do while ( ( nn .ge. 1 ) .and. ( iret .eq. 0 ) ) + do while ( ( nn >= 1 ) .and. ( iret == 0 ) ) nodnn = inv( nn, lun ) - if ( nodnn .le. nodbmap ) then + if ( nodnn <= 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 ) call bort( bort_str_mrkopr // tag(node) ) + if ( ( nodnn == inodtco(idxta,jj) ) .and. ( ctco(idxta,jj) == '235000' ) ) then + if ( imrkopr(tag(node)) == 1 ) call bort( bort_str_mrkopr // tag(node) ) return end if end do - if ( itp(nodnn) .gt. 1 ) then + if ( itp(nodnn) > 1 ) then iect = iect + 1 - if ( iect .eq. iemrk ) iret = nn + if ( iect == iemrk ) iret = nn end if end if nn = nn - 1 end do - if ( iret .eq. 0 ) then - if ( imrkopr(tag(node)) .eq. 1 ) call bort( bort_str_mrkopr // tag(node) ) + if ( iret == 0 ) then + if ( imrkopr(tag(node)) == 1 ) call bort( bort_str_mrkopr // tag(node) ) return end if - if ( imrkopr(tag(node)) .eq. 1 ) then + if ( imrkopr(tag(node)) == 1 ) then ! This element is a marker operator, so set the scale, reference value and bit width accordingly based on ! those of the previous referenced element. nodrfe = inv( iret, lun ) isc(node) = isc(nodrfe) - if ( tag(node)(1:3) .eq. '225' ) then + if ( tag(node)(1:3) == '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 + if ( nnrv > 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 + if ( ( nodrfe /= inodnrv(ii) ) .and. ( tag(nodrfe)(1:8) == tagnrv(ii) ) .and. & + ( nodrfe >= isnrv(ii) ) .and. ( nodrfe <= ienrv(ii) ) ) then irf(node) = int(nrv(ii)) return end if @@ -356,10 +356,10 @@ integer function imrkopr(nemo) result(iret) character*(*), intent(in) :: nemo - if (len(nemo).lt.6) then + if (len(nemo)<6) then iret = 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 + else if ( ( nemo(4:6)=='255' ) .and. & + ( ( nemo(1:3)=='223' ) .or. ( nemo(1:3)=='224' ) .or. ( nemo(1:3)=='225' ) .or. ( nemo(1:3)=='232' ) ) ) then iret = 1 else iret = 0 diff --git a/src/blocks.F90 b/src/blocks.F90 index 5dbd7d84..85d1f1e8 100644 --- a/src/blocks.F90 +++ b/src/blocks.F90 @@ -48,7 +48,7 @@ subroutine blocks(mbay,mwrd) equivalence(cint,iint) equivalence(dint,jint) - if(iblock.eq.0) return + if(iblock==0) return ! make room in mbay for control words - one at each end of the record @@ -61,13 +61,13 @@ subroutine blocks(mbay,mwrd) iint=mwrd*4 do i=1,nbytw - if(iblock.eq.-1) then + if(iblock==-1) then #ifdef BIG_ENDIAN dint(i)=cint(iordle(i)) #else dint(i)=cint(i) #endif - elseif(iblock.eq.1) then + elseif(iblock==1) then #ifdef LITTLE_ENDIAN dint(i)=cint(iordle(i)) #else diff --git a/src/bufr_interface.F90 b/src/bufr_interface.F90 index 7e175443..f8ae2449 100644 --- a/src/bufr_interface.F90 +++ b/src/bufr_interface.F90 @@ -74,12 +74,12 @@ end subroutine cwbmg_c subroutine ccbfl_c() bind(C, name='ccbfl') use iso_c_binding end subroutine ccbfl_c - + !> @fn bufr_interface::dlloctbf_c::dlloctbf_c() !> Free all memory allocated via inittbf_c(). - !> + !> !> Wraps dlloctbf() function. - !> + !> !> @author J. Ator @date 2017-11-03 subroutine dlloctbf_c() bind(C, name='dlloctbf') use iso_c_binding diff --git a/src/cftbvs.F90 b/src/cftbvs.F90 index 211df97f..88d69115 100644 --- a/src/cftbvs.F90 +++ b/src/cftbvs.F90 @@ -40,7 +40,7 @@ recursive real*8 function pkftbv(nbits,ibit) result(r8val) return endif - if((nbits.le.0).or.(ibit.le.0).or.(ibit.gt.nbits)) then + if((nbits<=0).or.(ibit<=0).or.(ibit>nbits)) then r8val = bmiss else r8val = (2.)**(nbits-ibit) @@ -103,14 +103,14 @@ recursive subroutine upftbv(lunit,nemo,val,mxib,ibit,nib) ! Perform some sanity checks. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il==0) call bort('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') call nemtab(lun,nemo,idn,tab,n) - if(n.eq.0) then + if(n==0) then write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo call bort(bort_str) endif - if(tabb(n,lun)(71:74).ne.'FLAG') then + if(tabb(n,lun)(71:74)/='FLAG') then write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," IS NOT A FLAG TABLE")') nemo call bort(bort_str) endif @@ -122,14 +122,14 @@ recursive subroutine upftbv(lunit,nemo,val,mxib,ibit,nib) call strnum(tabb(n,lun)(110:112),nbits,iersn) do i=(nbits-1),0,-1 r82i = (2.)**i - if(abs(r8val-r82i).lt.(0.005)) then + if(abs(r8val-r82i)<(0.005)) then nib = nib + 1 - if(nib.gt.mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') + if(nib>mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') ibit(nib) = nbits-i return - elseif(r82i.lt.r8val) then + elseif(r82imxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW') ibit(nib) = nbits-i r8val = r8val - r82i endif @@ -254,13 +254,13 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng endif call status ( lunit, lun, il, im ) - if ( il .eq. 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if ( il .gt. 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if ( im .eq. 0 ) call bort('BUFRLIB: GETCFMNG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if ( il == 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if ( il > 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if ( im == 0 ) call bort('BUFRLIB: GETCFMNG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') ! Make sure the appropriate code/flag information has already been read into internal memory. - if ( cdmf .ne. 'Y' ) call bort('BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// & + if ( cdmf /= 'Y' ) call bort('BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// & 'FIRST CALL SUBROUTINE CODFLG WITH INPUT ARGUMENT SET TO Y') itmp = ireadmt ( lun ) @@ -279,13 +279,13 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng do ii = 1, min ( 8, len( nemod ) ) my_nemod(ii:ii) = nemod(ii:ii) end do - if ( my_nemoi(1:4) .eq. 'GSES' ) then - if ( ( my_nemod(1:6) .eq. 'GCLONG' ) .or. ( my_nemod(1:4) .eq. 'OGCE' ) .or. ( my_nemod(1:5) .eq. 'ORIGC' ) ) then + if ( my_nemoi(1:4) == 'GSES' ) then + if ( ( my_nemod(1:6) == 'GCLONG' ) .or. ( my_nemod(1:4) == 'OGCE' ) .or. ( my_nemod(1:5) == 'ORIGC' ) ) then ifxyi = ifxy ( '001034' ) ifxyd(1) = ifxy ( '001035' ) else lnmng = min ( 24, lcmg ) - if ( lnmng .eq. 24 ) then + if ( lnmng == 24 ) then iret = 3 cmeang(1:24) = 'GCLONG OGCE ORIGC ' else @@ -293,18 +293,18 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng end if return end if - else if ( my_nemoi(1:6) .eq. 'GCLONG' ) then + else if ( my_nemoi(1:6) == 'GCLONG' ) then ifxyi = ifxy ( '001031' ) ifxyd(1) = (-1) - else if ( my_nemoi(1:4) .eq. 'OGCE' ) then + else if ( my_nemoi(1:4) == 'OGCE' ) then ifxyi = ifxy ( '001033' ) ifxyd(1) = (-1) - else if ( my_nemoi(1:5) .eq. 'ORIGC' ) then + else if ( my_nemoi(1:5) == 'ORIGC' ) then ifxyi = ifxy ( '001035' ) ifxyd(1) = (-1) - else if ( ( my_nemoi(1:7) .eq. 'TABLASS' ) .or. ( my_nemoi(1:7) .eq. 'TABLASL' ) ) then - if ( ( my_nemod(1:6) .eq. 'TABLAT' ) ) then - if ( my_nemoi(1:7) .eq. 'TABLASS' ) then + else if ( ( my_nemoi(1:7) == 'TABLASS' ) .or. ( my_nemoi(1:7) == 'TABLASL' ) ) then + if ( ( my_nemod(1:6) == 'TABLAT' ) ) then + if ( my_nemoi(1:7) == 'TABLASS' ) then ifxyi = ifxy ( '055021' ) else ifxyi = ifxy ( '055022' ) @@ -312,7 +312,7 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng ifxyd(1) = ifxy ( '055020' ) else lnmng = min ( 8, lcmg ) - if ( lnmng .eq. 8 ) then + if ( lnmng == 8 ) then iret = 1 cmeang(1:8) = 'TABLAT ' else @@ -320,28 +320,28 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng end if return end if - else if ( my_nemoi(1:6) .eq. 'TABLAT' ) then + else if ( my_nemoi(1:6) == 'TABLAT' ) then ifxyi = ifxy ( '055020' ) ifxyd(1) = (-1) else call parstr ( my_nemoi, nemo, 1, ntg, ' ', .true. ) call nemtab ( lun, nemo, ifxyi, tab, n ) - if ( ( n .eq. 0 ) .or. ( tab .ne. 'B' ) ) then + if ( ( n == 0 ) .or. ( tab /= 'B' ) ) then write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo call bort(bort_str) endif - if ( ( tabb ( n, lun )(71:74) .ne. 'CODE' ) .and. ( tabb ( n, lun )(71:74) .ne. 'FLAG' ) ) then + if ( ( tabb ( n, lun )(71:74) /= 'CODE' ) .and. ( tabb ( n, lun )(71:74) /= 'FLAG' ) ) then write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo call bort(bort_str) endif - if ( my_nemod(1:1) .ne. ' ' ) then + if ( my_nemod(1:1) /= ' ' ) then call parstr ( my_nemod, nemo, 1, ntg, ' ', .true. ) call nemtab ( lun, nemo, ifxyd(1), tab, n ) - if ( ( n .eq. 0 ) .or. ( tab .ne. 'B' ) ) then + if ( ( n == 0 ) .or. ( tab /= 'B' ) ) then write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo call bort(bort_str) endif - if ( ( tabb ( n, lun )(71:74) .ne. 'CODE' ) .and. ( tabb ( n, lun )(71:74) .ne. 'FLAG' ) ) then + if ( ( tabb ( n, lun )(71:74) /= 'CODE' ) .and. ( tabb ( n, lun )(71:74) /= 'FLAG' ) ) then write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo call bort(bort_str) endif @@ -353,7 +353,7 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng ! Search the internal table for the requested meaning. call srchtbf_c ( ifxyi, ivali, ifxyd(1), 10, ivald, cmeang, lcmg, lnmng, iret ) - if ( iret .le. 0 ) return + if ( iret <= 0 ) return ! The meaning of this value is dependent on the value of another mnemonic in the report. @@ -362,13 +362,13 @@ recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng 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 + if ( ( ierbd > 0 ) .and. ( tab == 'B' ) .and. ( lcmg >= ( 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 + if ( iret == 0 ) iret = -1 return end subroutine getcfmng @@ -419,16 +419,16 @@ recursive subroutine ufbqcd(lunit,nemo,iqcd) endif call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE OPEN') call nemtab(lun,nemo,idn,tab,iret) - if(tab.ne.'D') then + if(tab/='D') then write(bort_str,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') nemo call bort(bort_str) endif fxy = adn30(idn,6) - if(fxy(2:3).ne.'63') then + if(fxy(2:3)/='63') then write(bort_str,'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// & 'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," - CATEGORY MUST BE 63")') nemo, fxy(2:3) call bort(bort_str) @@ -476,7 +476,7 @@ recursive subroutine ufbqcp(lunit,iqcp,nemo) endif call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE OPEN') idn = ifxy('363000')+iqcp call numtab(lun,idn,nemo,tab,iret) diff --git a/src/cidecode.F90 b/src/cidecode.F90 index fcb8d2a5..02e8a3ab 100644 --- a/src/cidecode.F90 +++ b/src/cidecode.F90 @@ -52,7 +52,7 @@ subroutine upc(chr,nchr,ibay,ibit,cnvnull) numchr = min(nchr,len(chr)) do i=1,numchr call upb(ival(1),8,ibay,ibit) - if((ival(1).eq.0).and.(cnvnull)) then + if((ival(1)==0).and.(cnvnull)) then chr(i:i) = ' ' else chr(i:i) = cval(lb) @@ -162,7 +162,7 @@ subroutine upbb(nval,nbits,ibit,ibay) ! If nbits=0, then just set nval=0 and return - if(nbits.eq.0) then + if(nbits==0) then nval=0 return endif @@ -172,7 +172,7 @@ subroutine upbb(nval,nbits,ibit,ibay) int = ishft(irev(ibay(nwd)),nbt) int = ishft(int,nbits-nbitw) lbt = nbt+nbits - if(lbt.gt.nbitw) then + if(lbt>nbitw) then jnt = irev(ibay(nwd+1)) int = ior(int,ishft(jnt,lbt-2*nbitw)) endif @@ -289,7 +289,7 @@ recursive integer function iupm(cbay,nbits) result(iret) endif iret = 0 - if(nbits.gt.nbitw) then + if(nbits>nbitw) then write(bort_str,'("BUFRLIB: IUPM - NUMBER OF BITS BEING UNPACKED'// & ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBITW (",I3,")")') nbits,nbitw call bort(bort_str) @@ -331,21 +331,21 @@ real*8 function ups(ival,node) result(r8ret) r8ret = ( ival + irf(node) ) * ten**(-isc(node)) - if ( nnrv .gt. 0 ) then + if ( nnrv > 0 ) then ! There are redefined reference values in the jump/link table, so we need to check if this node is affected by any of them. do jj = 1, nnrv - if ( node .eq. inodnrv(jj) ) then + if ( node == inodnrv(jj) ) then ! This node contains a redefined reference value. Per the rules of BUFR, negative values may be encoded as positive ! integers with the left-most bit set to 1. imask = 2_8**(ibt(node)-1) - if ( iand(ival,imask) .gt. 0 ) then + if ( iand(ival,imask) > 0 ) then nrv(jj) = (-1) * ( ival - imask ) else nrv(jj) = ival end if r8ret = nrv(jj) return - else if ( ( tag(node)(1:8) .eq. tagnrv(jj) ) .and. ( node .ge. isnrv(jj) ) .and. ( node .le. ienrv(jj) ) ) then + else if ( ( tag(node)(1:8) == tagnrv(jj) ) .and. ( node >= isnrv(jj) ) .and. ( node <= ienrv(jj) ) ) then ! The corresponding redefinded reference value needs to be used when decoding this value. r8ret = ( ival + nrv(jj) ) * ten**(-isc(node)) return diff --git a/src/ciencode.F90 b/src/ciencode.F90 index 2e92dec5..5fec6b20 100644 --- a/src/ciencode.F90 +++ b/src/ciencode.F90 @@ -49,7 +49,7 @@ subroutine pkc(chr,nchr,ibay,ibit) nbit = 8 do i=1,nchr - if(i.le.len(chr)) then + if(i<=len(chr)) then cval(lb) = chr(i:i) else cval(lb) = ' ' @@ -62,7 +62,7 @@ subroutine pkc(chr,nchr,ibay,ibit) msk = ishft( -1,nbitw-nbit) msk = ishft(msk,-nbt) ibay(nwd) = irev(ior(iand(irev(ibay(nwd)),not(msk)),int)) - if(nbt+nbit.gt.nbitw) then + if(nbt+nbit>nbitw) then ! This character will not fit within the current word (i.e. array member) of ibay, because there ! are less than 8 bits of space left. Store as many bits as will fit within the current @@ -149,7 +149,7 @@ subroutine pkb(nval,nbits,ibay,ibit) character*156 bort_str - if(nbits.gt.nbitw) then + if(nbits>nbitw) then write(bort_str,'("BUFRLIB: PKB - NUMBER OF BITS BEING PACKED '// & ', NBITS (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBITW (",I3,")")') nbits,nbitw call bort(bort_str) @@ -158,13 +158,13 @@ subroutine pkb(nval,nbits,ibay,ibit) nwd = ibit/nbitw + 1 nbt = mod(ibit,nbitw) ival = nval - if(ishft(ival,-nbits).gt.0) ival = -1 + if(ishft(ival,-nbits)>0) ival = -1 int = ishft(ival,nbitw-nbits) int = ishft(int,-nbt) msk = ishft(-1,nbitw-nbits) msk = ishft(msk,-nbt) ibay(nwd) = irev(ior(iand(irev(ibay(nwd)),not(msk)),int)) - if(nbt+nbits.gt.nbitw) then + if(nbt+nbits>nbitw) then ! There are less than nbits bits remaining within the current word (i.e. array member) of ibay, ! so store as many bits as will fit within the current word and then store the remaining bits @@ -218,7 +218,7 @@ recursive subroutine ipkm(cbay,nbyt,n) return endif - if(nbyt.gt.nbytw) then + if(nbyt>nbytw) then write(bort_str,'("BUFRLIB: IPKM - NUMBER OF BYTES BEING PACKED '// & ', NBYT (",I4,"), IS > THE INTEGER WORD LENGTH ON THIS MACHINE, NBYTW (",I3,")")') nbyt,nbytw call bort(bort_str) @@ -264,21 +264,21 @@ integer*8 function ipks(val,node) result(i8ret) i8ret = nint(val * ten**isc(node),8) - irf(node) - if ( nnrv .gt. 0 ) then + if ( nnrv > 0 ) then ! There are redefined reference values in the jump/link table, so we need to check if this node is affected by any of them. do jj = 1, nnrv - if ( node .eq. inodnrv(jj) ) then + if ( node == inodnrv(jj) ) then ! This node contains a redefined reference value. Per the rules of BUFR, negative values should be encoded as positive ! integers with the left-most bit set to 1. nrv(jj) = nint(val) - if ( nrv(jj) .lt. 0 ) then + if ( nrv(jj) < 0 ) then imask = 2_8**(ibt(node)-1) i8ret = ior(abs(nrv(jj)),imask) else i8ret = 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 + else if ( ( tag(node)(1:8) == tagnrv(jj) ) .and. ( node >= isnrv(jj) ) .and. ( node <= ienrv(jj) ) ) then ! The corresponding redefinded reference value needs to be used when encoding this value. i8ret = nint(val * ten**isc(node),8) - nrv(jj) return diff --git a/src/compress.F90 b/src/compress.F90 index 94e3499a..fbbdf363 100644 --- a/src/compress.F90 +++ b/src/compress.F90 @@ -39,7 +39,7 @@ subroutine cmpmsg(cf) character*128 bort_str call capit(cf) - if(cf.ne.'Y'.and. cf.ne.'N') then + if(cf/='Y'.and. cf/='N') then write(bort_str,'("BUFRLIB: CMPMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf call bort(bort_str) endif @@ -164,7 +164,7 @@ subroutine rdcmps(lun) ! dictate that the "local reference value" will be equal to this value, the 6-bit increment length indicator will have a ! value of zero, and the actual increments themselves will be omitted from the message. - if(ityp.eq.1.or.ityp.eq.2) then + if(ityp==1.or.ityp==2) then ! This is a numeric element. if(nbit<=32) then call upb(lre4,nbit,mbay(1,lun),ibit) @@ -179,21 +179,21 @@ subroutine rdcmps(lun) jbit = ibit + linc*(nsbs-1) call up8(ninc,linc,mbay(1,lun),jbit) endif - if(ninc.eq.lps(linc)) then + if(ninc==lps(linc)) then ival = lps(nbit) else ival = lref + ninc endif - if(ityp.eq.1) then + if(ityp==1) then nbmp = int(ival) call usrtpl(lun,n,nbmp) - if (iscodes(lun) .ne. 0) return + if (iscodes(lun) /= 0) return goto 11 endif - if(ival.lt.lps(nbit)) val(n,lun) = ups(ival,node) + if(ival8) then ibit = ibit + (lelm-8)*8 nrst = nrst + 1 - if(nrst.gt.mxrst) then + if(nrst>mxrst) then write(bort_str,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER STRINGS EXCEEDS THE LIMIT (",I4,")")') mxrst call bort(bort_str) endif @@ -213,15 +213,15 @@ subroutine rdcmps(lun) endif ! Unpack the increment length indicator. For character elements, this length is in bytes rather than bits. call upb(linc,6,mbay(1,lun),ibit) - if(linc.eq.0) then - if(lelm.gt.8) then + if(linc==0) then + if(lelm>8) then irnch(nrst) = lelm irbit(nrst) = ibsv endif cval = cref else jbit = ibit + linc*(nsbs-1)*8 - if(lelm.gt.8) then + if(lelm>8) then irnch(nrst) = linc irbit(nrst) = jbit endif @@ -229,7 +229,7 @@ subroutine rdcmps(lun) cval = ' ' call upc(cval,nchr,mbay(1,lun),jbit,.true.) endif - if (lelm.le.8 .and. icbfms(cval,nchr).ne.0) then + if (lelm<=8 .and. icbfms(cval,nchr)/=0) then val(n,lun) = bmiss else val(n,lun) = rval @@ -275,7 +275,7 @@ subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt) call nemtba(lun,subset,mtyp,msbt,inod) call nemtab(lun,subset,isub,tab,iret) - if(iret.eq.0) then + if(iret==0) then write(bort_str,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subset call bort(bort_str) endif @@ -288,7 +288,7 @@ subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt) mour = mod(jdate ,100) mmin = 0 - if(mear.eq.0) then + if(mear==0) then mcen = mcen-1 mear = 100 endif @@ -438,10 +438,10 @@ subroutine wrcmps(lunix) call cmsgini(lun,mbay(1,lun),subset,idate(lun),ncol,kbyt) ! Check the edition number of the BUFR message to be created edge4 = .false. - if(ns01v.gt.0) then + if(ns01v>0) then i = 1 - do while ( (.not.edge4) .and. (i.le.ns01v) ) - if( (cmnem(i).eq.'BEN') .and. (ivmnem(i).ge.4) ) then + do while ( (.not.edge4) .and. (i<=ns01v) ) + if( (cmnem(i)=='BEN') .and. (ivmnem(i)>=4) ) then edge4 = .true. else i = i+1 @@ -450,39 +450,39 @@ subroutine wrcmps(lunix) endif endif - if(lun.ne.lunc) then + if(lun/=lunc) then write(bort_str,'("BUFRLIB: WRCMPS - FILE ID FOR THIS CALL (",I3,") .NE. FILE ID FOR INITIAL CALL (",I3,")'// & ' - UNIT NUMBER NOW IS",I4)') lun,lunc,lunix call bort(bort_str) endif cmpres = .true. - if(lunix.lt.0) then + if(lunix<0) then ! This is a "flush" call, so clear out the buffer (note that there is no current subset to be stored!) and prepare ! to write the final compressed BUFR message. - if(ncol.le.0) return + if(ncol<=0) return flush = .true. writ1 = .true. icol = 1 - elseif(ncol+1.gt.mxcsb) then + elseif(ncol+1>mxcsb) then ! There's no more room in the internal compression arrays for another subset, so we'll need to write out a message ! containing all of the data in those arrays, then initialize a new message to hold the current subset. cmpres = .false. else ! Check on some other possibly problematic situations - if(nval(lun).ne.nrow) then + if(nval(lun)/=nrow) then writ1 = .true. icol = 1 - elseif(nval(lun).gt.mxcdv) then + elseif(nval(lun)>mxcdv) then write(bort_str,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// & 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE COMPRESSION MATRIX (",I6,")")') nval(lun),mxcdv call bort(bort_str) - elseif(ncol.gt.0) then + elseif(ncol>0) then ! Confirm that all of the nodes are the same as in the previous subset for this same BUFR message. If not, then ! there may be different nested replication sequences activated in the current subset vs. in the previous subset, ! even though the total number of nodes is the same. do i = 1, nval(lun) - if ( inv(i,lun) .ne. jlnode(i) ) then + if ( inv(i,lun) /= jlnode(i) ) then writ1 = .true. icol = 1 exit @@ -499,9 +499,9 @@ subroutine wrcmps(lunix) jlnode(i) = node ityp(i) = itp(node) iwid(i) = ibt(node) - if(ityp(i).eq.1.or.ityp(i).eq.2) then + if(ityp(i)==1.or.ityp(i)==2) then call up8(matx(i,ncol),ibt(node),ibay,ibit) - elseif(ityp(i).eq.3) then + elseif(ityp(i)==3) then catx(i,ncol) = ' ' call upc(catx(i,ncol),ibt(node)/8,ibay,ibit,.true.) endif @@ -513,7 +513,7 @@ subroutine wrcmps(lunix) ! by re-computing all of the local reference values, increments, etc. to determine the new Section 4 length. do while (cmpres) - if(ncol.le.0) then + if(ncol<=0) then write(bort_str,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// & 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') ncol call bort(bort_str) @@ -522,47 +522,47 @@ subroutine wrcmps(lunix) ! subsets in the message ldata = 0 do i=1,nrow - if(ityp(i).eq.1 .or. ityp(i).eq.2) then + if(ityp(i)==1 .or. ityp(i)==2) then ! Row i of the compression matrix contains numeric values, so kmis(i) will store .true. if any such values are ! "missing", or .false. otherwise imiss = 2_8**iwid(i)-1 - if(icol.eq.1) then + if(icol==1) then kmin(i) = imiss kmax(i) = 0 kmis(i) = .false. endif do j=icol,ncol - if(matx(i,j).lt.imiss) then + if(matx(i,j)1. .or. kmiss)) then ! The data values in row i of the compression matrix are numeric values that aren't all identical. Compute the ! number of bits needed to hold the largest of the increments. kbit(i) = nint(log(range)*rln2) - if(2**kbit(i)-1.le.range) kbit(i) = kbit(i)+1 + if(2**kbit(i)-1<=range) kbit(i) = kbit(i)+1 ! However, under no circumstances should this number ever exceed the width of the original underlying descriptor! - if(kbit(i).gt.iwid(i)) kbit(i) = iwid(i) + if(kbit(i)>iwid(i)) kbit(i) = iwid(i) else ! The data values in row i of the compression matrix are numeric values that are all identical, so the 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 + elseif(ityp(i)==3) then ! Row i of the compression matrix contains character values, so kmis(i) will store .false. if all such values are ! identical, OR .true. otherwise - if(icol.eq.1) then + if(icol==1) then cstr(i) = catx(i,1) kmis(i) = .false. endif do j=icol,ncol - if ( (.not.kmis(i)) .and. (cstr(i).ne.catx(i,j)) ) then + if ( (.not.kmis(i)) .and. (cstr(i)/=catx(i,j)) ) then kmis(i) = .true. endif enddo @@ -580,7 +580,7 @@ subroutine wrcmps(lunix) ! Round data length up to a whole byte count ibyt = (ldata+8-mod(ldata,8))/8 ! Depending on the edition number of the message, we need to ensure that we round to an even byte count - if( (.not.edge4) .and. (mod(ibyt,2).ne.0) ) ibyt = ibyt+1 + if( (.not.edge4) .and. (mod(ibyt,2)/=0) ) ibyt = ibyt+1 jbit = ibyt*8-ldata if(msgfull(ibyt,kbyt,maxbyt)) then ! The current subset will not fit into the current message. Set the flag to indicate that a message write is needed, @@ -609,12 +609,12 @@ subroutine wrcmps(lunix) ibit = ibyt*8 do i=1,nrow - if(ityp(i).eq.1.or.ityp(i).eq.2) then + if(ityp(i)==1.or.ityp(i)==2) then call pkb8(kmin(i),iwid(i),mgwa,ibit) call pkb(kbit(i),6,mgwa,ibit) - if(kbit(i).gt.0) then + if(kbit(i)>0) then do j=1,ncol - if(matx(i,j).lt.2_8**iwid(i)-1) then + if(matx(i,j)<2_8**iwid(i)-1) then incr = matx(i,j)-kmin(i) else incr = 2_8**kbit(i)-1 @@ -622,9 +622,9 @@ subroutine wrcmps(lunix) call pkb8(incr,kbit(i),mgwa,ibit) enddo endif - elseif(ityp(i).eq.3) then + elseif(ityp(i)==3) then nchr = iwid(i)/8 - if(kbit(i).gt.0) then + if(kbit(i)>0) then call ipkm(czero,1,0) do j=1,nchr call pkc(czero,1,mgwa,ibit) @@ -650,11 +650,11 @@ subroutine wrcmps(lunix) ! Check that the message byte counters agree, then write the message - if(mod(ibit,8).ne.0) call bort('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// & + if(mod(ibit,8)/=0) call bort('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// & 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON A BYTE BOUNDARY') lbyt = iupbs01(mgwa,'LENM') nbyt = ibit/8 - if(nbyt.ne.lbyt) then + if(nbyt/=lbyt) then write(bort_str,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// & 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH (",I6,")")') lbyt,nbyt call bort(bort_str) diff --git a/src/copydata.F90 b/src/copydata.F90 index aff1eddd..b5591d00 100644 --- a/src/copydata.F90 +++ b/src/copydata.F90 @@ -46,9 +46,9 @@ recursive subroutine copybf(lunin,lunot) ! Check BUFR file statuses call status(lunin,lun,il,im) - if(il.ne.0) call bort ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + if(il/=0) call bort ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') call status(lunot,lun,il,im) - if(il.ne.0) call bort ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + if(il/=0) call bort ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') ! Connect the files for reading/writing to the C I/O interface @@ -58,9 +58,9 @@ recursive subroutine copybf(lunin,lunot) ! Read and copy a BUFR file from unit lunin to unit lunot ier = 0 - do while (ier.eq.0) + do while (ier==0) call rdmsgw(lunin,mgwa,ier) - if(ier.eq.0) call msgwrt(lunot,mgwa,iupbs01(mgwa,'LENM')) + if(ier==0) call msgwrt(lunot,mgwa,iupbs01(mgwa,'LENM')) enddo ! Free up the file connections for the two files @@ -135,20 +135,20 @@ recursive subroutine copymg(lunin,lunot) ! Check the file statuses call status(lunin,lin,il,im) - if(il.eq.0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') call status(lunot,lot,il,im) - if(il.eq.0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.ne.0) call bort('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN') + if(il==0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im/=0) call bort('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN') ! Make sure both files have the same tables subset = tag(inode(lin))(1:8) call nemtba(lot,subset,mtyp,msbt,inod) - if(inode(lin).ne.inod .and. iok2cpy(lin,lot).ne.1) & + if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) & call bort('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') ! Everything okay, so copy a message @@ -232,22 +232,22 @@ recursive subroutine copysb(lunin,lunot,iret) ! Check the file statuses call status(lunin,lin,il,im) - if(il.eq.0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(lunot.gt.0) then + if(lunot>0) then call status(lunot,lot,il,im) - if(il.eq.0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') - if( (inode(lin).ne.inode(lot)) .and. ( (tag(inode(lin)).ne.tag(inode(lot))) .or. (iok2cpy(lin,lot).ne.1) ) ) & + if(il==0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if( (inode(lin)/=inode(lot)) .and. ( (tag(inode(lin))/=tag(inode(lot))) .or. (iok2cpy(lin,lot)/=1) ) ) & call bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') endif ! See if there is another subset in the message - if(nsub(lin).eq.msub(lin)) then + if(nsub(lin)==msub(lin)) then iret = -1 return endif @@ -256,12 +256,12 @@ recursive subroutine copysb(lunin,lunot,iret) call mesgbc(-lunin, mest, icmp) - if(icmp.eq.1) then + if(icmp==1) then ! The input message is compressed, so read in the next subset and copy it as compressed to the output message. call readsb(lunin,iret) - if(lunot.gt.0) then + if(lunot>0) then call ufbcpy(lunin,lunot) call cmpmsg('Y') call writsb(lunot) @@ -273,9 +273,9 @@ recursive subroutine copysb(lunin,lunot,iret) ibit = (mbyt(lin))*8 call upb(nbyt,16,mbay(1,lin),ibit) - if (nbyt.gt.65530) then + if (nbyt>65530) then ! This is an oversized subset, so we can't rely on the value of nbyt as being the true size (in bytes) of the subset. - if ( (nsub(lin).eq.0) .and. (msub(lin).eq.1) ) then + if ( (nsub(lin)==0) .and. (msub(lin)==1) ) then ! But it's also the first and only subset in the message, so we can determine its true size in a different way. call getlens(mbay(1,lin), 4, len0, len1, len2, len3, len4, l5) nbyt = len4 - 4 @@ -285,7 +285,7 @@ recursive subroutine copysb(lunin,lunot,iret) return endif endif - if(lunot.gt.0) call cpyupd(lunot, lin, lot, nbyt) + if(lunot>0) call cpyupd(lunot, lin, lot, nbyt) mbyt(lin) = mbyt(lin) + nbyt nsub(lin) = nsub(lin) + 1 endif @@ -367,7 +367,7 @@ integer function iok2cpy(lui,luo) result(iret) ! Do both logical units have the same internal table information? - if ( icmpdx(lui,luo) .eq. 1 ) then + if ( icmpdx(lui,luo) == 1 ) then iret = 1 return endif @@ -377,20 +377,20 @@ integer function iok2cpy(lui,luo) result(iret) subset = tag(inode(lui))(1:8) call nemtbax(luo,subset,mtyp,msbt,inod) - if ( inod .eq. 0 ) return + if ( inod == 0 ) return ! The Table A mnemonic is defined within the dictionary tables for both units, so now make sure the definitions are identical. ntei = isc(inode(lui))-inode(lui) nteo = isc(inod)-inod - if ( ntei .ne. nteo ) return + if ( ntei /= nteo ) return do i = 1, ntei - if ( tag(inode(lui)+i) .ne. tag(inod+i) ) return - if ( typ(inode(lui)+i) .ne. typ(inod+i) ) return - if ( isc(inode(lui)+i) .ne. isc(inod+i) ) return - if ( irf(inode(lui)+i) .ne. irf(inod+i) ) return - if ( ibt(inode(lui)+i) .ne. ibt(inod+i) ) return + if ( tag(inode(lui)+i) /= tag(inod+i) ) return + if ( typ(inode(lui)+i) /= typ(inod+i) ) return + if ( isc(inode(lui)+i) /= isc(inod+i) ) return + if ( irf(inode(lui)+i) /= irf(inod+i) ) return + if ( ibt(inode(lui)+i) /= ibt(inod+i) ) return enddo iret = 1 @@ -461,18 +461,18 @@ recursive subroutine cpymem(lunot) ! Check the file statuses call status(munit,lin,il,im) - if(im.eq.0) call bort('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE') + if(im==0) call bort('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE') call status(lunot,lot,il,im) - if(il.eq.0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.ne.0) call bort('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN') + if(il==0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im/=0) call bort('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN') ! Make sure both files have the same tables subset = tag(inode(lin))(1:8) call nemtba(lot,subset,mtyp,msbt,inod) - if(inode(lin).ne.inod .and. iok2cpy(lin,lot).ne.1) & + if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) & call bort('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL '// & 'TABLES (DIFFERENT HERE)') @@ -529,7 +529,7 @@ subroutine cpyupd(lunit,lin,lun,ibyt) ! Check whether the new subset should be written into the currently open message - if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt.gt.65530).and.(nsub(lun).gt.0))) then + if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt>65530).and.(nsub(lun)>0))) then ! NO it should not, either because: ! 1) it doesn't fit, ! -- OR -- @@ -570,8 +570,8 @@ subroutine cpyupd(lunit,lin,lun,ibyt) ! in this message because their beginning would be beyond the upper limit of 65535 in the 16-bit byte counter, meaning ! they could not be located!) - if(ibyt.gt.65530) then - if(iprt.ge.1) then + if(ibyt>65530) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I7,A,A)') 'BUFRLIB: CPYUPD - SUBSET HAS BYTE COUNT = ',ibyt,' > UPPER LIMIT OF 65535' call errwrt(errstr) @@ -638,19 +638,19 @@ recursive subroutine ufbcpy(lubin,lubot) ! Check the file statuses and inode call status(lubin,lui,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lui).ne.inv(1,lui)) & + if(il==0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lui)/=inv(1,lui)) & call bort('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION '// & 'IN INTERNAL SUBSET ARRAY') call status(lubot,luo,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') - if( (inode(lui).ne.inode(luo)) .and. ( (tag(inode(lui)).ne.tag(inode(luo))) .or. (iok2cpy(lui,luo).ne.1) ) ) & + if( (inode(lui)/=inode(luo)) .and. ( (tag(inode(lui))/=tag(inode(luo))) .or. (iok2cpy(lui,luo)/=1) ) ) & call bort('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE') ! Everything okay, so copy user array from lui to luo @@ -794,16 +794,16 @@ recursive subroutine ufbcup(lubin,lubot) ! Check the file statuses and inode call status(lubin,lui,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lui).ne.inv(1,lui)) call bort('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lui)/=inv(1,lui)) call bort('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// & 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') call status(lubot,luo,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') ! Make a list of unique tags in the input buffer @@ -811,9 +811,9 @@ recursive subroutine ufbcup(lubin,lubot) outer1: do ni=1,nval(lui) nin = inv(ni,lui) - if(itp(nin).ge.2) then + if(itp(nin)>=2) then do nv=1,ntag - if(ttmp(nv).eq.tag(nin)) cycle outer1 + if(ttmp(nv)==tag(nin)) cycle outer1 enddo ntag = ntag+1 itmp(ntag) = ni @@ -821,7 +821,7 @@ recursive subroutine ufbcup(lubin,lubot) endif enddo outer1 - if(ntag.eq.0) call bort('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN INPUT SUBSET BUFFER') + if(ntag==0) call bort('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN INPUT SUBSET BUFFER') ! Now, using the list of unique tags, make one copy of the common elements to the output buffer @@ -829,7 +829,7 @@ recursive subroutine ufbcup(lubin,lubot) ni = itmp(nv) do no=1,nval(luo) tago = tag(inv(no,luo)) - if(ttmp(nv).eq.tago) then + if(ttmp(nv)==tago) then val(no,luo) = val(ni,lui) cycle outer2 endif diff --git a/src/dumpdata.F90 b/src/dumpdata.F90 index 97650ed5..4f827fc2 100644 --- a/src/dumpdata.F90 +++ b/src/dumpdata.F90 @@ -76,7 +76,7 @@ recursive subroutine ufbdmp(lunin,luprt) return endif - if(luprt.eq.0) then + if(luprt==0) then luout = 6 else luout = luprt @@ -86,16 +86,16 @@ recursive subroutine ufbdmp(lunin,luprt) lunit = abs(lunin) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBDMP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBDMP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBDMP - LOCATION OF INTERNAL TABLE FOR '// & 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') ! Dump the contents of @ref moda_usrint for unit abs(lunin) do nv=1,nval(lun) - if(luprt.eq.0 .and. mod(nv,20).eq.0) then + if(luprt==0 .and. mod(nv,20)==0) then ! When luprt=0, the output will be scrolled, 20 elements at a time @@ -105,7 +105,7 @@ recursive subroutine ufbdmp(lunin,luprt) ! If the terminal enters "q" followed by "", then scrolling will end and the subroutine will return to the ! calling program - if(you.eq.'q') THEN + if(you=='q') then print* print*,'==> You have chosen to stop the dumping of this subset' print* @@ -124,22 +124,22 @@ recursive subroutine ufbdmp(lunin,luprt) lk = link(nd) jb = jmpb(nd) tg_rj = adjustr(tg) - if(tp.ne.'CHR') then + if(tp/='CHR') then bits = ' ' - if(it.eq.2) then + if(it==2) then call nemtab(lun,tg,idn,tab,n) - if(tabb(n,lun)(71:75).eq.'FLAG') then + if(tabb(n,lun)(71:75)=='FLAG') then ! Print a listing of the bits corresponding to this value. call upftbv(lunit,tg,vl,mxfv,ifv,nifv) - if(nifv.gt.0) then + if(nifv>0) then bits(1:1) = '(' ipt = 2 do ii=1,nifv isz = isize(ifv(ii)) write(fmtf,'(A2,I1,A4)') '(I', isz, ',A1)' - if((ipt+isz).le.14) then + if((ipt+isz)<=14) then write(bits(ipt:ipt+isz),fmtf) ifv(ii), ',' ipt = ipt + isz + 1 else @@ -151,10 +151,10 @@ recursive subroutine ufbdmp(lunin,luprt) endif endif endif - if(ibfms(vl).ne.0) then + if(ibfms(vl)/=0) then write(luout,'(I5,1X,A3,A1,I1,1X,A10,1X, A20, 14X,7(1X,I5))') nv,tp,'-',it,tg_rj,pmiss,ib,is,ir,nd,jp,lk,jb else - if(lunit.eq.lunin) then + if(lunit==lunin) then write(luout,'(I5,1X,A3,A1,I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5))') nv,tp,'-',it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,jb else write(luout,'(I5,1X,A3,A1,I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5))') nv,tp,'-',it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,jb @@ -162,21 +162,21 @@ recursive subroutine ufbdmp(lunin,luprt) endif else nchr=ib/8 - if(nchr.gt.8) then + if(nchr>8) then call readlc(lunit,lchr2,tg_rj) - if (icbfms(lchr2,nchr).ne.0) then + if (icbfms(lchr2,nchr)/=0) then lchr = pmiss else lchr = lchr2(1:20) endif else - if(ibfms(vl).ne.0) then + if(ibfms(vl)/=0) then lchr = pmiss else lchr = vc endif endif - if ( nchr.le.20 .or. lchr.eq.pmiss ) then + if ( nchr<=20 .or. lchr==pmiss ) then lchr = adjustr(lchr) write(luout,'(I5,1X,A3,A1,I1,1X,A10,1X, A20, 14X,7(1X,I5))') nv,tp,'-',it,tg_rj,lchr,ib,is,ir,nd,jp,lk,jb else @@ -275,7 +275,7 @@ recursive subroutine ufdump(lunit,luprt) nls = 0 lcfmeang = len(cfmeang) - if(luprt.eq.0) then + if(luprt==0) then luout = 6 else luout = luprt @@ -284,10 +284,10 @@ recursive subroutine ufdump(lunit,luprt) ! Check the file status and inode call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '// & 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') write(luout,'(/,2A,/)') 'MESSAGE TYPE ',tag(inode(lun)) @@ -295,12 +295,12 @@ recursive subroutine ufdump(lunit,luprt) ! If code/flag table details are being printed, and if this is the first subset of a new message, then ! make sure the appropriate master tables have been read in to memory for this message. - if(cdmf.eq.'Y' .and. nsub(lun).eq.1) itmp = ireadmt(lun) + if(cdmf=='Y' .and. nsub(lun)==1) itmp = ireadmt(lun) ! Dump the contents of @ref moda_usrint for unit lunit do nv=1,nval(lun) - if(luprt.eq.0 .and. mod(nv,20).eq.0) then + if(luprt==0 .and. mod(nv,20)==0) then ! When luprt=0, the output will be scrolled, 20 elements at a time @@ -310,7 +310,7 @@ recursive subroutine ufdump(lunit,luprt) ! If the terminal enters "q" followed by "", then scrolling will end and the subroutine will return to the ! calling program - if(you.eq.'q') then + if(you=='q') then print* print*,'==> You have chosen to stop the dumping of this subset' print* @@ -323,7 +323,7 @@ recursive subroutine ufdump(lunit,luprt) ityp = itp(node) type = typ(node) - if(ityp.ge.1.and.ityp.le.3) then + if(ityp>=1.and.ityp<=3) then call nemtab(lun,nemo,idn,tab,n) if(n>0) then numb = tabb(n,lun)(1:6) @@ -333,16 +333,16 @@ recursive subroutine ufdump(lunit,luprt) rval = val(nv,lun) endif - if((ityp.eq.0).or.(ityp.eq.1)) then + if((ityp==0).or.(ityp==1)) then ! Sequence descriptor or delayed descriptor replication factor - if((type.eq.'REP').or.(type.eq.'DRP').or.(type.eq.'DRB').or.(type.eq.'DRS')) then + if((type=='REP').or.(type=='DRP').or.(type=='DRB').or.(type=='DRS')) then ! Print the number of replications nseq = nseq+1 - if(nseq.gt.mxseq) call bort('BUFRLIB: UFDUMP - MXSEQ OVERFLOW') - if(type.eq.'REP') then + if(nseq>mxseq) call bort('BUFRLIB: UFDUMP - MXSEQ OVERFLOW') + if(type=='REP') then numrep(nseq) = irf(node) else numrep(nseq) = nint(rval) @@ -352,7 +352,7 @@ recursive subroutine ufdump(lunit,luprt) write(luout,fmt) nemo2(1:lnm2), numrep(nseq), 'REPLICATIONS' ! How many times is this sequence replicated? - if(numrep(nseq).gt.1) then + if(numrep(nseq)>1) then ! Track the sequence seqnam(nseq) = nemo2 lsqnam(nseq) = lnm2 @@ -361,19 +361,19 @@ recursive subroutine ufdump(lunit,luprt) ! Don't bother nseq = nseq-1 endif - elseif( ((type.eq.'SEQ').or.(type.eq.'RPC').or.(type.eq.'RPS')) .and. (nseq.gt.0) ) then + elseif( ((type=='SEQ').or.(type=='RPC').or.(type=='RPS')) .and. (nseq>0) ) then ! Is this one of the sequences being tracked? ii = nseq track = .false. call strsuc(nemo,nemo2,lnm2) - do while ((ii.ge.1).and.(.not.track)) - if(nemo2(1:lnm2).eq.seqnam(ii)(2:lsqnam(ii)-1)) then + do while ((ii>=1).and.(.not.track)) + if(nemo2(1:lnm2)==seqnam(ii)(2:lsqnam(ii)-1)) then track = .true. ! Mark this level in the output fmt = '(4X,A,2X,A,2X,A,I6,2X,A)' write(luout,fmt) '++++++', nemo2(1:lnm2), 'REPLICATION #', idxrep(ii), '++++++' - if(idxrep(ii).lt.numrep(ii)) then + if(idxrep(ii)0) then tagrfe = tag(inv(nrfe,lun)) jj = 48 - do while((jj.ge.1).and.(desc(jj:jj).eq.' ')) + do while((jj>=1).and.(desc(jj:jj)==' ')) jj = jj - 1 enddo - if(jj.le.33) desc(jj+1:jj+15) = ' for ' // tagrfe + if(jj<=33) desc(jj+1:jj+15) = ' for ' // tagrfe endif ! Now print the value - if(ibfms(rval).ne.0) then + if(ibfms(rval)/=0) then ! The value is "missing". fmt = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)' write(luout,fmt) numb,nemo,pmiss,unit,desc else fmt = '(A6,2X,A10,2X, ,2X,A24,6X,A48)' ! Based upon the corresponding scale factor, select an appropriate format for the printing of this value. - if(isc(node).gt.0) then + if(isc(node)>0) then write(fmt(15:20),'(A,I2)') 'F20.', isc(node) else write(fmt(18:20),'(A)') 'I20' endif - if(unit(1:4).eq.'FLAG') then + if(unit(1:4)=='FLAG') then ! Print a listing of the bits corresponding to this value. call upftbv(lunit,nemo,rval,mxfv,ifv,nifv) - if(nifv.gt.0) then + if(nifv>0) then unit(11:11) = '(' ipt = 12 do ii=1,nifv isz = isize(ifv(ii)) write(fmtf,'(A2,I1,A4)') '(I', isz, ',A1)' - if((ipt+isz).le.24) then + if((ipt+isz)<=24) then write(unit(ipt:ipt+isz),fmtf) ifv(ii), ',' ipt = ipt + isz + 1 else @@ -447,25 +447,25 @@ recursive subroutine ufdump(lunit,luprt) unit(ipt-1:ipt-1) = ')' endif endif - if(isc(node).gt.0) then + if(isc(node)>0) then write(luout,fmt) numb,nemo,rval,unit,desc else ival = nint(rval,8) write(luout,fmt) numb,nemo,ival,unit,desc endif - if( (unit(1:4).eq.'FLAG' .or. unit(1:4).eq.'CODE') .and. (cdmf.eq.'Y') ) then + if( (unit(1:4)=='FLAG' .or. unit(1:4)=='CODE') .and. (cdmf=='Y') ) then ! Print the meanings of the code and flag values. fmt = '(31X,I8,A,A)' - if(unit(1:4).eq.'CODE') then + if(unit(1:4)=='CODE') then nifv = 1 ifv(nifv) = nint(rval) endif do ii=1,nifv icfdp(1) = (-1) call srchtbf_c(idn,ifv(ii),icfdp(1),mxcfdp,-1,cfmeang,lcfmeang,lcfmg,iersf) - if(iersf.eq.0) then + if(iersf==0) then write(luout,fmt) ifv(ii),' = ',cfmeang(1:lcfmg) - elseif(iersf.lt.0) then + elseif(iersf<0) then write(luout,fmt) ifv(ii),' = ','***THIS IS AN ILLEGAL/UNDEFINED VALUE***' else ! The meaning of this value is dependent on the value of another mnemonic in the report. Look for @@ -473,37 +473,37 @@ recursive subroutine ufdump(lunit,luprt) ! the proper meaning from the code/flag tables. ierft = (-1) jj = 0 - do while((jj.lt.iersf).and.(ierft.lt.0)) + do while((jj0).and.(tab=='B')) call fstag(lun,nemod,-1,nv,nout,ierft) enddo - if(ierft.eq.0) then + if(ierft==0) then ifvd = nint(val(nout,lun)) - if(jj.gt.1) icfdp(1) = icfdp(jj) + if(jj>1) icfdp(1) = icfdp(jj) call srchtbf_c(idn,ifv(ii),icfdp(1),mxcfdp,ifvd,cfmeang,lcfmeang,lcfmg,iersf) - if(iersf.eq.0) write(luout,fmt) ifv(ii),' = ', cfmeang(1:lcfmg) + if(iersf==0) write(luout,fmt) ifv(ii),' = ', cfmeang(1:lcfmg) endif endif enddo endif endif - elseif(ityp.eq.3) then + elseif(ityp==3) then ! Character (CCITT IA5) value nchr = ibt(node)/8 - if(ibfms(rval).ne.0) then + if(ibfms(rval)/=0) then lchr = pmiss - else if(nchr.le.8) then + else if(nchr<=8) then lchr = cval else ! Track the number of occurrences of this long character string, so that we can properly output each one. ii = 1 found = .false. - do while((ii.le.nls).and.(.not.found)) - if(nemo.eq.lsnemo(ii)) then + do while((ii<=nls).and.(.not.found)) + if(nemo==lsnemo(ii)) then found = .true. else ii = ii + 1 @@ -511,7 +511,7 @@ recursive subroutine ufdump(lunit,luprt) enddo if(.not.found) then nls = nls+1 - if(nls.gt.mxls) call bort('BUFRLIB: UFDUMP - MXLS OVERFLOW') + if(nls>mxls) call bort('BUFRLIB: UFDUMP - MXLS OVERFLOW') lsnemo(nls) = nemo lsct(nls) = 1 nemo3 = nemo @@ -523,14 +523,14 @@ recursive subroutine ufdump(lunit,luprt) endif call readlc(lunit,lchr2,nemo3) - if (icbfms(lchr2,nchr).ne.0) then + if (icbfms(lchr2,nchr)/=0) then lchr = pmiss else lchr = lchr2(1:20) endif endif - if ( nchr.le.20 .or. lchr.eq.pmiss ) then + if ( nchr<=20 .or. lchr==pmiss ) then lchr = adjustr(lchr) fmt = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)' write(luout,fmt) numb,nemo,lchr,nchr,unit,desc @@ -598,8 +598,8 @@ recursive subroutine dxdump(lunit,ldxot) data cardi4 /'|------------------------------------------------------------------------------|'/ ! Statement functions - tbskip(adn) = ((adn.eq.'063000').or.(adn.eq.'063255').or.(adn.eq.'031000').or.(adn.eq.'031001').or.(adn.eq.'031002')) - tdskip(adn) = ((adn.eq.'360001').or.(adn.eq.'360002').or.(adn.eq.'360003').or.(adn.eq.'360004')) + tbskip(adn) = ((adn=='063000').or.(adn=='063255').or.(adn=='031000').or.(adn=='031001').or.(adn=='031002')) + tdskip(adn) = ((adn=='360001').or.(adn=='360002').or.(adn=='360003').or.(adn=='360004')) ! Check for I8 integers. @@ -617,7 +617,7 @@ recursive subroutine dxdump(lunit,ldxot) ! Determine lun from lunit. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE OPEN') ! Create and write out (to ldxot) the header cards for the descriptor definition section. @@ -660,9 +660,9 @@ recursive subroutine dxdump(lunit,ldxot) ! last of the Table A mnemonics, in which case an extra cardi1 line will be written to ldxot in order to separate ! the Table A mnemonics from the other Table D mnemonics. do na=1,ntba(lun) - if(taba(na,lun)(4:11).eq.tabd(n,lun)(7:14)) then + if(taba(na,lun)(4:11)==tabd(n,lun)(7:14)) then card(14:14)='A' - if(na.eq.ntba(lun)) xtrci1=.true. + if(na==ntba(lun)) xtrci1=.true. exit end if end do @@ -715,24 +715,24 @@ recursive subroutine dxdump(lunit,ldxot) ! Get the list of child mnemonics for this Table D descriptor, and then add each one (including any replication tags) ! to 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 + if(nseq>0) then do nc=1,nseq cmstr=' ' icms=0 call strsuc(nem(nc,1),wrk2,nch) - if(irp(nc,1).ne.0) then + if(irp(nc,1)/=0) then ! Add the opening replication tag. icms=icms+1 cmstr(icms:icms)=reps(irp(nc,1)) end if cmstr(icms+1:icms+nch)=wrk2(1:nch) icms=icms+nch - if(irp(nc,1).ne.0) then + if(irp(nc,1)/=0) then ! Add the closing replication tag. icms=icms+1 cmstr(icms:icms)=reps(irp(nc,1)+5) end if - if(krp(nc,1).ne.0) then + if(krp(nc,1)/=0) then ! Add the fixed replication count. wrk1=' ' write (wrk1,'(I3)') krp(nc,1) @@ -742,7 +742,7 @@ recursive subroutine dxdump(lunit,ldxot) end if ! Will this child (and its replication tags, if any) fit into the current sequence definition card? If not, then ! write out (to ldxot) the current card and initialize a new one to hold this child. - if(ic.gt.(79-icms)) then + if(ic>(79-icms)) then write (ldxot,'(A)') card card=cardi2 card( 3:10)=tabd(n,lun)( 7:14) @@ -791,11 +791,11 @@ recursive subroutine dxdump(lunit,ldxot) ! Add the scale factor. call strsuc(tabb(n,lun)(96:98),wrk2,nch) card(17-nch+1:17)=wrk2 - if(tabb(n,lun)(95:95).eq.'-') card(17-nch:17-nch)='-' + if(tabb(n,lun)(95:95)=='-') card(17-nch:17-nch)='-' ! Add the reference value. call strsuc(tabb(n,lun)(100:109),wrk3,nch) card(31-nch+1:31)=wrk3 - if(tabb(n,lun)(99:99).eq.'-') card(31-nch:31-nch)='-' + if(tabb(n,lun)(99:99)=='-') card(31-nch:31-nch)='-' ! Add the bit width. call strsuc(tabb(n,lun)(110:112),wrk2,nch) card(37-nch+1:37)=wrk2 @@ -858,7 +858,7 @@ recursive subroutine getabdb(lunit,tabdb,itab,jtab) ! Make sure the file is open call status(lunit,lun,il,im) - if(il.eq.0) return + if(il==0) return ! Write out the Table D entries for this file @@ -867,7 +867,7 @@ recursive subroutine getabdb(lunit,tabdb,itab,jtab) call nemtbd(lun,i,nseq,nem(1,1),irp(1,1),krp(1,1)) do j=1,nseq,10 jtab = jtab+1 - if(jtab.le.itab) then + if(jtab<=itab) then write(tabdb(jtab),fmt='(A,A8,10(1X,A10))') 'D ', nemo, (nem(k,1),k=j,min(j+9,nseq)) endif enddo @@ -877,7 +877,7 @@ recursive subroutine getabdb(lunit,tabdb,itab,jtab) do i=1,ntbb(lun) jtab = jtab+1 - if(jtab.le.itab) then + if(jtab<=itab) then write(tabdb(jtab),fmt='(A,A8,1X,A42)') 'B ', tabb(i,lun)(7:14), tabb(i,lun)(71:112) endif enddo diff --git a/src/dxtable.F90 b/src/dxtable.F90 index c6fd6e3a..44b90cd5 100644 --- a/src/dxtable.F90 +++ b/src/dxtable.F90 @@ -42,9 +42,9 @@ subroutine readdx(lunit,lun,lundx) ! Read a dictionary table from the indicated source - if (lunit.eq.lundx) then + if (lunit==lundx) then ! Source is input BUFR file in lunit - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') write ( unit=errstr, fmt='(A,A,I3,A)' ) 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', & 'INPUT BUFR FILE IN UNIT ', lundx, ' INTO INTERNAL ARRAYS' @@ -54,9 +54,9 @@ subroutine readdx(lunit,lun,lundx) endif rewind lunit call rdbfdx(lunit,lun) - elseif(ildx.eq.-1) then + elseif(ildx==-1) then ! Source is input BUFR file in lundx; BUFR file in lunit may be input or output - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') write ( unit=errstr, fmt='(A,A,I3,A,A,I3)' ) 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', & 'ARRAYS ASSOC. W/ INPUT UNIT ', lundx, ' TO THOSE ASSOC. W/ UNIT ', lunit @@ -66,9 +66,9 @@ subroutine readdx(lunit,lun,lundx) endif call cpbfdx(lud,lun) call makestab - elseif(ildx.eq.1) then + elseif(ildx==1) then ! Source is output BUFR file in lundx; BUFR file in lunit may be input or output - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') write ( unit=errstr, fmt='(A,A,I3,A,A,I3)' ) 'BUFRLIB: READDX - COPYING BUFR DCTY TBL FROM INTERNAL ', & 'ARRAYS ASSOC. W/ OUTPUT UNIT ', lundx, ' TO THOSE ASSOC. W/ UNIT ', lunit @@ -78,9 +78,9 @@ subroutine readdx(lunit,lun,lundx) endif call cpbfdx(lud,lun) call makestab - elseif(ildx.eq.0) then + elseif(ildx==0) then ! Source is user-supplied character table in lundx; BUFR file in lunit may be input or output - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') write ( unit=errstr, fmt='(A,A,I3,A)' ) 'BUFRLIB: READDX - READING BUFR DICTIONARY TABLE FROM ', & 'USER-SUPPLIED TEXT FILE IN UNIT ', lundx, ' INTO INTERNAL ARRAYS' @@ -143,20 +143,20 @@ subroutine rdbfdx(lunit,lun) do while ( .not. done ) call rdmsgw ( lunit, mgwa, ier ) - if ( ier .eq. -1 ) then + if ( ier == -1 ) then ! Don't abort for an end-of-file condition, since it may be possible for a file to end with dictionary messages. ! Instead, backspace the file pointer and let the calling routine diagnose the end-of-file condition and deal with ! it as it sees fit. call backbufr_c(lun) done = .true. - else if ( ier .eq. -2 ) then + else if ( ier == -2 ) then call bort('BUFRLIB: RDBFDX - ERROR READING A BUFR DICTIONARY MESSAGE') - else if ( idxmsg(mgwa) .ne. 1 ) then + else if ( idxmsg(mgwa) /= 1 ) then ! This is a non-DX dictionary message. Assume we've reached the end of the dictionary table, and backspace lunit ! so that the next read (e.g. in the calling routine) will get this same message. call backbufr_c(lun) done = .true. - else if ( iupbs3(mgwa,'NSUB') .eq. 0 ) then + else if ( iupbs3(mgwa,'NSUB') == 0 ) then ! This is a DX dictionary message, but it doesn't contain any actual dictionary information. Assume we've reached ! the end of the dictionary table. done = .true. @@ -167,7 +167,7 @@ subroutine rdbfdx(lunit,lun) endif enddo - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I3,A)' ) 'BUFRLIB: RDBFDX - STORED NEW DX TABLE CONSISTING OF (', ict, ') MESSAGES;' call errwrt(errstr) @@ -218,62 +218,62 @@ subroutine rdusdx(lundx,lun) do while (.true.) read(lundx, '(A80)', iostat = ios) card - if (ios.ne.0) then + if (ios/=0) then call makestab return endif - if(card(1: 1).eq. '*') cycle ! comment line - if(card(3:10).eq.'--------') cycle ! separation line - if(card(3:10).eq.' ') cycle ! blank line - if(card(3:10).eq.'MNEMONIC') cycle ! header line - if(card(3:10).eq.'TABLE D') cycle ! header line - if(card(3:10).eq.'TABLE B') cycle ! header line + if(card(1: 1)== '*') cycle ! comment line + if(card(3:10)=='--------') cycle ! separation line + if(card(3:10)==' ') cycle ! blank line + if(card(3:10)=='MNEMONIC') cycle ! header line + if(card(3:10)=='TABLE D') cycle ! header line + if(card(3:10)=='TABLE B') cycle ! header line - if(card(12:12).eq.'|' .and. card(21:21).eq.'|') then + if(card(12:12)=='|' .and. card(21:21)=='|') then ! Parse a descriptor definition card nemo = card(3:10) ! nemo is the (up to) 8-character mnemonic iret=nemock(nemo) - if(iret.eq.-2) then + if(iret==-2) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"MNEMONIC ",A," IN USER DICTIONARY HAS INVALID CHARACTERS")') nemo call bort2(bort_str1,bort_str2) endif numb = card(14:19) ! numb is the 6-character FXY value corresponding to nemo nmb2 = numb - if(nmb2(1:1).eq.'A') nmb2(1:1) = '3' + if(nmb2(1:1)=='A') nmb2(1:1) = '3' iret=numbck(nmb2) - if(iret.eq.-1) then + if(iret==-1) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// & 'DICTIONARY HAS AN INVALID FIRST CHARACTER (F VALUE) - MUST BE A, 0 OR 3")') numb call bort2(bort_str1,bort_str2) endif - if(iret.eq.-2) then + if(iret==-2) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// & 'DICTIONARY HAS NON-NUMERIC VALUES IN CHARACTERS 2-6 (X AND Y VALUES)")') numb call bort2(bort_str1,bort_str2) endif - if(iret.eq.-3) then + if(iret==-3) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// & 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 2-3 (X VALUE) - MUST BE BETWEEN 00 AND 63")') numb call bort2(bort_str1,bort_str2) endif - if(iret.eq.-4) then + if(iret==-4) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"DESCRIPTOR NUMBER ",A," IN USER '// & 'DICTIONARY HAS INVALID NUMBER IN CHARACTERS 4-6 (Y VALUE) - MUST BE BETWEEN 000 AND 255")') numb call bort2(bort_str1,bort_str2) endif - if(numb(1:1).eq.'A') then + if(numb(1:1)=='A') then ! Table A descriptor found n = igetntbi ( lun, 'A' ) call stntbia ( n, lun, numb, nemo, card(23:) ) - if ( idna(n,lun,1) .eq. 11 ) then + if ( idna(n,lun,1) == 11 ) then write(bort_str1,'("BUFRLIB: RDUSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"USER-DEFINED MESSAGE TYPE ""011"" IS RESERVED FOR DICTIONARY MESSAGES")') call bort2(bort_str1,bort_str2) @@ -282,13 +282,13 @@ subroutine rdusdx(lundx,lun) numb(1:1) = '3' endif - if(numb(1:1).eq.'0') then + if(numb(1:1)=='0') then ! Table B descriptor found call stntbi ( igetntbi(lun,'B'), lun, numb, nemo, card(23:) ) cycle endif - if(numb(1:1).eq.'3') then + if(numb(1:1)=='3') then ! Table D descriptor found call stntbi ( igetntbi(lun,'D'), lun, numb, nemo, card(23:) ) cycle @@ -301,13 +301,13 @@ subroutine rdusdx(lundx,lun) endif - if(card(12:12).eq.'|' .and. card(19:19).ne.'|') then + if(card(12:12)=='|' .and. card(19:19)/='|') then ! Parse a sequence definition card call seqsdx(card,lun) cycle endif - if(card(12:12).eq.'|' .and. card(19:19).eq.'|') then + if(card(12:12)=='|' .and. card(19:19)=='|') then ! Parse an element definition card call elemdx(card,lun) cycle @@ -361,13 +361,13 @@ subroutine seqsdx(card,lun) ! can access the entry and then add the decoded sequence information to it. call nemtab(lun,nemo,idn,tab,iseq) - if(tab.ne.'D') then + if(tab/='D') then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY (UNDEFINED, TAB=",A,")")') nemo,tab call bort2(bort_str1,bort_str2) endif call parstr(seqs,tags,maxtgs,ntag,' ',.true.) - if(ntag.eq.0) then + if(ntag==0) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A," DOES NOT CONTAIN ANY CHILD MNEMONICS")') nemo call bort2(bort_str1,bort_str2) @@ -380,30 +380,30 @@ subroutine seqsdx(card,lun) ! Check for a replicator outer: do i=1,5 - if(atag(1:1).eq.reps(i)) then + if(atag(1:1)==reps(i)) then ! Note that reps(*), which contains all of the symbols used to denote all of the various replication schemes that ! are possible within a user-supplied BUFR dictionary table in character format, was previously defined within ! subroutine bfrini(). do j=2,maxtag - if(atag(j:j).eq.reps(i+5)) then + if(atag(j:j)==reps(i+5)) then ! Note that subroutine strnum() will return numr = 0 if the string passed to it contains all blanks ! (as *should* be the case whenever i = 2 '(' ')', 3 '{' '}', 4 '[' ']', or 5 '<' '>'). ! However, when i = 1 '"' '"', then subroutine strnum() will return numr = (the number of replications for ! the mnemonic using F=1 "regular" (i.e. non-delayed) replication). call strnum(atag(j+1:maxtag),numr,ier) - if(i.eq.1 .and. numr.le.0) then + if(i==1 .and. numr<=0) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// & 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER 2ND QUOTE")') nemo,tags(n),numr call bort2(bort_str1,bort_str2) endif - if(i.eq.1 .and. numr.gt.255) then + if(i==1 .and. numr>255) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '// & 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF 255")') nemo,tags(n),numr call bort2(bort_str1,bort_str2) endif - if(i.ne.1 .and. numr.ne.0) then + if(i/=1 .and. numr/=0) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL. '// & 'CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-NO")') nemo,tags(n),numr @@ -424,34 +424,34 @@ subroutine seqsdx(card,lun) ! Check for a valid tag iret=nemock(atag) - if(iret.eq.-1) then + if(iret==-1) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// & ' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")') nemo,tags(n) call bort2(bort_str1,bort_str2) endif - if(iret.eq.-2) then + if(iret==-2) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// & ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') nemo,tags(n) call bort2(bort_str1,bort_str2) endif call nemtab(lun,atag,idn,tab,iret) - if(iret.gt.0) then + if(iret>0) then ! Note that the next code line checks that we are not trying to replicate a Table B mnemonic (which is currently not ! allowed). The logic works because, for replicated mnemonics, irep = i = (the index within reps(*) of the symbol ! associated with the type of replication in question (e.g. "{, "<", etc.)) - if(tab.eq.'B' .and. irep.ne.0) then + if(tab=='B' .and. irep/=0) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'// & ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")') nemo,tags(n) call bort2(bort_str1,bort_str2) endif - if(atag(1:1).eq.'.') then + if(atag(1:1)=='.') then ! This mnemonic is a "following value" mnemonic (i.e. it relates to the mnemonic that immediately follows it within ! the user-supplied character-format BUFR dictionary table sequence), so confirm that it contains, as a substring, ! this mnemonic that immediately follows it. - if(n.eq.ntag) then + if(n==ntag) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '// & '''FOLLOWING VALUE'' MNEMONIC WHICH IS LAST IN THE STRING")') nemo @@ -461,13 +461,13 @@ subroutine seqsdx(card,lun) call numtab(lun,idn,nema,tab,itab) call nemtab(lun,nemb,jdn,tab,iret) call rsvfvm(nema,nemb) - if(nema.ne.atag) then + if(nema/=atag) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '// & 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")') nemo,tags(n),nema call bort2(bort_str1,bort_str2) endif - if(tab.ne.'B') then + if(tab/='B') then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'// & 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B ENTRY")') nemo,nemb @@ -482,8 +482,8 @@ subroutine seqsdx(card,lun) endif ! Write the descriptor string into the tabd array, but first look for a replication descriptor - if(irep.gt.0) call pktdd(iseq,lun,idnr(irep)+numr,iret) - if(iret.lt.0) then + if(irep>0) call pktdd(iseq,lun,idnr(irep)+numr,iret) + if(iret<0) then clemon = adn30(idnr(irep)+numr,6) write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// & @@ -491,7 +491,7 @@ subroutine seqsdx(card,lun) call bort2(bort_str1,bort_str2) endif call pktdd(iseq,lun,idn,iret) - if(iret.lt.0) then + if(iret<0) then write(bort_str1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') card write(bort_str2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '// & 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. WARNING MSG")') nemo,tags(n) @@ -545,7 +545,7 @@ subroutine elemdx(card,lun) ! so that we can access the entry and then add the scale factor, reference value, bit width, and units to it. call nemtab(lun,nemo,idsn,tab,iele) - if(tab.ne.'B') then + if(tab/='B') then write(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"MNEMONIC ",A," IS NOT A TABLE B ENTRY (UNDEFINED, TAB=",A,")")') nemo,tab call bort2(bort_str1,bort_str2) @@ -554,7 +554,7 @@ subroutine elemdx(card,lun) ! Left justify and store characteristics unit = adjustl(unit) - if(unit.eq.' ') then + if(unit==' ') then write(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"UNITS FIELD IS EMPTY")') call bort2(bort_str1,bort_str2) @@ -563,7 +563,7 @@ subroutine elemdx(card,lun) scal_orig=scal call jstnum(scal,sign,iret) - if(iret.ne.0) then + if(iret/=0) then write(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"PARSED SCALE VALUE (=",A,") IS NOT NUMERIC")') scal_orig call bort2(bort_str1,bort_str2) @@ -573,7 +573,7 @@ subroutine elemdx(card,lun) refr_orig=refr call jstnum(refr,sign,iret) - if(iret.ne.0) then + if(iret/=0) then write(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"PARSED REFERENCE VALUE (=",A,") IS NOT NUMERIC")') refr_orig call bort2(bort_str1,bort_str2) @@ -583,7 +583,7 @@ subroutine elemdx(card,lun) bitw_orig=bitw call jstnum(bitw,sign,iret) - if(iret.ne.0 .or. sign.eq.'-') then + if(iret/=0 .or. sign=='-') then write(bort_str1,'("BUFRLIB: ELEMDX - CARD READ IN IS: ",A)') card write(bort_str2,'(18X,"PARSED BIT WIDTH VALUE (=",A,") IS NOT NUMERIC")') bitw_orig call bort2(bort_str1,bort_str2) @@ -651,7 +651,7 @@ subroutine dxinit(lun,ioi) call pktdd(i,lun,0,iret) enddo - if(ioi.eq.0) return + if(ioi==0) return ! Initialize table with apriori Table B and D entries @@ -738,7 +738,7 @@ subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd) nby5 = 4 mbyt = nby0+nby1+nby2+nby3+nby4+nby5 - if(mod(nby3,2).ne.0) call bort ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') + if(mod(nby3,2)/=0) call bort ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') ! Section 0 @@ -788,7 +788,7 @@ subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd) mbd = mbit/8+1 call pkb( 0 , 8 , mbay,mbit) - if(mbit/8+nby5.ne.mbyt) then + if(mbit/8+nby5/=mbyt) then write(bort_str,'("BUFRLIB: DXMINI - NUMBER OF BYTES STORED FOR '// & 'A MESSAGE (",I6,") IS NOT THE SAME AS FIRST CALCULATED, MBYT (",I6)') mbit/8+nby5,mbyt call bort(bort_str) @@ -818,7 +818,7 @@ subroutine writdx(lunit,lun,lundx) ! The table must be coming from an input file - if(lunit.eq.lundx) then + if(lunit==lundx) then write(bort_str,'("BUFRLIB: WRITDX - FILES CONTAINING BUFR DATA '// & 'AND DICTIONARY TABLE CANNOT BE THE SAME (HERE BOTH SHARE FORTRAN UNIT NUMBER ",I3,")")') lunit call bort(bort_str) @@ -882,15 +882,15 @@ recursive subroutine wrdxtb(lundx,lunot) ! Check file statuses call status(lunot,lot,il,im) - if(il.eq.0) call bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(il==0) call bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') call status(lundx,ldx,il,im) - if(il.eq.0) call bort('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT MUST BE OPEN') ! If files are different, copy internal table information from lundx to lunot - if(lundx.ne.lunot) call cpbfdx(ldx,lot) + if(lundx/=lunot) call cpbfdx(ldx,lot) ! Generate and write out BUFR dictionary messages to lunot @@ -904,7 +904,7 @@ recursive subroutine wrdxtb(lundx,lunot) ! Table A information do i=1,ntba(lot) - if(msgfull(mbyt,lda,maxdx).or.(iupb(mgwa,mbya,8).eq.255)) then + if(msgfull(mbyt,lda,maxdx).or.(iupb(mgwa,mbya,8)==255)) then call msgwrt(lunot,mgwa,mbyt) call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd) endif @@ -924,7 +924,7 @@ recursive subroutine wrdxtb(lundx,lunot) ! Table B information do i=1,ntbb(lot) - if(msgfull(mbyt,ldb,maxdx).or.(iupb(mgwa,mbyb,8).eq.255)) then + if(msgfull(mbyt,ldb,maxdx).or.(iupb(mgwa,mbyb,8)==255)) then call msgwrt(lunot,mgwa,mbyt) call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd) endif @@ -944,7 +944,7 @@ recursive subroutine wrdxtb(lundx,lunot) do i=1,ntbd(lot) nseq = iupm(tabd(i,lot)(ldd+1:ldd+1),8) lend = ldd+1 + l30*nseq - if(msgfull(mbyt,lend,maxdx).or.(iupb(mgwa,mbyd,8).eq.255)) then + if(msgfull(mbyt,lend,maxdx).or.(iupb(mgwa,mbyd,8)==255)) then call msgwrt(lunot,mgwa,mbyt) call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd) endif @@ -1020,8 +1020,8 @@ subroutine stbfdx(lun,mesg) ! Get some preliminary information from the message idxs = iupbs01(mesg,'MSBT')+1 - if(idxs.gt.idxv+1) idxs = iupbs01(mesg,'MTVL')+1 - if(ldxa(idxs).eq.0 .or. ldxb(idxs).eq.0 .or. ldxd(idxs).eq.0) call bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY '// & + if(idxs>idxv+1) idxs = iupbs01(mesg,'MTVL')+1 + if(ldxa(idxs)==0 .or. ldxb(idxs)==0 .or. ldxd(idxs)==0) call bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY '// & 'MESSAGE SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN KNOWN)') call getlens(mesg,3,len0,len1,len2,len3,l4,l5) @@ -1029,7 +1029,7 @@ subroutine stbfdx(lun,mesg) dxcmp = ' ' jbit = 8*(i3+7) call upc(dxcmp,nxstr(idxs),mesg,jbit,.false.) - if(dxcmp.ne.dxstr(idxs)) call bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE CONTENTS') + if(dxcmp/=dxstr(idxs)) call bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE CONTENTS') ! Section 4 - read definitions for Tables A, B and D @@ -1089,7 +1089,7 @@ subroutine stbfdx(lun,mesg) call nenubd(nemo,numb,lun) idnd(n,lun) = ifxy(numb) nd = iupb(mesg,id+ldd+1,8) - if(nd.gt.maxcd) then + if(nd>maxcd) then write(bort_str,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '// & 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT (",I4,")")') nemo,nd,maxcd call bort(bort_str) @@ -1100,10 +1100,10 @@ subroutine stbfdx(lun,mesg) call upc(cidn,l30,mesg,jbit,.true.) idn = idn30(cidn,l30) call pktdd(n,lun,idn,iret) - if(iret.lt.0) call bort('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE PKTDD, SEE PREVIOUS WARNING MESSAGE') + if(iret<0) call bort('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE PKTDD, SEE PREVIOUS WARNING MESSAGE') enddo id = id+ldd+1 + nd*l30 - if(iupb(mesg,id+1,8).eq.0) id = id+1 + if(iupb(mesg,id+1,8)==0) id = id+1 ntbd(lun) = n enddo @@ -1129,8 +1129,8 @@ integer function idxmsg( mesg ) result( iret ) ! Note that the following test relies upon logic within subroutine dxmini() which zeroes out the Section 1 date of ! all DX dictionary messages. - if ( (iupbs01(mesg,'MTYP').eq.11) .and. & - (iupbs01(mesg,'MNTH').eq.0) .and. (iupbs01(mesg,'DAYS').eq.0) .and. (iupbs01(mesg,'HOUR').eq.0) ) then + if ( (iupbs01(mesg,'MTYP')==11) .and. & + (iupbs01(mesg,'MNTH')==0) .and. (iupbs01(mesg,'DAYS')==0) .and. (iupbs01(mesg,'HOUR')==0) ) then iret = 1 else iret = 0 @@ -1161,17 +1161,17 @@ integer function igetntbi ( lun, ctb ) result(iret) character, intent(in) :: ctb character*128 bort_str - if ( ctb .eq. 'A' ) then + if ( ctb == 'A' ) then iret = ntba(lun) + 1 imax = ntba(0) - else if ( ctb .eq. 'B' ) then + else if ( ctb == 'B' ) then iret = ntbb(lun) + 1 imax = ntbb(0) - else ! ctb .eq. 'D' + else ! ctb == 'D' iret = ntbd(lun) + 1 imax = ntbd(0) endif - if ( iret .gt. imax ) then + if ( iret > imax ) then write(bort_str,'("BUFRLIB: IGETNTBI - NUMBER OF INTERNAL TABLE",A1," ENTRIES EXCEEDS THE LIMIT (",I4,")")') ctb, imax call bort(bort_str) endif @@ -1211,15 +1211,15 @@ subroutine nemtbax(lun,nemo,mtyp,msbt,inod) ! Look for nemo in Table A do i=1,ntba(lun) - if(taba(i,lun)(4:11).eq.nemo) then + if(taba(i,lun)(4:11)==nemo) then mtyp = idna(i,lun,1) msbt = idna(i,lun,2) inod = mtab(i,lun) - if(mtyp.lt.0 .or. mtyp.gt.255) then + if(mtyp<0 .or. mtyp>255) then write(bort_str,'("BUFRLIB: NEMTBAX - INVALID MESSAGE TYPE (",I4,") RETURNED FOR MENMONIC ",A)') mtyp, nemo call bort(bort_str) endif - if(msbt.lt.0 .or. msbt.gt.255) then + if(msbt<0 .or. msbt>255) then write(bort_str,'("BUFRLIB: NEMTBAX - INVALID MESSAGE SUBTYPE (",I4,") RETURNED FOR MENMONIC ",A)') msbt, nemo call bort(bort_str) endif @@ -1256,7 +1256,7 @@ subroutine nemtba(lun,nemo,mtyp,msbt,inod) ! Look for nemo in Table A call nemtbax(lun,nemo,mtyp,msbt,inod) - if(inod.eq.0) then + if(inod==0) then write(bort_str,'("BUFRLIB: NEMTBA - CAN''T FIND MNEMONIC ",A)') nemo call bort(bort_str) endif @@ -1288,7 +1288,7 @@ subroutine nemtbb(lun,itab,unit,iscl,iref,ibit) character*24, intent(out) :: unit character*8 nemo - if(itab.le.0 .or. itab.gt.ntbb(lun)) then + if(itab<=0 .or. itab>ntbb(lun)) then write(bort_str,'("BUFRLIB: NEMTBB - ITAB (",I7,") NOT FOUND IN TABLE B")') itab call bort(bort_str) endif @@ -1304,11 +1304,11 @@ subroutine nemtbb(lun,itab,unit,iscl,iref,ibit) ! Check Table B contents - if(unit(1:5).ne.'CCITT' .and. ibit.gt.32) then + if(unit(1:5)/='CCITT' .and. ibit>32) then write(bort_str,'("BUFRLIB: NEMTBB - BIT WIDTH FOR NON-CHARACTER TABLE B MNEMONIC ",A," (",I7,") IS > 32")') nemo,ibit call bort(bort_str) endif - if(unit(1:5).eq.'CCITT' .and. mod(ibit,8).ne.0) then + if(unit(1:5)=='CCITT' .and. mod(ibit,8)/=0) then write(bort_str,'("BUFRLIB: NEMTBB - BIT WIDTH FOR CHARACTER TABLE B MNEMONIC ",A," (",I7,") IS NOT A MULTIPLE OF 8")') & nemo,ibit call bort(bort_str) @@ -1359,7 +1359,7 @@ subroutine nemtbd(lun,itab,nseq,nems,irps,knts) character*8 nemo, nemt, nemf character tab - if(itab.le.0 .or. itab.gt.ntbd(lun)) then + if(itab<=0 .or. itab>ntbd(lun)) then write(bort_str,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN TABLE D")') itab call bort(bort_str) endif @@ -1383,31 +1383,31 @@ subroutine nemtbd(lun,itab,nseq,nems,irps,knts) ! Loop through each child mnemonic do j=1,ndsc - if(nseq+1.gt.maxcd) then + if(nseq+1>maxcd) then write(bort_str,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '// & '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE MNEMONIC ",A)') maxcd, nemo call bort(bort_str) endif call uptdd(itab,lun,j,idsc) call numtab(lun,idsc,nemt,tab,iret) - if(tab.eq.'R') then - if(iret.lt.0) then + if(tab=='R') then + if(iret<0) then ! Regular (i.e. non-delayed) replication irps(nseq+1) = 1 knts(nseq+1) = abs(iret) - elseif(iret.gt.0) then + elseif(iret>0) then ! Delayed replication irps(nseq+1) = iret endif - elseif(tab.eq.'F') then + elseif(tab=='F') then ! Replication factor irps(nseq+1) = iret - elseif(tab.eq.'D'.or.tab.eq.'C') then + elseif(tab=='D'.or.tab=='C') then nseq = nseq+1 nems(nseq) = nemt - elseif(tab.eq.'B') then + elseif(tab=='B') then nseq = nseq+1 - if((nemt(1:1).eq.'.').and.(j.lt.ndsc)) then + if((nemt(1:1)=='.').and.(j=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - if(nd.lt.0) then + if(nd<0) then write ( unit=errstr, FMT='(A,I4,A)' ) 'BUFRLIB: PKTDD - BAD COUNTER VALUE (=', nd, ') - RETURN WITH IRET = -1' else write ( unit=errstr, FMT='(A,I4,A,A)' ) 'BUFRLIB: PKTDD - MAXIMUM NUMBER OF CHILD MNEMONICS (=', & @@ -1756,10 +1756,10 @@ subroutine uptdd(id,lun,ient,iret) ldd = ldxd(idxv+1)+1 ndsc = iupm(tabd(id,lun)(ldd:ldd),8) - if(ient.eq.0) then + if(ient==0) then iret = ndsc return - elseif(ient.lt.0 .or. ient.gt.ndsc) then + elseif(ient<0 .or. ient>ndsc) then write(bort_str,'("BUFRLIB: UPTDD - VALUE OF THIRD ARGUMENT IENT (INPUT) IS OUT OF RANGE (IENT =",I4,")")') ient call bort(bort_str) endif @@ -1801,11 +1801,11 @@ subroutine rsvfvm(nem1,nem2) integer i, j do i=1,len(nem1) - if(i.eq.1) then + if(i==1) then ! Skip the initial ".", and initialize J. j = 1 else - if(nem1(i:i).eq.'.') then + if(nem1(i:i)=='.') then nem1(i:i) = nem2(j:j) j = j+1 endif diff --git a/src/fxy.F90 b/src/fxy.F90 index 5a3eba56..6fa01fab 100644 --- a/src/fxy.F90 +++ b/src/fxy.F90 @@ -4,7 +4,7 @@ !> @author J. Ator @date 2024-02-29 !> Convert an FXY value from its WMO bit-wise representation to a character string of length 5 or 6. -!> +!> !> For an description of the WMO bit-wise representation of the FXY value, see ifxy(). !> !> This function is the logical inverse of function idn30(). @@ -27,12 +27,12 @@ function adn30(idn,ldn) character*(*) adn30 character*128 bort_str - if(len(adn30).lt.ldn) call bort('BUFRLIB: ADN30 - FUNCTION RETURN STRING TOO SHORT') - if(idn.lt.0 .or. idn.gt.65535) call bort('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF DESCRIPTOR OUT OF 16-BIT RANGE') + if(len(adn30)65535) call bort('BUFRLIB: ADN30 - INTEGER REPRESENTATION OF DESCRIPTOR OUT OF 16-BIT RANGE') - if(ldn.eq.5) then + if(ldn==5) then write(adn30,'(i5)') idn - elseif(ldn.eq.6) then + elseif(ldn==6) then idf = ishft(idn,-14) idx = ishft(ishft(idn,nbitw-14),-(nbitw-6)) idy = ishft(ishft(idn,nbitw- 8),-(nbitw-8)) @@ -43,7 +43,7 @@ function adn30(idn,ldn) endif do i=1,ldn - if(adn30(i:i).eq.' ') adn30(i:i) = '0' + if(adn30(i:i)==' ') adn30(i:i) = '0' enddo return @@ -99,20 +99,20 @@ integer function idn30(adn,ldn) result(iret) integer ifxy - if(len(adn).lt.ldn) then + if(len(adn)65535) then write(bort_str, & '("BUFRLIB: IDN30 - DESCRIPTOR INTEGER REPRESENTATION, IDN30 (",I8,"), IS OUTSIDE 16-BIT RANGE (0-65535)")') iret call bort(bort_str) endif - elseif(ldn.eq.6) then + elseif(ldn==6) then iret = ifxy(adn) else write(bort_str,'("BUFRLIB: IDN30 - FUNCTION INPUT STRING ",A," CHARACTER LENGTH (",I4,") MUST BE EITHER 5 OR 6")') & @@ -190,21 +190,21 @@ integer function igetfxy ( str, cfxy ) result ( iret ) iret = -1 lstr = len ( str ) - if ( lstr .lt. 6 ) return + if ( lstr < 6 ) return ! Left-justify a copy of the input string. - if ( lstr .gt. lstr2 ) then + if ( lstr > lstr2 ) then str2(1:lstr2) = str(1:lstr2) else str2 = str endif str2 = adjustl ( str2 ) - if ( str2 .eq. ' ' ) return + if ( str2 == ' ' ) return ! Look for an FXY number. - if ( index ( str2, '-' ) .ne. 0 ) then + if ( index ( str2, '-' ) /= 0 ) then ! Format of field is F-XX-YYY. cfxy(1:1) = str2(1:1) cfxy(2:3) = str2(3:4) @@ -216,7 +216,7 @@ integer function igetfxy ( str, cfxy ) result ( iret ) ! Check that the FXY number is valid. - if ( numbck ( cfxy ) .eq. 0 ) iret = 0 + if ( numbck ( cfxy ) == 0 ) iret = 0 return end function igetfxy @@ -257,10 +257,10 @@ integer function numbck(numb) result(iret) return endif - if(ix.lt.0 .or. ix.gt. 63) then + if(ix<0 .or. ix> 63) then iret = -3 return - else if(iy.lt.0 .or. iy.gt.255) then + else if(iy<0 .or. iy>255) then iret = -4 return endif @@ -303,10 +303,10 @@ subroutine numtbd(lun,idn,nemo,tab,iret) iret = 0 tab = ' ' - if(idn.ge.ifxy('300000')) then + if(idn>=ifxy('300000')) then ! Look for idn in Table D do i=1,ntbd(lun) - if(idn.eq.idnd(i,lun)) then + if(idn==idnd(i,lun)) then nemo = tabd(i,lun)(7:14) tab = 'D' iret = i @@ -316,7 +316,7 @@ subroutine numtbd(lun,idn,nemo,tab,iret) else ! Look for idn in Table B do i=1,ntbb(lun) - if(idn.eq.idnb(i,lun)) then + if(idn==idnb(i,lun)) then nemo = tabb(i,lun)(7:14) tab = 'B' iret = i @@ -373,7 +373,7 @@ subroutine numtab(lun,idn,nemo,tab,iret) ! Look for a replicator or a replication factor descriptor - if(idn.ge.idnr(1) .and. idn.le.idnr(6)) then + if(idn>=idnr(1) .and. idn<=idnr(6)) then ! Note that the above test is checking whether idn is the bit-wise representation of a FXY (descriptor) value ! denoting F=1 regular (i.e. non-delayed) replication, since, as was initialized within subroutine bfrini(), ! idnr(1) = ifxy('101000'), and idnr(6) = ifxy('101255'). @@ -383,11 +383,11 @@ subroutine numtab(lun,idn,nemo,tab,iret) endif do i=2,5 - if(idn.eq.idnr(i)) then + if(idn==idnr(i)) then tab = 'R' iret = i return - elseif(idn.eq.idnr(i+5)) then + elseif(idn==idnr(i+5)) then tab = 'F' iret = i return @@ -397,12 +397,12 @@ subroutine numtab(lun,idn,nemo,tab,iret) ! Look for idn in Table B and Table D call numtbd(lun,idn,nemo,tab,iret) - if(iret.ne.0) return + if(iret/=0) return ! Look for idn in Table C cid = adn30(idn,6) - if (iokoper(cid).eq.1) then + if (iokoper(cid)==1) then nemo = cid(1:6) read(nemo,'(1X,I2)') iret tab = 'C' @@ -444,7 +444,7 @@ subroutine nemtab(lun,nemo,idn,tab,iret) logical folval - folval = nemo(1:1).eq.'.' + folval = nemo(1:1)=='.' iret = 0 tab = ' ' @@ -452,14 +452,14 @@ subroutine nemtab(lun,nemo,idn,tab,iret) outer: do i=1,ntbb(lun) nemt = tabb(i,lun)(7:14) - if(nemt.eq.nemo) then + if(nemt==nemo) then idn = idnb(i,lun) tab = 'B' iret = i return - elseif(folval.and.nemt(1:1).eq.'.') then + elseif(folval.and.nemt(1:1)=='.') then do j=2,len(nemt) - if(nemt(j:j).ne.'.' .and. nemt(j:j).ne.nemo(j:j)) cycle outer + if(nemt(j:j)/='.' .and. nemt(j:j)/=nemo(j:j)) cycle outer enddo idn = idnb(i,lun) tab = 'B' @@ -476,7 +476,7 @@ subroutine nemtab(lun,nemo,idn,tab,iret) do i=1,ntbd(lun) nemt = tabd(i,lun)(7:14) - if(nemt.eq.nemo) then + if(nemt==nemo) then idn = idnd(i,lun) tab = 'D' iret = i @@ -486,7 +486,7 @@ subroutine nemtab(lun,nemo,idn,tab,iret) ! If still nothing, check for Table C operator descriptors - if (iokoper(nemo).eq.1) then + if (iokoper(nemo)==1) then read(nemo,'(1X,I2)') iret idn = ifxy(nemo) tab = 'C' diff --git a/src/jumplink.F90 b/src/jumplink.F90 index eee27940..36f99f41 100644 --- a/src/jumplink.F90 +++ b/src/jumplink.F90 @@ -65,26 +65,26 @@ subroutine makestab do lun=1,nfiles xtab(lun) = .false. - if(iolun(lun).eq.0) then + if(iolun(lun)==0) then ! Logical unit iolun(lun) is not defined to NCEPLIBS-bufr. lus(lun) = 0 - else if(mtab(1,lun).eq.0) then + else if(mtab(1,lun)==0) then ! New dictionary table information has been read for logical unit iolun(lun) since the last call to this subroutine. xtab(lun) = .true. - if(lus(lun).ne.0) then - if(iolun(abs(lus(lun))).eq.0) then + if(lus(lun)/=0) then + if(iolun(abs(lus(lun)))==0) then lus(lun) = 0 - else if(lus(lun).gt.0) then + else if(lus(lun)>0) then ! iolun(lun) was sharing table information with logical unit iolun(lus(lun)), so check whether the table information ! has really changed. If not, then iolun(lun) just re-read a copy of the exact same table information as before, ! and therefore it can continue to share with logical unit iolun(lus(lun)). - if(icmpdx(lus(lun),lun).eq.1) then + if(icmpdx(lus(lun),lun)==1) then xtab(lun) = .false. call cpbfdx(lus(lun),lun) else lus(lun) = (-1)*lus(lun) endif - else if(icmpdx(abs(lus(lun)),lun).eq.1) then + else if(icmpdx(abs(lus(lun)),lun)==1) then ! iolun(lun) was not sharing table information with logical unit iolun(lus(lun)), but it did at one point in the past ! and now once again has the same table information as that logical unit. Since the two units shared table ! information at one point in the past, allow them to do so again. @@ -93,22 +93,22 @@ subroutine makestab call cpbfdx(lus(lun),lun) endif endif - else if(lus(lun).gt.0) then + else if(lus(lun)>0) then ! Logical unit iolun(lun) is sharing table information with logical unit iolun(lus(lun)), so make sure that the latter ! unit is still defined to NCEPLIBS-bufr. - if(iolun(lus(lun)).eq.0) then + if(iolun(lus(lun))==0) then lus(lun) = 0 - else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun).eq.0) ) then + else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun)==0) ) then ! The table information for logical unit iolun(lus(lun)) just changed (in midstream). If iolun(lun) is an output ! file, then we will have to update it with the new table information later on in this subroutine. Otherwise, ! iolun(lun) is an input file and is no longer sharing tables with iolun(lus(lun)). - if(iolun(lun).lt.0) lus(lun) = (-1)*lus(lun) + if(iolun(lun)<0) lus(lun) = (-1)*lus(lun) endif else ! Determine whether logical unit iolun(lun) is sharing table information with any other logical units. lum = 1 - do while ((lum.lt.lun).and.(lus(lun).eq.0)) - if(ishrdx(lum,lun).eq.1) then + do while ((lum0) then ! Reset any existing inventory pointers. - if(iomsg(lun).ne.0) then - if(lus(lun).le.0) then + if(iomsg(lun)/=0) then + if(lus(lun)<=0) then inc = (ntab+1)-mtab(1,lun) else inc = mtab(1,lus(lun))-mtab(1,lun) @@ -132,7 +132,7 @@ subroutine makestab inv(n,lun) = inv(n,lun)+inc enddo endif - if(lus(lun).le.0) then + if(lus(lun)<=0) then ! The dictionary table information corresponding to logical unit iolun(lun) has not yet been written into the internal ! jump/link table, so add it in now. call chekstab(lun) @@ -143,13 +143,13 @@ subroutine makestab mtab(itba,lun) = inod isc(inod) = ntab enddo - else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun).eq.0) ) then + else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun)==0) ) then ! Logical unit iolun(lun) is an output file that is sharing table information with logical unit iolun(lus(lun)) whose ! table just changed (in midstream). Flush any existing data messages from iolun(lun), then update the table information ! for this logical unit with the corresponding new table information from iolun(lus(lun)), then update iolun(lun) itself ! with a copy of the new table information. lunit = abs(iolun(lun)) - if(iomsg(lun).ne.0) call closmg(lunit) + if(iomsg(lun)/=0) call closmg(lunit) call cpbfdx(lus(lun),lun) lundx = abs(iolun(lus(lun))) call wrdxtb(lundx,lunit) @@ -160,43 +160,43 @@ subroutine makestab ! Store types and initial values and counts do node=1,ntab - if(typ(node).eq.'SUB') then + if(typ(node)=='SUB') then vali(node) = 0 knti(node) = 1 itp (node) = 0 - elseif(typ(node).eq.'SEQ') then + elseif(typ(node)=='SEQ') then vali(node) = 0 knti(node) = 1 itp (node) = 0 - elseif(typ(node).eq.'RPC') then + elseif(typ(node)=='RPC') then vali(node) = 0 knti(node) = 0 itp (node) = 0 - elseif(typ(node).eq.'RPS') then + elseif(typ(node)=='RPS') then vali(node) = 0 knti(node) = 0 itp (node) = 0 - elseif(typ(node).eq.'REP') then + elseif(typ(node)=='REP') then vali(node) = bmiss knti(node) = irf(node) itp (node) = 0 - elseif(typ(node).eq.'DRS') then + elseif(typ(node)=='DRS') then vali(node) = 0 knti(node) = 1 itp (node) = 1 - elseif(typ(node).eq.'DRP') then + elseif(typ(node)=='DRP') then vali(node) = 0 knti(node) = 1 itp (node) = 1 - elseif(typ(node).eq.'DRB') then + elseif(typ(node)=='DRB') then vali(node) = 0 knti(node) = 0 itp (node) = 1 - elseif(typ(node).eq.'NUM') then + elseif(typ(node)=='NUM') then vali(node) = bmiss knti(node) = 1 itp (node) = 2 - else ! typ(node).eq.'CHR' + else ! typ(node)=='CHR' vali(node) = bmiss knti(node) = 1 itp (nodE) = 3 @@ -210,7 +210,7 @@ subroutine makestab do n=1,ntab iseq(n,1) = 0 iseq(n,2) = 0 - expand = typ(n).eq.'SUB' .or. typ(n).eq.'DRP' .or. typ(n).eq.'DRS' .or. typ(n).eq.'REP' .or. typ(n).eq.'DRB' + expand = typ(n)=='SUB' .or. typ(n)=='DRP' .or. typ(n)=='DRS' .or. typ(n)=='REP' .or. typ(n)=='DRB' if(expand) then iseq(n,1) = newn+1 noda = n @@ -218,7 +218,7 @@ subroutine makestab do k=1,maxjl knt(k) = 0 enddo - if(typ(noda).eq.'REP') then + if(typ(noda)=='REP') then knt(node) = knti(noda) else knt(node) = 1 @@ -226,23 +226,23 @@ subroutine makestab outer: do while (.true.) newn = newn+1 - if(newn.gt.maxjl) then + if(newn>maxjl) then write(bort_str,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') maxjl call bort(bort_str) endif jseq(newn) = node knt(node) = max(knti(node),knt(node)) inner: do while (.true.) - if(jump(node)*knt(node).gt.0) then + if(jump(node)*knt(node)>0) then node = jump(node) cycle outer - else if(link(node).gt.0) then + else if(link(node)>0) then node = link(node) cycle outer else node = jmpb(node) - if(node.eq.noda) exit outer - if(node.eq.0) then + if(node==noda) exit outer + if(node==0) then write(bort_str,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO CIRCULATE (TAG IS ",A,")")') tag(n) call bort(bort_str) endif @@ -256,7 +256,7 @@ subroutine makestab ! Print the sequence tables - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') do n=1,ntab write ( unit=errstr, fmt='(A,I5,2X,A10,A5,6I8)' ) & @@ -293,16 +293,16 @@ subroutine chekstab(lun) ! There must be entries in Tables A, B, and D - if(ntba(lun).eq.0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES') - if(ntbb(lun).eq.0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES') - if(ntbd(lun).eq.0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES') + if(ntba(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES') + if(ntbb(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES') + if(ntbd(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES') ! Make sure each Table A entry is defined as a sequence do itab=1,ntba(lun) nemo = taba(itab,lun)(4:11) call nemtab(lun,nemo,idn,tab,iret) - if(tab.ne.'D') then + if(tab/='D') then write(bort_str,'("BUFRLIB: CHEKSTAB - TABLE A ENTRY: ",A," NOT DEFINED AS A SEQUENCE")') nemo call bort(bort_str) endif @@ -362,7 +362,7 @@ subroutine tabsub(lun,nemo) ! Table D mnemonics within internal BUFR Table D array tabd(*,lun). So the following test is valid. call nemtab(lun,nemo,idn,tab,itab) - if(tab.ne.'D') then + if(tab/='D') then write(bort_str,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D (TAB=",A,") FOR INPUT MNEMONIC ",A)') tab,nemo call bort(bort_str) endif @@ -392,7 +392,7 @@ subroutine tabsub(lun,nemo) ibtnrv = 0 ipfnrv = 0 - if(ntamc+1.gt.mxtamc) call bort('BUFRLIB: TABSUB - MXTAMC OVERFLOW') + if(ntamc+1>mxtamc) call bort('BUFRLIB: TABSUB - MXTAMC OVERFLOW') inodtamc(ntamc+1) = node ntco(ntamc+1) = 0 ltamc = .false. @@ -402,17 +402,17 @@ subroutine tabsub(lun,nemo) 11 do n=ntag(limb,1),ntag(limb,2) ntag(limb,1) = n+1 - drop(limb) = n.eq.ntag(limb,2) + drop(limb) = n==ntag(limb,2) call nemtab(lun,nem(n,limb),idn,tab,itab) nems = nem(n,limb) - if(tab.eq.'C') then + if(tab=='C') then ! Special treatment for certain operator descriptors. read(nems,'(3X,I3)') iyyy - if(itab.eq.1) then - if(iyyy.ne.0) then - if(icdw.ne.0) then + if(itab==1) then + if(iyyy/=0) then + if(icdw/=0) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// & 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) @@ -421,9 +421,9 @@ subroutine tabsub(lun,nemo) else icdw = 0 endif - elseif(itab.eq.2) then - if(iyyy.ne.0) then - if(icsc.ne.0) then + elseif(itab==2) then + if(iyyy/=0) then + if(icsc/=0) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// & 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) @@ -432,10 +432,10 @@ subroutine tabsub(lun,nemo) else icsc = 0 endif - elseif(itab.eq.3) then - if(iyyy.eq.0) then + elseif(itab==3) then + if(iyyy==0) then ! Stop applying new reference values to subset nodes. Instead, revert to the use of standard Table B values. - if(ipfnrv.eq.0) then + if(ipfnrv==0) then write(bort_str,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '// & 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR INPUT MNEMONIC ",A)') nemo call bort(bort_str) @@ -444,26 +444,26 @@ subroutine tabsub(lun,nemo) ienrv(jj) = ntab enddo ipfnrv = 0 - elseif(iyyy.eq.255) then + elseif(iyyy==255) then ! End the definition of new reference values. ibtnrv = 0 else ! Begin the definition of new reference values. - if(ibtnrv.ne.0) then + if(ibtnrv/=0) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// & 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif ibtnrv = iyyy endif - elseif(itab.eq.7) then - if(iyyy.gt.0) then - if(icdw.ne.0) then + elseif(itab==7) then + if(iyyy>0) then + if(icdw/=0) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// & 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(icsc.ne.0) then + if(icsc/=0) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// & 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) @@ -476,15 +476,15 @@ subroutine tabsub(lun,nemo) icdw = 0 icrv = 1 endif - elseif(itab.eq.8) then + elseif(itab==8) then incw = iyyy - elseif((itab.ge.21).and.(iokoper(nems).eq.1)) then + elseif((itab>=21).and.(iokoper(nems)==1)) then ! Save the location of this operator within the jump/link table, for possible later use. if(.not.ltamc) then ltamc = .true. ntamc = ntamc+1 end if - if(ntco(ntamc)+1.gt.mxtco) call bort('BUFRLIB: TABSUB - MXTCO OVERFLOW') + if(ntco(ntamc)+1>mxtco) call bort('BUFRLIB: TABSUB - MXTCO OVERFLOW') ntco(ntamc) = ntco(ntamc)+1 ctco(ntamc,ntco(ntamc)) = nems(1:6) inodtco(ntamc,ntco(ntamc)) = ntab @@ -497,11 +497,11 @@ subroutine tabsub(lun,nemo) call tabent(lun,nems,tab,itab,irep,iknt,jum0) endif - if(tab.eq.'D') then + if(tab=='D') then ! Note here how a new tree "limb" is created (and is then immediately recursively resolved) whenever a Table D mnemonic ! contains another Table D mnemonic as one of its children. limb = limb+1 - if(limb.gt.maxlim) then + if(limb>maxlim) then write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '// & 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE LIMIT IS",I4)') nemo,maxlim call bort(bort_str) @@ -515,33 +515,33 @@ subroutine tabsub(lun,nemo) do while (.true.) link(nodl(limb)) = 0 limb = limb-1 - if(limb.eq.0) then - if(icrv.ne.1) then + if(limb==0) then + if(icrv/=1) then write(bort_str,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '// & 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(icdw.ne.0) then + if(icdw/=0) then write(bort_str,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '// & 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(icsc.ne.0) then + if(icsc/=0) then write(bort_str,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '// & 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(incw.ne.0) then + if(incw/=0) then write(bort_str,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '// & 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(ibtnrv.ne.0) then + if(ibtnrv/=0) then write(bort_str,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '// & 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR INPUT MNEMONIC ",A)') nemo call bort(bort_str) endif - if(ipfnrv.ne.0) then + if(ipfnrv/=0) then ! One or more new reference values were defined for this subset, but there was no subsequent 2-03-000 operator, ! so set all IENRV(*) values for this subset to point to the last element of the subset within the jump/link table. ! Note that, if there had been a subsequent 2-03-000 operator, then these IENRV(*) values would have already been @@ -556,7 +556,7 @@ subroutine tabsub(lun,nemo) enddo link(nodl(limb)) = ntab+1 goto 11 - elseif(tab.ne.'C') then + elseif(tab/='C') then link(nodl(limb)) = ntab+1 endif @@ -606,10 +606,10 @@ subroutine tabent(lun,nemo,tab,itab,irep,iknt,jum0) ! Make a jump/link table entry for a replicator - if(irep.ne.0) then + if(irep/=0) then rtag = reps(irep)//nemo do i=1,10 - if(rtag(i:i).eq.' ') then + if(rtag(i:i)==' ') then rtag(i:i) = reps(irep+5) call inctab(rtag,typs(irep),node) jump(node) = node+1 @@ -618,7 +618,7 @@ subroutine tabent(lun,nemo,tab,itab,irep,iknt,jum0) ibt (node) = lens(irep) irf (node) = 0 isc (node) = 0 - if(irep.eq.1) irf(node) = iknt + if(irep==1) irf(node) = iknt jm0 = node exit endif @@ -627,9 +627,9 @@ subroutine tabent(lun,nemo,tab,itab,irep,iknt,jum0) ! Make a jump/link entry for an element or a sequence - if(tab.eq.'B') then + if(tab=='B') then call nemtbb(lun,itab,unit,iscl,iref,ibit) - if(unit(1:5).eq.'CCITT') then + if(unit(1:5)=='CCITT') then typt = 'CHR' else typt = 'NUM' @@ -641,29 +641,29 @@ subroutine tabent(lun,nemo,tab,itab,irep,iknt,jum0) ibt (node) = ibit irf (node) = iref isc (node) = iscl - if(unit(1:4).eq.'CODE') then + if(unit(1:4)=='CODE') then typt = 'COD' - elseif(unit(1:4).eq.'FLAG') then + elseif(unit(1:4)=='FLAG') then typt = 'FLG' endif - if( (typt.eq.'NUM') .and. (ibtnrv.ne.0) ) then + if( (typt=='NUM') .and. (ibtnrv/=0) ) then ! This node contains a new (redefined) reference value. - if(nnrv+1.gt.mxnrv) call bort('BUFRLIB: TABENT - MXNRV OVERFLOW') + if(nnrv+1>mxnrv) call bort('BUFRLIB: TABENT - MXNRV OVERFLOW') nnrv = nnrv+1 tagnrv(nnrv) = nemo inodnrv(nnrv) = node isnrv(nnrv) = node+1 ibt(node) = ibtnrv - if(ipfnrv.eq.0) ipfnrv = nnrv - elseif( (typt.eq.'NUM') .and. (nemo(1:3).ne.'204') ) then + if(ipfnrv==0) ipfnrv = nnrv + elseif( (typt=='NUM') .and. (nemo(1:3)/='204') ) then ibt(node) = ibt(node) + icdw isc(node) = isc(node) + icsc irf(node) = irf(node) * icrv - elseif( (typt.eq.'CHR') .and. (incw.gt.0) ) then + elseif( (typt=='CHR') .and. (incw>0) ) then ibt(node) = incw * 8 endif - else ! tab.eq.'D' - if(irep.eq.0) then + else ! tab=='D' + if(irep==0) then typt = 'SEQ' else typt = typs(irep+5) @@ -706,7 +706,7 @@ subroutine inctab(atag,atyp,node) character*128 bort_str ntab = ntab+1 - if(ntab.gt.maxjl) then + if(ntab>maxjl) then write(bort_str,'("BUFRLIB: INCTAB - THE NUMBER OF JUMP/LINK TABLE ENTRIES EXCEEDS THE LIMIT, MAXJL (",I7,")")') maxjl call bort(bort_str) endif @@ -750,11 +750,11 @@ integer function lstjpb(node,lun,jbtyp) result(iret) character*(*), intent(in) :: jbtyp character*128 bort_str - if(node.lt.inode(lun)) then + if(nodeisc(inode(lun))) then write(bort_str,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT OF BOUNDS, > UPPER BOUNDS (",I7,")")') node,isc(inode(lun)) call bort(bort_str) endif @@ -763,8 +763,8 @@ integer function lstjpb(node,lun,jbtyp) result(iret) ! Find this or the previous node of type jbtyp - do while (nod.ne.0) - if(typ(nod).eq.jbtyp) exit + do while (nod/=0) + if(typ(nod)==jbtyp) exit nod = jmpb(nod) enddo @@ -796,11 +796,11 @@ integer function ishrdx(lud,lun) result(iret) ! for each of the Table A mnemonics that is currently defined for that luX value. Thus, if all of these indices are ! identical for two different luX values, then the associated logical units are sharing table information. - if ( ( ntba(lud) .ge. 1 ) .and. ( ntba(lud) .eq. ntba(lun) ) ) then + if ( ( ntba(lud) >= 1 ) .and. ( ntba(lud) == ntba(lun) ) ) then ii = 1 iret = 1 - do while ( ( ii .le. ntba(lud) ) .and. ( iret .eq. 1 ) ) - if ( ( mtab(ii,lud) .ne. 0 ) .and. ( mtab(ii,lud) .eq. mtab(ii,lun) ) ) then + do while ( ( ii <= ntba(lud) ) .and. ( iret == 1 ) ) + if ( ( mtab(ii,lud) /= 0 ) .and. ( mtab(ii,lud) == mtab(ii,lun) ) ) then ii = ii + 1 else iret = 0 @@ -841,27 +841,27 @@ integer function icmpdx(lud,lun) result(iret) ! If so, then they obviously have the same table information. iret = ishrdx(lud,lun) - if ( iret .eq. 1 ) return + if ( iret == 1 ) return ! Otherwise, check whether the internal Table A, B and D entries are all identical between the two units. - if ( ( ntba(lud) .eq. 0 ) .or. ( ntba(lun) .ne. ntba(lud) ) ) return + if ( ( ntba(lud) == 0 ) .or. ( ntba(lun) /= 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) /= idna(i,lud,1) ) return + if ( idna(i,lun,2) /= idna(i,lud,2) ) return + if ( taba(i,lun) /= taba(i,lud) ) return enddo - if ( ( ntbb(lud) .eq. 0 ) .or. ( ntbb(lun) .ne. ntbb(lud) ) ) return + if ( ( ntbb(lud) == 0 ) .or. ( ntbb(lun) /= 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) /= idnb(i,lud) ) return + if ( tabb(i,lun) /= tabb(i,lud) ) return enddo - if ( ( ntbd(lud) .eq. 0 ) .or. ( ntbd(lun) .ne. ntbd(lud) ) ) return + if ( ( ntbd(lud) == 0 ) .or. ( ntbd(lun) /= 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) /= idnd(i,lud) ) return + if ( tabd(i,lun) /= tabd(i,lud) ) return enddo iret = 1 @@ -909,14 +909,14 @@ subroutine drstpl(inod,lun,inv1,inv2,invn) node = inod do while (.true.) node = jmpb(node) - if(node.eq.0) return - if(typ(node).eq.'DRS' .or. typ(node).eq.'DRB') then + if(node==0) return + if(typ(node)=='DRS' .or. typ(node)=='DRB') then invn = invwin(node,lun,inv1,inv2) - if(invn.gt.0) then + if(invn>0) then call usrtpl(lun,invn,1) call newwin(lun,inv1,inv2) invn = invwin(inod,lun,invn,inv2) - if(invn.gt.0) return + if(invn>0) return exit endif endif @@ -998,18 +998,18 @@ recursive subroutine nemspecs ( lunit, nemo, nnemo, nscl, nref, nbts, iret ) ! Get lun from lunit. call status( lunit, lun, il, im ) - if ( il .eq. 0 ) return - if ( inode(lun) .ne. inv(1,lun) ) return + if ( il == 0 ) return + if ( inode(lun) /= inv(1,lun) ) return ! Starting from the beginning of the subset, locate the (nnemo)th occurrence of nemo. call fstag( lun, nemo, nnemo, 1, nidx, ierfst ) - if ( ierfst .ne. 0 ) return + if ( ierfst /= 0 ) return ! Confirm that nemo is a Table B mnemonic. node = inv(nidx,lun) - if ( ( typ(node) .ne. 'NUM' ) .and. ( typ(node) .ne. 'CHR' ) ) return + if ( ( typ(node) /= 'NUM' ) .and. ( typ(node) /= 'CHR' ) ) return ! Get the scale factor, reference value and bit width, including accounting for any Table C operators which may be in ! scope for this particular occurrence of nemo. @@ -1020,18 +1020,18 @@ recursive subroutine nemspecs ( lunit, nemo, nnemo, nscl, nref, nbts, iret ) nbts = ibt(node) nref = irf(node) - if ( nnrv .gt. 0 ) then + if ( nnrv > 0 ) then ! There are nodes containing redefined reference values (from one or more 2-03-YYY operators) in the jump/link table, ! so we 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 + if ( ( ltn <= 0 ) .or. ( ltn > 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 + if ( ( node /= inodnrv(jj) ) .and. ( tagn(1:8) == tagnrv(jj) ) .and. & + ( node >= isnrv(jj) ) .and. ( node <= ienrv(jj) ) ) then nref = int(nrv(jj)) return end if @@ -1081,18 +1081,18 @@ subroutine fstag ( lun, utag, nutag, nin, nout, iret ) ! Confirm that there's only one mnemonic in the input string. call parstr( utag, tgs, maxtg, ntg, ' ', .true. ) - if ( ntg .ne. 1 ) return + if ( ntg /= 1 ) return ! Starting from nin, search either forward or backward for the (nutag)th occurrence of utag. - if ( nutag .eq. 0 ) return + if ( nutag == 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 + do while ( ( nout >= 1 ) .and. ( nout <= nval(lun) ) ) + if ( tgs(1) == tag(inv(nout,lun)) ) then itagct = itagct + 1 - if ( itagct .eq. iabs(nutag) ) then + if ( itagct == iabs(nutag) ) then iret = 0 return endif @@ -1158,13 +1158,13 @@ recursive subroutine gettagpr ( lunit, tagch, ntagch, tagpr, iret ) ! Get lun from lunit. call status( lunit, lun, il, im ) - if ( il .eq. 0 ) return - if ( inode(lun) .ne. inv(1,lun) ) return + if ( il == 0 ) return + if ( inode(lun) /= inv(1,lun) ) return ! Get tagpr from the (ntagch)th occurrence of tagch. call fstag( lun, tagch, ntagch, 1, nch, iret ) - if ( iret .ne. 0 ) return + if ( iret /= 0 ) return tagpr = tag(jmpb(inv(nch,lun))) @@ -1201,17 +1201,17 @@ integer function invtag(node,lun,inv1,inv2) result(iret) common /quiet/ iprt - if(node.ne.0) then + if(node/=0) then tagn = tag(node) ! Search between inv1 and inv2 do iret=inv1,inv2 - if(tag(inv(iret,lun)).eq.tagn) return + if(tag(inv(iret,lun))==tagn) return enddo endif iret = 0 - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt('BUFRLIB: INVTAG - RETURNING WITH A VALUE OF 0') call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') @@ -1249,10 +1249,10 @@ integer function invwin(node,lun,inv1,inv2) result(iret) common /quiet/ iprt iret = 0 - if(node.ne.0) then + if(node/=0) then ! Search between inv1 and inv2 do idx=inv1,inv2 - if(inv(idx,lun).eq.node) then + if(inv(idx,lun)==node) then iret = idx exit endif @@ -1324,23 +1324,23 @@ subroutine getwin(node,lun,iwin,jwin) irpc = lstjpb(node,lun,'RPC') - if(irpc.eq.0) then + if(irpc==0) then iwin = invwin(node,lun,jwin,nval(lun)) - if(iwin.eq.0 .and. jwin.gt.1) return + if(iwin==0 .and. jwin>1) return iwin = 1 jwin = nval(lun) return else iwin = invwin(irpc,lun,jwin,nval(lun)) - if(iwin.eq.0) return - if(val(iwin,lun).eq.0.) then + if(iwin==0) return + if(val(iwin,lun)==0.) then iwin = 0 return endif endif jwin = invwin(irpc,lun,iwin+1,nval(lun)) - if(jwin.eq.0) then + if(jwin==0) then write(bort_str,'("BUFRLIB: GETWIN - SEARCHED BETWEEN",I5," AND",I5,", MISSING BRACKET")') iwin+1, nval(lun) call bort(bort_str) endif @@ -1391,7 +1391,7 @@ subroutine conwin(lun,inc1,inc2) common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10) - if(ncon.eq.0) then + if(ncon==0) then ! There are no condition nodes in the string inc1 = 1 inc2 = nval(lun) @@ -1400,9 +1400,9 @@ subroutine conwin(lun,inc1,inc2) outer: do while (.true.) call getwin(nodc(1),lun,inc1,inc2) - if(inc1.gt.0) then + if(inc1>0) then do nc=1,ncon - if(invcon(nc,lun,inc1,inc2).eq.0) cycle outer + if(invcon(nc,lun,inc1,inc2)==0) cycle outer enddo endif exit @@ -1449,19 +1449,19 @@ integer function invcon(nc,lun,inv1,inv2) result(iret) common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10) common /quiet/ iprt - if(inv1.gt.0 .and. inv1.le.nval(lun) .and. inv2.gt.0 .and. inv2.le.nval(lun)) then + if(inv1>0 .and. inv1<=nval(lun) .and. inv2>0 .and. inv2<=nval(lun)) then do iret=inv1,inv2 - if(inv(iret,lun).eq.nodc(nc)) then - if(kons(nc).eq.1 .and. val(iret,lun).eq.ivls(nc)) return - if(kons(nc).eq.2 .and. val(iret,lun).ne.ivls(nc)) return - if(kons(nc).eq.3 .and. val(iret,lun).lt.ivls(nc)) return - if(kons(nc).eq.4 .and. val(iret,lun).gt.ivls(nc)) return + if(inv(iret,lun)==nodc(nc)) then + if(kons(nc)==1 .and. val(iret,lun)==ivls(nc)) return + if(kons(nc)==2 .and. val(iret,lun)/=ivls(nc)) return + if(kons(nc)==3 .and. val(iret,lun)ivls(nc)) return endif enddo endif iret = 0 - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt('BUFRLIB: INVCON - RETURNING WITH A VALUE OF 0') call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') @@ -1499,7 +1499,7 @@ subroutine newwin(lun,iwin,jwin) character*128 bort_str - if(iwin.eq.1) then + if(iwin==1) then ! This is a "SUB" (subset) node, so return jwin as pointing to the last value of the entire subset. jwin = nval(lun) return @@ -1507,7 +1507,7 @@ subroutine newwin(lun,iwin,jwin) ! Confirm that iwin points to an "RPC" node and then compute jwin. node = inv(iwin,lun) - if(lstjpb(node,lun,'RPC').ne.node) then + if(lstjpb(node,lun,'RPC')/=node) then write(bort_str,'("BUFRLIB: NEWWIN - LSTJPB FOR NODE",I6,'// & '" (LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN =",I8,")")') node, lstjpb(node,lun,'RPC'), iwin call bort(bort_str) @@ -1547,18 +1547,18 @@ subroutine nxtwin(lun,iwin,jwin) character*128 bort_str - if(jwin.eq.nval(lun)) then + if(jwin==nval(lun)) then iwin = 0 return endif node = inv(iwin,lun) - if(lstjpb(node,lun,'RPC').ne.node) then + if(lstjpb(node,lun,'RPC')/=node) then write(bort_str,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '// & '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN =",I8,")")') node, lstjpb(node,lun,'RPC'), iwin call bort(bort_str) endif - if(val(jwin,lun).eq.0) then + if(val(jwin,lun)==0) then iwin = 0 else iwin = jwin @@ -1601,8 +1601,8 @@ integer function nvnwin(node,lun,inv1,inv2,invn,nmax) result(iret) iret = 0 - if(node.eq.0) then - if(iprt.ge.1) then + if(node==0) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') call errwrt('BUFRLIB: NVNWIN - NODE=0, IMMEDIATE RETURN') call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') @@ -1618,8 +1618,8 @@ integer function nvnwin(node,lun,inv1,inv2,invn,nmax) result(iret) ! Search between inv1 and inv2 do n=inv1,inv2 - if(inv(n,lun).eq.node) then - if(iret+1.gt.nmax) then + if(inv(n,lun)==node) then + if(iret+1>nmax) then write(bort_str,'("BUFRLIB: NVNWIN - THE NUMBER OF EVENTS EXCEEDS THE LIMIT NMAX (",I5,")")') nmax call bort(bort_str) endif diff --git a/src/mastertable.F90 b/src/mastertable.F90 index 199060a6..e53cfa48 100644 --- a/src/mastertable.F90 +++ b/src/mastertable.F90 @@ -107,14 +107,14 @@ subroutine mtfnam ( imt, imtv, iogce, imtvl, tbltyp, stdfil, locfil ) ! Determine the standard master table path/filename. - if ( ( imt .eq. 0 ) .and. ( imtv .le. 13 ) ) then + if ( ( imt == 0 ) .and. ( imtv <= 13 ) ) then ! For master table 0, version 13 is a superset of all earlier 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 + if ( iprt >= 2 ) then call errwrt('Standard ' // tbltyp2(1:ltbt) // ':') call errwrt(stdfil) endif @@ -131,7 +131,7 @@ subroutine mtfnam ( imt, imtv, iogce, imtvl, tbltyp, stdfil, locfil ) 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 + if ( iprt >= 2 ) then call errwrt('Local ' // tbltyp2(1:ltbt) // ':') call errwrt(locfil) endif @@ -139,7 +139,7 @@ subroutine mtfnam ( imt, imtv, iogce, imtvl, tbltyp, stdfil, locfil ) if ( .not. found ) then ! Use the local table from NCEP. locfil = mtdir(1:lmtd) // '/bufrtab.' // tbltyp2(1:ltbt) // '_LOC_0_7_1' - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('Local ' // tbltyp2(1:ltbt) // ' not found, so using:') call errwrt(locfil) endif @@ -221,8 +221,8 @@ integer function ireadmt ( lun ) result ( iret ) ! Compare the master table and master table version numbers from this message to those from the message that was ! processed during 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 + if ( ( imt /= lmt ) .or. ( ( imt /= 0 ) .and. ( imtv /= lmtv ) ) .or. & + ( ( imt == 0 ) .and. ( imtv /= lmtv ) .and. ( ( imtv > 13 ) .or. ( lmtv > 13 ) ) ) ) then ! Either the master table number has changed ! OR ! The master table number hasn't changed, but it isn't 0, and the table version number has changed @@ -240,8 +240,8 @@ integer function ireadmt ( lun ) result ( iret ) 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 + do while ( (allstd) .and. (ii<=ncds3) ) + if ( istdesc(ifxy(cds3(ii))) == 0 ) then allstd = .false. else ii = ii + 1 @@ -251,32 +251,32 @@ integer function ireadmt ( lun ) result ( iret ) ! If there was at least one local (i.e. non-standard) descriptor, and if either the originating center or local table ! version number are different than those from the message that was processed during the previous call to this subroutine, ! then we need to read in new tables. - if ( ( .not. allstd ) .and. ( ( iogce .ne. logce ) .or. ( imtvl .ne. lmtvl ) ) ) iret = 1 + if ( ( .not. allstd ) .and. ( ( iogce /= logce ) .or. ( imtvl /= lmtvl ) ) ) iret = 1 endif - if ( iret .eq. 0 ) return + if ( iret == 0 ) return lmt = imt lmtv = imtv logce = iogce lmtvl = imtvl - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt(' ') call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') call errwrt('BUFRLIB: IREADMT - OPENING/READING MASTER TABLES') endif - if ( isc3(lun) .ne. 0 ) then + if ( isc3(lun) /= 0 ) then ! Locate and open the master Table B files. There should be one 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 ) call bort2(bort_str1, stdfil) + if ( ier /= 0 ) call bort2(bort_str1, stdfil) open ( unit = lun2, file = locfil, iostat = ier ) - if ( ier .ne. 0 ) call bort2(bort_str2, locfil) + if ( ier /= 0 ) call bort2(bort_str2, locfil) ! Read the master Table B files. call rdmtbb ( lun1, lun2, mxmtbb, ibmt, ibmtv, ibogce, ibltv, nmtb, ibfxyn, cbscl, cbsref, cbbw, & @@ -290,9 +290,9 @@ integer function ireadmt ( lun ) result ( iret ) ! descriptors. call mtfnam ( imt, imtv, iogce, imtvl, 'TableD', stdfil, locfil ) open ( unit = lun1, file = stdfil, iostat = ier ) - if ( ier .ne. 0 ) call bort2(bort_str1, stdfil) + if ( ier /= 0 ) call bort2(bort_str1, stdfil) open ( unit = lun2, file = locfil, iostat = ier ) - if ( ier .ne. 0 ) call bort2(bort_str2, locfil) + if ( ier /= 0 ) call bort2(bort_str2, locfil) ! Read the master Table D files. call rdmtbd ( lun1, lun2, mxmtbd, maxcd, idmt, idmtv, idogce, idltv, nmtd, idfxyn, cdmnem, cmdscd, cdseq, & @@ -313,15 +313,15 @@ integer function ireadmt ( lun ) result ( iret ) ndelem, idefxy, maxcd ) endif - if ( cdmf .eq. 'Y' ) then + if ( cdmf == 'Y' ) then ! Locate and open the master code and flag table files. There should be one file corresponding to the standard Table B ! descriptors, and one file corresponding to the local Table B descriptors. call mtfnam ( imt, imtv, iogce, imtvl, 'CodeFlag', stdfil, locfil ) open ( unit = lun1, file = stdfil, iostat = ier ) - if ( ier .ne. 0 ) call bort2(bort_str1, stdfil) + if ( ier /= 0 ) call bort2(bort_str1, stdfil) open ( unit = lun2, file = locfil, iostat = ier ) - if ( ier .ne. 0 ) call bort2(bort_str2, locfil) + if ( ier /= 0 ) call bort2(bort_str2, locfil) ! Read the master code and flag table files. call rdmtbf ( lun1, lun2 ) @@ -331,7 +331,7 @@ integer function ireadmt ( lun ) result ( iret ) close ( unit = lun2 ) endif - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') call errwrt(' ') endif @@ -390,21 +390,21 @@ subroutine rdmtbb ( lunstb, lunltb, mxmtbb, imt, imtv, iogce, iltv, nmtbb, imfxy 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 + do while ( ( iers == 0 ) .or. ( ierl == 0 ) ) + if ( ( iers == 0 ) .and. ( ierl == 0 ) ) then + if ( isfxyn == ilfxyn ) then cmatch = adn30 ( isfxyn, 6 ) 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) - else if ( isfxyn .lt. ilfxyn ) then + else if ( isfxyn < 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 + else if ( iers == 0 ) then call sntbbe ( isfxyn, stline, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmunit, cmmnem, cmdsc, cmelem ) call getntbe ( lunstb, isfxyn, stline, iers ) else @@ -469,21 +469,21 @@ subroutine rdmtbd ( lunstd, lunltd, mxmtbd, mxelem, imt, imtv, iogce, iltv, nmtb 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 + do while ( ( iers == 0 ) .or. ( ierl == 0 ) ) + if ( ( iers == 0 ) .and. ( ierl == 0 ) ) then + if ( isfxyn == ilfxyn ) then cmatch = adn30 ( isfxyn, 6 ) 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) - else if ( isfxyn .lt. ilfxyn ) then + else if ( isfxyn < 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 + else if ( iers == 0 ) then call sntbde ( lunstd, isfxyn, stline, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cmdsc, cmseq, nmelem, iefxyn, ceelem ) call getntbe ( lunstd, isfxyn, stline, iers ) else @@ -529,21 +529,21 @@ subroutine rdmtbf ( lunstf, lunltf ) 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 + do while ( ( iers == 0 ) .or. ( ierl == 0 ) ) + if ( ( iers == 0 ) .and. ( ierl == 0 ) ) then + if ( isfxyn == ilfxyn ) then cmatch = adn30 ( isfxyn, 6 ) 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) - else if ( isfxyn .lt. ilfxyn ) then + else if ( isfxyn < ilfxyn ) then call sntbfe ( lunstf, isfxyn ) call getntbe ( lunstf, isfxyn, stline, iers ) else call sntbfe ( lunltf, ilfxyn ) call getntbe ( lunltf, ilfxyn, ltline, ierl ) endif - else if ( iers .eq. 0 ) then + else if ( iers == 0 ) then call sntbfe ( lunstf, isfxyn ) call getntbe ( lunstf, isfxyn, stline, iers ) else @@ -590,7 +590,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu character*200 tags(10), wktag character*128 bort_str1, bort_str2 - if ( nmtbb .ge. mxmtbb ) call bort('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') + if ( nmtbb >= mxmtbb ) call bort('BUFRLIB: SNTBBE - OVERFLOW OF MERGED ARRAYS') nmtbb = nmtbb + 1 ! Store the FXY number. This is the element descriptor. @@ -600,7 +600,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu ! Parse the table entry. call parstr ( line, tags, 10, ntag, '|', .false. ) - if ( ntag .lt. 4 ) then + if ( ntag < 4 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS TOO FEW FIELDS' call bort2(bort_str1, bort_str2) @@ -609,7 +609,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu ! Scale factor. tags(2) = adjustl( tags(2) ) - if ( tags(2) .eq. ' ' ) then + if ( tags(2) == ' ' ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS MISSING SCALE FACTOR' call bort2(bort_str1, bort_str2) @@ -622,7 +622,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu ! Reference value. tags(3) = adjustl( tags(3) ) - if ( tags(3) .eq. ' ' ) then + if ( tags(3) == ' ' ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS MISSING REFERENCE VALUE' call bort2(bort_str1, bort_str2) @@ -635,7 +635,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu ! Bit width. tags(4) = adjustl( tags(4) ) - if ( tags(4) .eq. ' ' ) then + if ( tags(4) == ' ' ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS MISSING BIT WIDTH' call bort2(bort_str1, bort_str2) @@ -647,7 +647,7 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu ! Units. Note that this field is allowed to be blank. - if ( ntag .gt. 4 ) then + if ( ntag > 4 ) then tags(5) = adjustl( tags(5) ) do ii = 1, 24 cmunit ( ii, nmtbb ) = tags(5)(II:II) @@ -667,14 +667,14 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu do ii = 1, 120 cmelem ( ii, nmtbb ) = ' ' enddo - if ( ntag .gt. 5 ) then + if ( ntag > 5 ) then wktag = tags(6) call parstr ( wktag, tags, 10, ntag, ';', .false. ) - if ( ntag .gt. 0 ) then + if ( ntag > 0 ) then ! The first additional field contains the mnemonic. tags(1) = adjustl( tags(1) ) ! If there is a mnemonic, then make sure it's legal. - if ( ( tags(1) .ne. ' ' ) .and. ( nemock ( tags(1) ) .ne. 0 ) ) then + if ( ( tags(1) /= ' ' ) .and. ( nemock ( tags(1) ) /= 0 ) ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS ILLEGAL MNEMONIC' call bort2(bort_str1, bort_str2) @@ -683,12 +683,12 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu cmmnem ( ii, nmtbb ) = tags(1)(ii:ii) enddo endif - if ( ntag .gt. 1 ) then + if ( ntag > 1 ) then ! The second additional field contains descriptor codes. tags(2) = adjustl( tags(2) ) cmdsc ( nmtbb ) = tags(2)(1:4) endif - if ( ntag .gt. 2 ) then + if ( ntag > 2 ) then ! The third additional field contains the element name. tags(3) = adjustl( tags(3) ) do ii = 1, 120 @@ -737,7 +737,7 @@ subroutine sntbde ( lunt, ifxyn, line, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cm logical done - if ( nmtbd .ge. mxmtbd ) call bort('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') + if ( nmtbd >= mxmtbd ) call bort('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') nmtbd = nmtbd + 1 ! Store the FXY number. This is the sequence descriptor. @@ -754,14 +754,14 @@ subroutine sntbde ( lunt, ifxyn, line, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cm cmseq ( ii, nmtbd ) = ' ' enddo ipt = index ( line, '|' ) - if ( ipt .ne. 0 ) then + if ( ipt /= 0 ) then ! 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 + if ( ntag > 0 ) then ! The first additional field contains the mnemonic. tags(1) = adjustl( tags(1) ) ! If there is a mnemonic, then make sure it's legal. - if ( ( tags(1) .ne. ' ' ) .and. ( nemock ( tags(1) ) .ne. 0 ) ) then + if ( ( tags(1) /= ' ' ) .and. ( nemock ( tags(1) ) /= 0 ) ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS ILLEGAL MNEMONIC' call bort2(bort_str1, bort_str2) @@ -770,12 +770,12 @@ subroutine sntbde ( lunt, ifxyn, line, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cm cmmnem ( ii, nmtbd ) = tags(1)(ii:ii) enddo endif - if ( ntag .gt. 1 ) then + if ( ntag > 1 ) then ! The second additional field contains descriptor codes. tags(2) = adjustl( tags(2) ) cmdsc ( nmtbd ) = tags(2)(1:4) endif - if ( ntag .gt. 2 ) then + if ( ntag > 2 ) then ! The third additional field contains the sequence name. tags(3) = adjustl( tags(3) ) do ii = 1, 120 @@ -790,35 +790,35 @@ subroutine sntbde ( lunt, ifxyn, line, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cm nelem = 0 done = .false. do while ( .not. done ) - if ( igetntbl ( lunt, cline ) .ne. 0 ) then + if ( igetntbl ( lunt, cline ) /= 0 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' IS INCOMPLETE' call bort2(bort_str1, bort_str2) endif call parstr ( cline, tags, 10, ntag, '|', .false. ) - if ( ntag .lt. 2 ) then + if ( ntag < 2 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD ELEMENT CARD' call bort2(bort_str1, bort_str2) endif ! The second field contains the FXY number for this element. - if ( igetfxy ( tags(2), adsc ) .ne. 0 ) then + if ( igetfxy ( tags(2), adsc ) /= 0 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD OR MISSING ELEMENT FXY NUMBER' call bort2(bort_str1, bort_str2) endif - if ( nelem .ge. mxelem ) CALL BORT('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') + if ( nelem >= mxelem ) CALL BORT('BUFRLIB: SNTBDE - OVERFLOW OF MERGED ARRAYS') nelem = nelem + 1 iefxyn ( nmtbd, nelem ) = ifxy ( adsc ) ! The third field (if it exists) contains the element name. - if ( ntag .gt. 2 ) then + if ( ntag > 2 ) then tags(3) = adjustl( tags(3) ) ceelem ( nmtbd, nelem ) = tags(3)(1:120) else ceelem ( nmtbd, nelem ) = ' ' endif ! Is this the last line for this table entry? - if ( index ( tags(2), ' >' ) .eq. 0 ) done = .true. + if ( index ( tags(2), ' >' ) == 0 ) done = .true. enddo nmelem ( nmtbd ) = nelem @@ -858,38 +858,38 @@ subroutine sntbfe ( lunt, ifxyn ) do while ( .not. done ) - if ( igetntbl ( lunt, cline ) .ne. 0 ) then + if ( igetntbl ( lunt, cline ) /= 0 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' IS INCOMPLETE' call bort2(bort_str1, bort_str2) endif call parstr ( cline, tags, 4, ntag, '|', .false. ) - if ( ( ntag .lt. 2 ) .or. ( ntag .gt. 3 ) ) then + if ( ( ntag < 2 ) .or. ( ntag > 3 ) ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD CARD' call bort2(bort_str1, bort_str2) endif - if ( ntag .eq. 2 ) then + if ( ntag == 2 ) then ! This line contains a list of dependencies. call parstr ( tags(2), cdstr, 2, ntag, '=', .false. ) - if ( ntag .ne. 2 ) then + if ( ntag /= 2 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD DEPENDENCY CARD' call bort2(bort_str1, bort_str2) endif ! Parse the list of FXY numbers. call parstr ( cdstr(1), adsc, 10, nidfxy, ',', .false. ) - if ( ( nidfxy .eq. 0 ) .or. ( ( nidfxy .eq. 1 ) .and. ( adsc(1) .eq. ' ' ) ) ) then + if ( ( nidfxy == 0 ) .or. ( ( nidfxy == 1 ) .and. ( adsc(1) == ' ' ) ) ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD DEPENDENCY LIST (FXY)' call bort2(bort_str1, bort_str2) endif do ii = 1, nidfxy - if ( igetfxy ( adsc(ii), cdsc ) .ne. 0 ) then + if ( igetfxy ( adsc(ii), cdsc ) /= 0 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD DEPENDENCY (FXY)' call bort2(bort_str1, bort_str2) @@ -898,7 +898,7 @@ subroutine sntbfe ( lunt, ifxyn ) enddo ! Parse the list of values. call parstr ( cdstr(2), cval, 25, nidval, ',', .false. ) - if ( ( nidval .eq. 0 ) .or. ( ( nidval .eq. 1 ) .and. ( cval(1) .eq. ' ' ) ) ) then + if ( ( nidval == 0 ) .or. ( ( nidval == 1 ) .and. ( cval(1) == ' ' ) ) ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD DEPENDENCY LIST (VAL)' call bort2(bort_str1, bort_str2) @@ -906,7 +906,7 @@ subroutine sntbfe ( lunt, ifxyn ) do ii = 1, nidval cval(ii) = adjustl( cval(ii) ) call strnum ( cval(ii), ival, ier ) - if ( ier .ne. 0 ) then + if ( ier /= 0 ) then call sntbestr(bort_str1_head, ifxyn, bort_str1) bort_str2 = ' HAS BAD DEPENDENCY (VAL)' call bort2(bort_str1, bort_str2) @@ -919,7 +919,7 @@ subroutine sntbfe ( lunt, ifxyn ) ! This line contains a value (code figure or bit number) and corresponding meaning. ipt = index ( tags(2), ' >' ) - if ( ipt .eq. 0 ) then + if ( ipt == 0 ) then ! This is the last line for this table entry. done = .true. else @@ -931,15 +931,15 @@ subroutine sntbfe ( lunt, ifxyn ) 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 + do while ( ( lt3 > 0 ) .and. ( .not. lstnblk ) ) + if ( tags(3)(lt3:lt3) /= ' ' ) then lstnblk = .true. else lt3 = lt3 - 1 endif enddo ! Store the information for this value within the internal memory structure. - if ( ( nidfxy .eq. 0 ) .and. ( nidval .eq. 0 ) ) then + if ( ( nidfxy == 0 ) .and. ( nidval == 0 ) ) then call strtbfe_c ( ifxyn, ival, tags(3), lt3, -1, -1 ) else do ii = 1, nidfxy @@ -1000,11 +1000,11 @@ integer function igetntbl ( lunt, line ) result ( iret ) do while (.true.) read ( lunt, '(A)', iostat = ier ) line - if ( ( ier .ne. 0 ) .or. ( line(1:3) .eq. 'END' ) ) then + if ( ( ier /= 0 ) .or. ( line(1:3) == 'END' ) ) then iret = -1 return endif - if ( ( line .ne. ' ' ) .and. ( line(1:1) .ne. '#' ) ) then + if ( ( line /= ' ' ) .and. ( line(1:1) /= '#' ) ) then iret = 0 return endif @@ -1035,14 +1035,14 @@ integer function igettdi ( iflag ) result ( iret ) save idx - if ( iflag .eq. 0 ) then + if ( iflag == 0 ) then ! Initialize the index to one less than the actual minimum value. That way, the next normal call will return the ! minimum value. idx = idxmin - 1 iret = -1 else idx = idx + 1 - if ( idx .gt. idxmax ) call bort('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') + if ( idx > idxmax ) call bort('BUFRLIB: IGETTDI - IDXMAX OVERFLOW') iret = idx endif @@ -1088,19 +1088,19 @@ subroutine gettbh ( luns, lunl, tab, imt, imtv, iogce, iltv ) logical badlabel ! 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 ) == 0 ) .or. ( index ( label, cftyp ) == 0 ) ) cttyp = tab // ' ' ! Read and parse the header line of the standard file. cftyp = 'STD' - if ( igetntbl ( luns, header ) .ne. 0 ) then + if ( igetntbl ( luns, header ) /= 0 ) then bort_str = bort_str_head // cftyp // ' TABLE ' // tab call bort(bort_str) endif call parstr ( header, tags, 5, ntag, '|', .false. ) - if ( ( ntag .lt. 3 ) .or. ( badlabel ( tags(1) ) ) ) then + if ( ( ntag < 3 ) .or. ( badlabel ( tags(1) ) ) ) then bort_str = bort_str_head // cftyp // ' TABLE ' // tab call bort(bort_str) endif @@ -1110,12 +1110,12 @@ subroutine gettbh ( luns, lunl, tab, imt, imtv, iogce, iltv ) ! Read and parse the header line of the local file. cftyp = 'LOC' - if ( igetntbl ( lunl, header ) .ne. 0 ) then + if ( igetntbl ( lunl, header ) /= 0 ) then bort_str = bort_str_head // cftyp // ' TABLE ' // tab call bort(bort_str) endif call parstr ( header, tags, 5, ntag, '|', .false. ) - if ( ( ntag .lt. 4 ) .or. ( badlabel ( tags(1) ) ) ) then + if ( ( ntag < 4 ) .or. ( badlabel ( tags(1) ) ) ) then bort_str = bort_str_head // cftyp // ' TABLE ' // tab call bort(bort_str) endif @@ -1125,7 +1125,7 @@ subroutine gettbh ( luns, lunl, tab, imt, imtv, iogce, iltv ) ! Verify that both files are for the same master table. - if ( imt .ne. imt2 ) then + if ( imt /= imt2 ) then write(bort_str,'("BUFRLIB: GETTBH - MASTER TABLE NUMBER MISMATCH BETWEEN STD AND LOC TABLE ",A)') tab call bort(bort_str) endif @@ -1160,10 +1160,10 @@ subroutine getntbe ( lunt, ifxyn, line, iret ) ! Get the first line of the next entry in the file. iret = igetntbl ( lunt, line ) - if ( iret .eq. 0 ) then + if ( iret == 0 ) then ! The first field within this line should contain the FXY number. call parstr ( line(1:20), tags, 4, ntag, '|', .false. ) - if ( igetfxy ( tags(1), adsc ) .ne. 0 ) then + if ( igetfxy ( tags(1), adsc ) /= 0 ) then bort_str1 = 'BUFRLIB: GETNTBE - CARD BEGINNING WITH: ' // line(1:20) bort_str2 = ' HAS BAD OR MISSING FXY NUMBER' call bort2(bort_str1, bort_str2) @@ -1216,7 +1216,7 @@ subroutine codflg(cf) character*128 bort_str call capit(cf) - if(cf.ne.'Y'.and. cf.ne.'N') then + if(cf/='Y'.and. cf/='N') then write(bort_str,'("BUFRLIB: CODFLG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf call bort(bort_str) endif @@ -1249,12 +1249,12 @@ integer function nemock(nemo) result(iret) lnemo = 0 do i=len(nemo),1,-1 - if(nemo(i:i).ne.' ') then + if(nemo(i:i)/=' ') then lnemo = i exit endif enddo - if(lnemo.lt.1 .or. lnemo.gt.8) then + if(lnemo<1 .or. lnemo>8) then iret = -1 return endif diff --git a/src/memmsgs.F90 b/src/memmsgs.F90 index d0184c32..fca4971f 100644 --- a/src/memmsgs.F90 +++ b/src/memmsgs.F90 @@ -73,7 +73,7 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) call openbf(lunit,'IN',lunit) - if(inew.eq.0) then + if(inew==0) then msgp(0) = 0 munit = 0 mlast = 0 @@ -99,19 +99,19 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) ! If a table was indeed present at the beginning of the file, then set the flag to indicate that this table is now in scope. - if ((itemp+1).eq.ndxts) ldxts = ndxts + if ((itemp+1)==ndxts) ldxts = ndxts ! Transfer messages from file to memory and set message pointers do while (.true.) call rdmsgw(lunit,mgwa,ier) - if(ier.eq.-1) exit - if(ier.eq.-2) then + if(ier==-1) exit + if(ier==-2) then write(bort_str,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit call bort(bort_str) endif - if(idxmsg(mgwa).eq.1) then + if(idxmsg(mgwa)==1) then ! New "embedded" BUFR dictionary table messages have been found in this file. Copy them into @ref moda_msgmem ! for later use. call backbufr_c(lun) ! Backspace lunit @@ -120,11 +120,11 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) endif nmsg = nmsg+1 - if(nmsg.gt.maxmsg) iflg = 1 + if(nmsg>maxmsg) iflg = 1 lmem = nmwrd(mgwa) - if(lmem+mlast.gt.maxmem) iflg = 2 + if(lmem+mlast>maxmem) iflg = 2 - if(iflg.eq.0) then + if(iflg==0) then iret = iret+1 do i=1,lmem msgs(mlast+i) = mgwa(i) @@ -132,7 +132,7 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) msgp(0) = nmsg msgp(nmsg) = mlast+1 else - if(itim.eq.0) then + if(itim==0) then mlast0 = mlast itim=1 endif @@ -140,9 +140,9 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) mlast = mlast+lmem enddo - if(iflg.eq.1) then + if(iflg==1) then ! Emergency room treatment for maxmsg array overflow - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', & 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ' @@ -157,9 +157,9 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) mlast=mlast0 endif - if(iflg.eq.2) then + if(iflg==2) then ! Emergency room treatment for maxmem array overflow - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', & 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ' @@ -174,11 +174,11 @@ recursive subroutine ufbmem(lunit,inew,iret,iunit) mlast=mlast0 endif - if(iret.eq.0) then + if(iret==0) then call closbf(lunit) else - if(munit.ne.0) call closbf(lunit) - if(munit.eq.0) munit = lunit + if(munit/=0) call closbf(lunit) + if(munit==0) munit = lunit endif iunit = munit @@ -238,7 +238,7 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) call x84(lunit(1),my_lunit(1),1) call x84(lundx(1),my_lundx(1),1) call x84(inew(1),my_inew(1),1) - if (my_inew(1).eq.0) then + if (my_inew(1)==0) then nmesg = 0 else nmesg = msgp(0) @@ -256,7 +256,7 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) call openbf(lunit(1),'IN',lundx(1)) - if(inew(1).eq.0) then + if(inew(1)==0) then msgp(0) = 0 munit = 0 mlast = 0 @@ -281,19 +281,19 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) do while (.true.) call rdmsgw(lunit(1),mgwa,ier) - if(ier.eq.-1) exit - if(ier.eq.-2) then + if(ier==-1) exit + if(ier==-2) then write(bort_str,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit(1) call bort(bort_str) endif nmsg = nmsg+1 mesg(nmsg) = iupbs01(mgwa,'MTYP') - if(nmsg.gt.maxmsg) iflg = 1 + if(nmsg>maxmsg) iflg = 1 lmem = nmwrd(mgwa) - if(lmem+mlast.gt.maxmem) iflg = 2 + if(lmem+mlast>maxmem) iflg = 2 - if(iflg.eq.0) then + if(iflg==0) then iret(1) = iret(1)+1 do i=1,lmem msgs(mlast+i) = mgwa(i) @@ -301,7 +301,7 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) msgp(0) = nmsg msgp(nmsg) = mlast+1 else - if(itim.eq.0) then + if(itim==0) then mlast0 = mlast itim=1 endif @@ -309,9 +309,9 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) mlast = mlast+lmem enddo - if(iflg.eq.1) then + if(iflg==1) then ! Emergency room treatment for maxmsg array overflow - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', & 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ' @@ -326,9 +326,9 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) mlast=mlast0 endif - if(iflg.eq.2) then + if(iflg==2) then ! Emergency room treatment for maxmem array overflow - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', & 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ' @@ -343,11 +343,11 @@ recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg) mlast=mlast0 endif - if(iret(1).eq.0) then + if(iret(1)==0) then call closbf(lunit(1)) else - if(munit.ne.0) call closbf(lunit(1)) - if(munit.eq.0) munit = lunit(1) + if(munit/=0) call closbf(lunit(1)) + if(munit==0) munit = lunit(1) endif return @@ -525,11 +525,11 @@ recursive subroutine rdmemm(imsg,subset,jdate,iret) call wtstat(munit,lun,il,1) iret = 0 - if(imsg.eq.0 .or.imsg.gt.msgp(0)) then + if(imsg==0 .or.imsg>msgp(0)) then call wtstat(munit,lun,il,0) - if(iprt.ge.1) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - if(imsg.eq.0) then + if(imsg==0) then errstr = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH IRET = -1' else write ( unit=errstr, fmt='(A,I6,A,I6,A)' ) 'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', imsg, & @@ -547,8 +547,8 @@ 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 + do while ((.not.known).and.(jj>=1)) + if (ipmsgs(jj)<=imsg) then known = .true. else jj = jj - 1 @@ -561,11 +561,11 @@ recursive subroutine rdmemm(imsg,subset,jdate,iret) ! Is this table the one that is currently in scope? - if (jj.ne.ldxts) then + if (jj/=ldxts) then ! No, so reset the software to use the proper table. - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I3,A,I3,A,I6)' ) 'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', jj, & ' INSTEAD OF DX TABLE #', ldxts, ' FOR REQUESTED MESSAGE #', imsg @@ -578,7 +578,7 @@ recursive subroutine rdmemm(imsg,subset,jdate,iret) ! Store each of the DX dictionary messages which constitute this table. do ii = ifdxts(jj), (ifdxts(jj)+icdxts(jj)-1) - if (ii.eq.ndxm) then + if (ii==ndxm) then nwrd = ldxm - ipdxm(ii) + 1 else nwrd = ipdxm(ii+1) - ipdxm(II) @@ -598,8 +598,8 @@ recursive subroutine rdmemm(imsg,subset,jdate,iret) ! Read memory message number imsg into a message buffer. iptr = msgp(imsg) - if(imsg.lt.msgp(0)) lptr = msgp(imsg+1)-iptr - if(imsg.eq.msgp(0)) lptr = mlast-iptr+1 + if(imsgmsub(lun)) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I5,A,A,I5,A)' ) 'BUFRLIB: RDMEMS - REQ. SUBSET #', isub, ' (= 1st INPUT ', & 'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', msub(lun), ')' @@ -692,12 +692,12 @@ recursive subroutine rdmems(isub,iret) ! Position to subset number isub in memory message - if(msgunp(lun).eq.0) then + if(msgunp(lun)==0) then nsub(lun) = isub-1 do i=1,isub-1 mbyt(lun) = mbyt(lun) + iupb(mbay(1,lun),mbyt(lun)+1,16) enddo - elseif(msgunp(lun).eq.1) then + elseif(msgunp(lun)==1) then ! message with "standard" Section 3 do i=1,isub-1 call readsb(munit,iret) @@ -710,7 +710,7 @@ recursive subroutine rdmems(isub,iret) ! Now read subset number isub from memory message call readsb(munit,iret) - if(iret.ne.0) call bort('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED WITH IRET = -1 (EITHER MEMORY MESSAGE '// & + if(iret/=0) call bort('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED WITH IRET = -1 (EITHER MEMORY MESSAGE '// & 'NOT OPEN OR ALL SUBSETS IN MESSAGE READ') ! Reset subset pointer back to zero (beginning of message) and return @@ -746,7 +746,7 @@ subroutine cpdxmm( lunit ) common /quiet/ iprt - if ( ndxts .ge. mxdxts ) call bort('BUFRLIB: CPDXMM - MXDXTS OVERFLOW') + if ( ndxts >= mxdxts ) call bort('BUFRLIB: CPDXMM - MXDXTS OVERFLOW') ict = 0 done = .false. @@ -756,8 +756,8 @@ subroutine cpdxmm( lunit ) do while ( .not. done ) call rdmsgw ( lunit, mgwa, ier ) - if ( ier .eq. -2 ) call bort('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR') - if ( ier .eq. -1 ) then + if ( ier == -2 ) call bort('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR') + if ( ier == -1 ) then ! Don't abort for an end-of-file condition, since it may be possible for a file to end with dictionary messages. ! Instead, backspace the file pointer and let the calling routine diagnose the end-of-file condition and deal with @@ -765,14 +765,14 @@ subroutine cpdxmm( lunit ) call backbufr_c(lun) done = .true. - else if ( idxmsg(mgwa) .ne. 1 ) then + else if ( idxmsg(mgwa) /= 1 ) then ! This is a non-DX dictionary message. Assume we've reached the end of the dictionary table, and backspace lunit so ! that the next read (e.g. in the calling routine) will get this same message. call backbufr_c(lun) done = .true. - else if ( iupbs3(mgwa,'nsub') .eq. 0 ) then + else if ( iupbs3(mgwa,'nsub') == 0 ) then ! This is a DX dictionary message, but it doesn't contain any actual dictionary information. Assume we've reached the ! end of the dictionary table. @@ -783,10 +783,10 @@ subroutine cpdxmm( lunit ) ! Store this message into @ref moda_msgmem. ict = ict + 1 - if ( ( ndxm + ict ) .gt. mxdxm ) call bort('BUFRLIB: CPDXMM - MXDXM OVERFLOW') + if ( ( ndxm + ict ) > mxdxm ) call bort('BUFRLIB: CPDXMM - MXDXM OVERFLOW') ipdxm(ndxm+ict) = ldxm + 1 lmem = nmwrd(mgwa) - if ( ( ldxm + lmem ) .gt. mxdxw ) call bort('BUFRLIB: CPDXMM - MXDXW OVERFLOW') + if ( ( ldxm + lmem ) > mxdxw ) call bort('BUFRLIB: CPDXMM - MXDXW OVERFLOW') do j = 1, lmem mdx(ldxm+j) = mgwa(j) enddo @@ -796,13 +796,13 @@ subroutine cpdxmm( lunit ) ! Update the table information within @ref moda_msgmem. - if ( ict .gt. 0 ) then + if ( ict > 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 + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I3,A,I3,A)') 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', ndxts, & ' CONSISTING OF ', ict, ' MESSAGES' @@ -870,8 +870,8 @@ recursive subroutine ufbmms(imsg,isub,subset,jdate) ! Read subset #isub from memory message #imsg call rdmemm(imsg,subset,jdate,iret) - if(iret.lt.0) then - if(imsg.gt.0) then + if(iret<0) then + if(imsg>0) then write(bort_str,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// & 'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0) else @@ -880,7 +880,7 @@ recursive subroutine ufbmms(imsg,isub,subset,jdate) call bort(bort_str) endif call rdmems(isub,iret) - if(iret.ne.0) then + if(iret/=0) then call status(munit,lun,il,im) write(bort_str,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// & 'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg @@ -941,8 +941,8 @@ recursive subroutine ufbmns(irep,subset,idate) ! Read subset #irep - do while(ireadmm(imsg,subset,idate).eq.0) - if(jrep+nmsub(munit).ge.irep) then + do while(ireadmm(imsg,subset,idate)==0) + if(jrep+nmsub(munit)>=irep) then call rdmems(irep-jrep,iret) return endif @@ -1011,8 +1011,8 @@ recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str) endif iret = 0 - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -1021,8 +1021,8 @@ recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.ge.0) then + elseif(i2<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -1036,8 +1036,8 @@ recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str) ! Read requested values from subset #isub within memory message #imsg call rdmemm(imsg,subset,jdate,iret) - if(iret.lt.0) then - if(imsg.gt.0) then + if(iret<0) then + if(imsg>0) then write(bort_str,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// & 'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0) else @@ -1046,7 +1046,7 @@ recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str) call bort(bort_str) endif call rdmems(isub,iret) - if(iret.ne.0) then + if(iret/=0) then call status(munit,lun,il,im) write(bort_str,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// & 'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg @@ -1151,7 +1151,7 @@ recursive subroutine ufbtam(tab,i1,i2,iret,str) iret = 0 - if(msgp(0).eq.0) return + if(msgp(0)==0) return do j=1,i2 do i=1,i1 @@ -1166,9 +1166,9 @@ recursive subroutine ufbtam(tab,i1,i2,iret,str) isub = 0 itbl = 0 do i=1,ntg - if(tgs(i).eq.'IREC') irec = i - if(tgs(i).eq.'ISUB') isub = i - if(tgs(i).eq.'ITBL') itbl = i + if(tgs(i)=='IREC') irec = i + if(tgs(i)=='ISUB') isub = i + if(tgs(i)=='ITBL') itbl = i enddo call status(munit,lun,il,im) @@ -1177,32 +1177,32 @@ recursive subroutine ufbtam(tab,i1,i2,iret,str) outer: do imsg=1,msgp(0) call rdmemm(imsg,subset,jdate,mret) - if(mret.lt.0) then + if(mret<0) then write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') imsg call bort(bort_str) endif call string(str,lun,i1,0) - if(irec.gt.0) nods(irec) = 0 - if(isub.gt.0) nods(isub) = 0 - if(itbl.gt.0) nods(itbl) = 0 + if(irec>0) nods(irec) = 0 + if(isub>0) nods(isub) = 0 + if(itbl>0) nods(itbl) = 0 ! Process all the subsets in the memory message - do while (nsub(lun).lt.msub(lun)) - if(iret+1.gt.i2) then + do while (nsub(lun)i2) then ! Emergency room treatment for array overflow call rdmemm(0,subset,jdate,mret) nrep = 0 do kmsg=1,msgp(0) call rdmemm(kmsg,subset,jdate,mret) - if(mret.lt.0) then + if(mret<0) then write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') kmsg call bort(bort_str) endif nrep = nrep+nmsub(munit) enddo - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A,A)' ) 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', & 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - INCOMPLETE READ' @@ -1226,25 +1226,25 @@ recursive subroutine ufbtam(tab,i1,i2,iret,str) nbit = 0 n = 1 - inner: do while(n+1.le.nval(lun)) + inner: do while(n+1<=nval(lun)) n = n+1 node = inv(n,lun) mbit = mbit+nbit nbit = ibt(node) - if(itp(node).eq.1) then + if(itp(node)==1) then call upb8(ival,nbit,mbit,mbay(1,lun)) nbmp=int(ival) call usrtpl(lun,n,nbmp) endif do i=1,nnod - if(nods(i).eq.node) then - if(itp(node).eq.1) then + if(nods(i)==node) then + if(itp(node)==1) then call upb8(ival,nbit,mbit,mbay(1,lun)) tab(i,iret) = ival - elseif(itp(node).eq.2) then + elseif(itp(node)==2) then call upb8(ival,nbit,mbit,mbay(1,lun)) - if(ival.lt.mps(node)) tab(i,iret) = ups(ival,node) - elseif(itp(node).eq.3) then + if(ival0) cycle inner enddo enddo inner @@ -1265,9 +1265,9 @@ recursive subroutine ufbtam(tab,i1,i2,iret,str) call upb(nbyt,16,mbay(1,lun),ibit) mbyt(lun) = mbyt(lun) + nbyt nsub(lun) = nsub(lun) + 1 - if(irec.gt.0) tab(irec,iret) = nmsg(lun) - if(isub.gt.0) tab(isub,iret) = nsub(lun) - if(itbl.gt.0) tab(itbl,iret) = ldxts + if(irec>0) tab(irec,iret) = nmsg(lun) + if(isub>0) tab(isub,iret) = nsub(lun) + if(itbl>0) tab(itbl,iret) = ldxts enddo enddo outer diff --git a/src/misc.F90.in b/src/misc.F90.in index 478c7dfa..82259d29 100644 --- a/src/misc.F90.in +++ b/src/misc.F90.in @@ -114,10 +114,10 @@ subroutine bfrini idxv = 1 do j=1,10 - ldxa(j) = nldxa(j) - ldxb(j) = nldxb(j) - ldxd(j) = nldxd(j) - ld30(j) = nld30(j) + ldxa(j) = nldxa(j) + ldxb(j) = nldxb(j) + ldxd(j) = nldxd(j) + ld30(j) = nld30(j) dxstr(j) = ' ' nxstr(j) = ndndx(j)*2 do i=1,ndndx(j) @@ -199,9 +199,9 @@ recursive subroutine strnum( str, num, iret ) iret = 0 num = 0 call strsuc ( str, str2, lens ) - if ( lens .eq. 0 ) return + if ( lens == 0 ) return read ( str2(1:lens), '(I40)', iostat = ios ) num - if ( ios .ne. 0 ) iret = -1 + if ( ios /= 0 ) iret = -1 return end subroutine strnum @@ -313,14 +313,14 @@ subroutine jstnum(str,sign,iret) iret = 0 - if(str.eq.' ') call bort('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT ALLOWED') + if(str==' ') call bort('BUFRLIB: JSTNUM - INPUT BLANK CHARACTER STRING NOT ALLOWED') str = adjustl(str) lstr = len(str) - if(str(1:1).eq.'+') then + if(str(1:1)=='+') then str = str(2:lstr) sign = '+' - elseif(str(1:1).eq.'-') then + elseif(str(1:1)=='-') then str = str(2:lstr) sign = '-' else @@ -328,8 +328,8 @@ subroutine jstnum(str,sign,iret) endif call strnum(str,num,ier) - if(ier.lt.0) then - if(iprt.ge.0) then + if(ier<0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: JSTNUM: ENCODED VALUE WITHIN RESULTANT CHARACTER STRING (' // str // ') IS NOT AN INTEGER - '// & 'RETURN WITH IRET = -1' @@ -364,7 +364,7 @@ subroutine capit(str) do i=1,len(str) do j=1,26 - if(str(i:i).eq.lwcs(j:j)) then + if(str(i:i)==lwcs(j:j)) then str(i:i) = upcs(j:j) exit endif @@ -385,7 +385,7 @@ subroutine bvers (cverstr) character*(*), intent(out) :: cverstr - if (len(cverstr).lt.8) call bort('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE FOR AT LEAST 8 CHARACTERS') + if (len(cverstr)<8) call bort('BUFRLIB: BVERS - INPUT STRING MUST CONTAIN SPACE FOR AT LEAST 8 CHARACTERS') cverstr = '@PROJECT_VERSION@' @@ -411,9 +411,9 @@ integer function isize (num) result (iret) character*128 bort_str - if ( num .ge. 0 ) then + if ( num >= 0 ) then do iret = 1, 5 - if ( num .lt. 10**iret ) return + if ( num < 10**iret ) return enddo endif write(bort_str,'("BUFRLIB: ISIZE - INPUT NUMBER (",I7,") IS OUT OF RANGE")') num @@ -464,7 +464,7 @@ recursive integer function igetsc(lunit) result(iret) ! Make sure the specified logical unit is connected to the library. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: IGETSC - BUFR FILE IS CLOSED, IT MUST BE OPEN') iret = iscodes(lun) @@ -487,17 +487,17 @@ integer function iokoper(nemo) result(iret) character*(*), intent(in) :: nemo - if ( len(nemo).lt.6 ) then + if ( len(nemo)<6 ) then iret = 0 else if ( lge(nemo(1:3),'201') .and. lle(nemo(1:3),'208') ) then iret = 1 - else if ( nemo(1:3).eq.'221' ) then + else if ( nemo(1:3)=='221' ) then iret = 1 - else if ( ( ( nemo(4:6).eq.'000' ) .or. ( nemo(4:6).eq.'255' ) ) .and. & - ( ( nemo(1:3).eq.'237' ) .or. ( lge(nemo(1:3),'241') .and. lle(nemo(1:3),'243') ) ) ) then + else if ( ( ( nemo(4:6)=='000' ) .or. ( nemo(4:6)=='255' ) ) .and. & + ( ( nemo(1:3)=='237' ) .or. ( lge(nemo(1:3),'241') .and. lle(nemo(1:3),'243') ) ) ) then iret = 1 - else if ( ( nemo(4:6).eq.'000' ) .and. ( ( lge(nemo(1:3),'222') .and. lle(nemo(1:3),'225') ) .or. & - ( nemo(1:3).eq.'232' ) .or. ( nemo(1:3).eq.'235' ) .or. ( nemo(1:3).eq.'236' ) ) ) then + else if ( ( nemo(4:6)=='000' ) .and. ( ( lge(nemo(1:3),'222') .and. lle(nemo(1:3),'225') ) .or. & + ( nemo(1:3)=='232' ) .or. ( nemo(1:3)=='235' ) .or. ( nemo(1:3)=='236' ) ) ) then iret = 1 else iret = imrkopr(nemo) @@ -520,7 +520,7 @@ subroutine mrginv common /mrgcom/ nrpl, nmrg, namb, ntot common /quiet/ iprt - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++') call errwrt('---------------------------------------------------') call errwrt('INVENTORY FROM MERGE PROCESS IN SUBROUTINE INVMRG:') diff --git a/src/missing.F90 b/src/missing.F90 index 38d2cc33..0233271c 100644 --- a/src/missing.F90 +++ b/src/missing.F90 @@ -29,7 +29,7 @@ integer function ibfms ( r8val ) result ( iret ) real*8, intent(in) :: r8val - if ( r8val .eq. bmiss ) then + if ( r8val == bmiss ) then iret = 1 else iret = 0 @@ -92,13 +92,13 @@ recursive integer function icbfms ( str, lstr ) result ( iret ) ! "missing" string by storing the real*8 value of 10E10 into the string. So for consistency with historical archives, ! the following logic attempts to identify some of these earlier cases, at least for strings between 4 and 8 bytes in length. - if ( numchr.ge.4 .and. numchr.le.8 ) then + if ( numchr>=4 .and. numchr<=8 ) then do ii = 1, numchr strz(ii:ii) = str(ii:ii) end do write (zz,'(z16.16)') rl8z ii = 2*(8-numchr)+1 - if ( zz(ii:16).eq.zm_be(ii:16) .or. zz(ii:16).eq.zm_le(ii:16) ) then + if ( zz(ii:16)==zm_be(ii:16) .or. zz(ii:16)==zm_le(ii:16) ) then iret = 1 return end if @@ -109,7 +109,7 @@ recursive integer function icbfms ( str, lstr ) result ( iret ) do ii=1,numchr strz(1:1) = str(ii:ii) - if ( iupm(strz(1:1),8).ne.255 ) return + if ( iupm(strz(1:1),8)/=255 ) return enddo iret = 1 diff --git a/src/openbt.F90 b/src/openbt.F90 index 86208fc3..d115a129 100644 --- a/src/openbt.F90 +++ b/src/openbt.F90 @@ -51,7 +51,7 @@ recursive subroutine openbt(lundx,mtyp) return endif - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE'// & ' CALLED BY CKTABA OR APPL. PGM; OPENBT SHOULD BE INCL. IN-LINE IN APPL. PGM' diff --git a/src/openclosebf.F90 b/src/openclosebf.F90 index 2cd78852..ec04764a 100644 --- a/src/openclosebf.F90 +++ b/src/openclosebf.F90 @@ -212,15 +212,15 @@ recursive subroutine openbf(lunit,io,lundx) ! If this is the first call to this subroutine, initialize iprt in /quiet/ as 0 - if(ifopbf.eq.0) iprt = 0 + if(ifopbf==0) iprt = 0 - if(io.eq.'QUIET') then + if(io=='QUIET') then ! override previous iprt value (printout indicator) iprtprv = iprt iprt = lundx - if(iprt.lt.-1) iprt = -1 - if(iprt.gt.3) iprt = 3 - if(iprt.ge.0) then + if(iprt<-1) iprt = -1 + if(iprt>3) iprt = 3 + if(iprt>=0) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') write ( unit=errstr, FMT='(A,I3,A,A,I3,A)' ) 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR CHNGED FROM', & iprtprv,cprint(iprtprv+1),' TO',iprt,cprint(iprt+1) @@ -230,7 +230,7 @@ recursive subroutine openbf(lunit,io,lundx) endif endif - if(ifopbf.eq.0) then + if(ifopbf==0) then ! This is the first call to this subroutine, so take care of some initial housekeeping tasks. ! Note that arallocf and arallocc_c must be called before calling bfrini. @@ -243,17 +243,17 @@ recursive subroutine openbf(lunit,io,lundx) ifopbf = 1 endif - if( (io.eq.'FIRST') .or. (io.eq.'QUIET') ) return + if( (io=='FIRST') .or. (io=='QUIET') ) return ! See if a file can be opened call status(lunit,lun,il,im) - if(lun.eq.0) then + if(lun==0) then write(bort_str,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3," BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') & nfiles,lunit call bort(bort_str) endif - if(il.ne.0) then + if(il/=0) then write(bort_str,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT",I5," IS ALREADY OPEN")') lunit call bort(bort_str) endif @@ -264,7 +264,7 @@ recursive subroutine openbf(lunit,io,lundx) ! Use inquire to obtain the filename associated with unit lunit - if (io.ne.'NUL' .and. io.ne.'INUL') then + if (io/='NUL' .and. io/='INUL') then inquire(lunit,access=fileacc) if(fileacc=='UNDEFINED') open(lunit) inquire(lunit,name=filename) @@ -279,41 +279,41 @@ recursive subroutine openbf(lunit,io,lundx) ! Decide how to open the file and setup the dictionary - if(io.eq.'IN') then + if(io=='IN') then call openrb_c(lun,filename) call wtstat(lunit,lun,-1,0) call readdx(lunit,lun,lundx) - else if(io.eq.'INUL') then + else if(io=='INUL') then call wtstat(lunit,lun,-1,0) - if(lunit.ne.lundx) call readdx(lunit,lun,lundx) + if(lunit/=lundx) call readdx(lunit,lun,lundx) null(lun) = 1 - else if(io.eq.'NUL') then + else if(io=='NUL') then call wtstat(lunit,lun,1,0) - if(lunit.ne.lundx) call readdx(lunit,lun,lundx) + if(lunit/=lundx) call readdx(lunit,lun,lundx) null(lun) = 1 - else if(io.eq.'INX') then + else if(io=='INX') then call openrb_c(lun,filename) call wtstat(lunit,lun,-1,0) null(lun) = 1 - else if(io.eq.'OUX') then + else if(io=='OUX') then call openwb_c(lun,filename) call wtstat(lunit,lun,1,0) - else if(io.eq.'SEC3') then + else if(io=='SEC3') then call openrb_c(lun,filename) call wtstat(lunit,lun,-1,0) isc3(lun) = 1 - else if(io.eq.'OUT') then + else if(io=='OUT') then call openwb_c(lun,filename) call wtstat(lunit,lun,1,0) call writdx(lunit,lun,lundx) - else if(io.eq.'NODX') then + else if(io=='NODX') then call openwb_c(lun,filename) call wtstat(lunit,lun,1,0) call readdx(lunit,lun,lundx) - else if(io.eq.'APN' .or. io.eq.'APX') then + else if(io=='APN' .or. io=='APX') then call openab_c(lun,filename) call wtstat(lunit,lun,1,0) - if(lunit.ne.lundx) call readdx(lunit,lun,lundx) + if(lunit/=lundx) call readdx(lunit,lun,lundx) call posapx(lunit) else call bort('BUFRLIB: OPENBF - ILLEGAL SECOND (INPUT) ARGUMENT') @@ -370,13 +370,13 @@ recursive subroutine closbf(lunit) endif call status(lunit,lun,il,im) - if(il.gt.0 .and. im.ne.0) call closmg(lunit) - if(il.ne.0 .and. null(lun).eq.0) call closfb_c(lun) + if(il>0 .and. im/=0) call closmg(lunit) + if(il/=0 .and. null(lun)==0) call closfb_c(lun) call wtstat(lunit,lun,0,0) ! Close Fortran unit if null(lun) = 0 - if(null(lun).eq.0) close(lunit) + if(null(lun)==0) close(lunit) return end subroutine closbf @@ -431,7 +431,7 @@ recursive subroutine status(lunit,lun,il,im) return endif - if(lunit.le.0 .or. lunit.gt.99) then + if(lunit<=0 .or. lunit>99) then write(bort_str,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") OUTSIDE LEGAL RANGE OF 1-99")') lunit call bort(bort_str) endif @@ -453,14 +453,14 @@ recursive subroutine status(lunit,lun,il,im) endif do i=1,nfiles - if(abs(iolun(i)).eq.lunit) lun = i + if(abs(iolun(i))==lunit) lun = i enddo ! If not, try to define it so as to connect it to the library - if(lun.eq.0) then + if(lun==0) then do i=1,nfiles - if(iolun(i).eq.0) then + if(iolun(i)==0) then ! File space is available, return with lun > 0, il and im remain 0 lun = i return @@ -517,20 +517,20 @@ subroutine wtstat(lunit,lun,il,im) ! Check on the arguments - if(lunit.le.0) then + if(lunit<=0) then write(bort_str,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED INTO FIRST ARGUMENT (INPUT) (=",I3,")")') lunit call bort(bort_str) endif - if(lun.le.0) then + if(lun<=0) then write(bort_str,'("BUFRLIB: WTSTAT - INVALID FILE ID PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') lun call bort(bort_str) endif - if(il.lt.-1 .or. il.gt.1) then + if(il<-1 .or. il>1) then write(bort_str,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS INDICATOR PASSED INTO THIRD ARGUMENT '// & '(INPUT) (=",I4,")")') il call bort(bort_str) endif - if(im.lt. 0 .or. im.gt.1) then + if(im< 0 .or. im>1) then write(bort_str,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS INDICATOR PASSED INTO FOURTH ARGUMENT '// & '(INPUT) (=",I4,")")') im call bort(bort_str) @@ -538,7 +538,7 @@ subroutine wtstat(lunit,lun,il,im) ! Check on lunit-lun combination - if(abs(iolun(lun)).ne.lunit .and. (iolun(lun).ne.0)) then + if(abs(iolun(lun))/=lunit .and. (iolun(lun)/=0)) then write(bort_str,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE EXISTING FILE UNIT (LOGICAL UNIT '// & 'NUMBER ",I3,")")') iolun(lun) call bort(bort_str) @@ -546,7 +546,7 @@ subroutine wtstat(lunit,lun,il,im) ! Reset the file statuses - if(il.ne.0) then + if(il/=0) then iolun(lun) = sign(lunit,il) iomsg(lun) = im else @@ -609,7 +609,7 @@ recursive subroutine ufbcnt(lunit,kmsg,ksub) ! Check the file status - return the message and subset counters call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBCNT - BUFR FILE IS CLOSED, IT MUST BE OPEN FOR EITHER INPUT OR OUTPUT') + if(il==0) call bort('BUFRLIB: UFBCNT - BUFR FILE IS CLOSED, IT MUST BE OPEN FOR EITHER INPUT OR OUTPUT') kmsg = nmsg(lun) ksub = nsub(lun) @@ -641,15 +641,15 @@ subroutine posapx(lunxx) lunit = abs(lunxx) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(il==0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') ! Try to read to the end of the file do while (.true.) call rdmsgw(lunit,mgwa,ier) - if(ier.lt.0) return - if(idxmsg(mgwa).eq.1) then + if(ier<0) return + if(idxmsg(mgwa)==1) then ! This is an internal dictionary message that was generated by the NCEPLIBS-bufr software. Backspace the file pointer ! and then read and store all such dictionary messages (they should be stored consecutively!) and reset the internal tables. call backbufr_c(lun) @@ -707,20 +707,20 @@ subroutine rewnbf(lunit,isr) character*8 subset ! Try to trap bad call problems - if(isr.eq.0) then + if(isr==0) then call status(lunit,lun,il,im) - if(jsr(lun).ne.0) then + if(jsr(lun)/=0) then write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// & 'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED (AND NOT YET RESTORED) (UNIT",I3,")")') lunit call bort(bort_str) endif - if(il.eq.0) then + if(il==0) then write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// & 'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT OR OUTPUT) (UNIT",I3,")")') lunit call bort(bort_str) endif - elseif(isr.eq.1) then - if(junn.eq.0 .or. jsr(junn).ne.1) then + elseif(isr==1) then + if(junn==0 .or. jsr(junn)/=1) then write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// & 'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') lunit call bort(bort_str) @@ -732,7 +732,7 @@ subroutine rewnbf(lunit,isr) call bort(bort_str) endif - if(isr.eq.0) then + if(isr==0) then ! Store the existing file parameters jmsg = nmsg(lun) jsub = nsub(lun) @@ -754,7 +754,7 @@ subroutine rewnbf(lunit,isr) ! Rewind the file call cewind_c(lun) - if(isr.eq.1) then + if(isr==1) then ! Restore the previous file parameters. Note that we already restored the previous value of lun earlier in this routine. ! Reset nmsg(lun) to 0, so that the below calls to readmg() will internally restore nmsg(lun) to the correct value. @@ -765,7 +765,7 @@ subroutine rewnbf(lunit,isr) ! was an input file. do i=1,jmsg call readmg(lunit,subset,kdate,ier) - if(ier.lt.0) then + if(ier<0) then write(bort_str,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// & 'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE NO.",I5)') lunit, jmsg call bort(bort_str) @@ -911,7 +911,7 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) lunit = abs(lunin) call status(lunit,lun,il,im) - openit = il.eq.0 + openit = il==0 if(openit) then ! Open BUFR file connected to unit lunit if it isn't already open @@ -939,34 +939,34 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) overflow = .false. ! Check for count subset only option - just_count = lunin.lt.lunit + just_count = lunin=0) iret = iret+nmsub(lunit) enddo else ! Check for special tags in string call parstr(str,tgs,maxtg,ntg,' ',.true.) do i=1,ntg - if(tgs(i).eq.'IREC') irec = i - if(tgs(i).eq.'ISUB') isub = i + if(tgs(i)=='IREC') irec = i + if(tgs(i)=='ISUB') isub = i enddo endif outer: do while (.not. just_count) ! Read the next message from the file - if(ireadmg(-lunit,subset,jdate).lt.0) exit + if(ireadmg(-lunit,subset,jdate)<0) exit call string(str,lun,i1,0) - if(irec.gt.0) nods(irec) = 0 - if(isub.gt.0) nods(isub) = 0 + if(irec>0) nods(irec) = 0 + if(isub>0) nods(isub) = 0 - if(msgunp(lun).ne.2) then + if(msgunp(lun)/=2) then ! The message is uncompressed inner1: do while (.true.) ! Get the next subset from the message - if(nsub(lun).eq.msub(lun)) cycle outer - if(iret+1.gt.i2) then + if(nsub(lun)==msub(lun)) cycle outer + if(iret+1>i2) then overflow = .true. exit outer endif @@ -984,25 +984,25 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) call usrtpl(lun,n,n) inner2: do while (.true.) ! Cycle through each node of the subset to look for the requested values - if(n+1.le.nval(lun)) then + if(n+1<=nval(lun)) then n = n+1 node = inv(n,lun) mbit = mbit+nbit nbit = ibt(node) - if(itp(node).eq.1) then + if(itp(node)==1) then call upb8(ival,nbit,mbit,mbay(1,lun)) nbmp=int(ival) call usrtpl(lun,n,nbmp) endif do i=1,nnod - if(nods(i).eq.node) then - if(itp(node).eq.1) then + if(nods(i)==node) then + if(itp(node)==1) then call upb8(ival,nbit,mbit,mbay(1,lun)) tab(i,iret) = ival - elseif(itp(node).eq.2) then + elseif(itp(node)==2) then call upb8(ival,nbit,mbit,mbay(1,lun)) - if(ival.lt.mps(node)) tab(i,iret) = ups(ival,node) - elseif(itp(node).eq.3) then + if(ival0) cycle inner2 enddo endif exit @@ -1027,21 +1027,21 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) mbyt(lun) = mbit endif nsub(lun) = nsub(lun) + 1 - if(irec.gt.0) tab(irec,iret) = nmsg(lun) - if(isub.gt.0) tab(isub,iret) = nsub(lun) + if(irec>0) tab(irec,iret) = nmsg(lun) + if(isub>0) tab(isub,iret) = nsub(lun) enddo inner1 else ! The message is compressed - if(iret+msub(lun).gt.i2) then + if(iret+msub(lun)>i2) then overflow = .true. exit outer endif - if(irec.gt.0.or.isub.gt.0) then + if(irec>0.or.isub>0) then do nsb=1,msub(lun) - if(irec.gt.0) tab(irec,iret+nsb) = nmsg(lun) - if(isub.gt.0) tab(isub,iret+nsb) = nsb + if(irec>0) tab(irec,iret+nsb) = nmsg(lun) + if(isub>0) tab(isub,iret+nsb) = nsb enddo endif call usrtpl(lun,1,1) @@ -1052,7 +1052,7 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) node = inv(n,lun) nbit = ibt(node) ityp = itp(node) - if(n.eq.1) then + if(n==1) then ! Reset the node indices do i=1,nnod nods(i) = abs(nods(i)) @@ -1061,18 +1061,18 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) ! Are we still looking for more values? need_node = .false. do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then need_node = .true. exit endif enddo if(.not. need_node) exit inner3 endif - if(ityp.eq.1 .or. ityp.eq.2) then + if(ityp==1 .or. ityp==2) then call up8(lref,nbit,mbay(1,lun),ibit) call upb(linc,6,mbay(1,lun),ibit) nibit = ibit + linc*msub(lun) - elseif(ityp.eq.3) then + elseif(ityp==3) then cref=' ' call upc(cref,nbit/8,mbay(1,lun),ibit,.true.) call upb(linc,6,mbay(1,lun),ibit) @@ -1080,7 +1080,7 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) else cycle endif - if(ityp.eq.1) then + if(ityp==1) then ! This is a delayed replication node jbit = ibit + linc call up8(ninc,linc,mbay(1,lun),jbit) @@ -1089,21 +1089,21 @@ recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str) cycle endif do i=1,nnod - if(node.eq.nods(i)) then + if(node==nods(i)) then ! This is one of the requested values, so store the corresponding value from each subset in the message nods(i) = -nods(i) lret = iret - if(ityp.eq.1 .or. ityp.eq.2) then + if(ityp==1 .or. ityp==2) then do nsb=1,msub(lun) jbit = ibit + linc*(nsb-1) call up8(ninc,linc,mbay(1,lun),jbit) ival = lref+ninc lret = lret+1 - if(ninc.lt.lps(linc)) tab(i,lret) = ups(ival,node) + if(ninc=0) nrep = nrep+nmsub(lunit) enddo - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', & 'IS .GT. LIMIT OF ', i2, ' IN THE 4TH ARG. (INPUT) - INCOMPLETE READ' diff --git a/src/readwritemg.F90 b/src/readwritemg.F90 index 005446b5..07cb899b 100644 --- a/src/readwritemg.F90 +++ b/src/readwritemg.F90 @@ -81,15 +81,15 @@ recursive subroutine readmg(lunxx,subset,jdate,iret) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(il==0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') call wtstat(lunit,lun,il,1) ! Read a message into the internal message buffer do while (.true.) call rdmsgw(lunit,mbay(1,lun),ier) - if(ier.eq.-1) then + if(ier==-1) then ! EOF on attempted read call wtstat(lunit,lun,il,0) inode(lun) = 0 @@ -101,20 +101,20 @@ recursive subroutine readmg(lunxx,subset,jdate,iret) endif ! Parse the message section contents - if(isc3(lun).ne.0) call reads3(lun) + if(isc3(lun)/=0) call reads3(lun) call cktaba(lun,subset,jdate,iret) ! Check for a dictionary message - if(idxmsg(mbay(1,lun)).ne.1) return + if(idxmsg(mbay(1,lun))/=1) return ! This is an internal dictionary message that was generated by the NCEPLIBS-bufr software. - if(isc3(lun).ne.0) return + if(isc3(lun)/=0) return ! Section 3 decoding isn't being used, so backspace the file pointer and then use subroutine rdbfdx() to read in ! all such dictionary messages (they should be stored consecutively!) and reset the internal tables. call backbufr_c(lun) call rdbfdx(lunit,lun) - if(iprt.ge.1) then + if(iprt>=1) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') errstr = 'BUFRLIB: READMG - INTERNAL DICTIONARY MESSAGE READ; ACCOUNT FOR IT THEN READ IN NEXT MESSAGE WITHOUT RETURNING' call errwrt(errstr) @@ -256,8 +256,8 @@ recursive subroutine readerme(mesg,lunit,subset,jdate,iret) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(il==0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') call wtstat(lunit,lun,il, 1) ! Copy the input message into the internal message buffer @@ -265,7 +265,7 @@ recursive subroutine readerme(mesg,lunit,subset,jdate,iret) iec0(1) = mesg(1) iec0(2) = mesg(2) lnmsg = lmsg(sec0) - if(lnmsg*nbytw.gt.mxmsgl) then + if(lnmsg*nbytw>mxmsgl) then write(bort_str,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH",1X,I6," BYTES) IS LARGER THAN '// & 'LIMIT OF ",I6," BYTES")') lnmsg*nbytw, mxmsgl call bort(bort_str) @@ -276,14 +276,14 @@ recursive subroutine readerme(mesg,lunit,subset,jdate,iret) ! Confirm that the first 4 bytes of SEC0 contain 'BUFR'. - if(sec0(1:4).ne.'BUFR') & + if(sec0(1:4)/='BUFR') & call bort('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD NOT "BUFR", DOES NOT CONTAIN BUFR DATA') ! Parse the message section contents - if(isc3(lun).ne.0) call reads3(lun) + if(isc3(lun)/=0) call reads3(lun) call cktaba(lun,subset,jdate,iret) - if(isc3(lun).ne.0) return + if(isc3(lun)/=0) return ! Check for a DX dictionary message @@ -293,29 +293,29 @@ recursive subroutine readerme(mesg,lunit,subset,jdate,iret) ! else is a non-DX dictionary message. endtbl = .false. - if(idxmsg(mbay(1,lun)).eq.1) then + if(idxmsg(mbay(1,lun))==1) then ! This is a DX dictionary message that was generated by the NCEPLIBS-bufr software. - if(iupbs3(mbay(1,lun),'NSUB').eq.0) then + if(iupbs3(mbay(1,lun),'NSUB')==0) then ! But it doesn't contain any actual dictionary information, so assume we've reached the end of the dictionary table. - if(idrdm(lun).gt.0) then + if(idrdm(lun)>0) then endtbl = .true. endif else - if(idrdm(lun).eq.0) then + if(idrdm(lun)==0) then ! This is the first DX dictionary message that is part of a new dictionary table. call dxinit(lun,0) endif idrdm(lun) = idrdm(lun) + 1 call stbfdx(lun,mbay(1,lun)) endif - else if(idrdm(lun).gt.0) then + else if(idrdm(lun)>0) then ! This is the first non-DX dictionary message received following a string of DX dictionary messages, so assume we've ! reached the end of the dictionary table. endtbl = .true. endif if(endtbl) then - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I3,A)' ) & 'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (', idrdm(lun), ') MESSAGES;' @@ -355,10 +355,10 @@ subroutine rdmsgw(lunit,mesg,iret) call status(lunit,lun,il,im) iret = -2 - do while (iret.le.-2) + do while (iret<=-2) iret = crdbufr_c(lun,mesg,mxmsgld4) - if(iret.eq.-3) call errwrt('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE') - if(iret.eq.-2) call errwrt('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE') + if(iret==-3) call errwrt('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE') + if(iret==-2) call errwrt('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE') end do return @@ -424,13 +424,13 @@ recursive subroutine openmb(lunit,subset,jdate) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(il==0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') ! Get some subset particulars call nemtba(lun,subset,mtyp,mstb,inod) - open = im.eq.0 .or. inod.ne.inode(lun) .or. i4dy(jdate).ne.idate(lun) + open = im==0 .or. inod/=inode(lun) .or. i4dy(jdate)/=idate(lun) ! Maybe(?) open a new or different type of message @@ -494,9 +494,9 @@ recursive subroutine openmg(lunit,subset,jdate) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.ne.0) call closmg(lunit) + if(il==0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im/=0) call closmg(lunit) call wtstat(lunit,lun,il, 1) ! Get some subset particulars @@ -558,15 +558,15 @@ recursive subroutine closmg(lunin) lunit = abs(lunin) call status(lunit,lun,il,im) - if(lunit.ne.lunin) msglim(lun) = 0 - if(il.eq.0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.ne.0) THEN - if(nsub(lun).gt.0) then + if(lunit/=lunin) msglim(lun) = 0 + if(il==0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im/=0) then + if(nsub(lun)>0) then call msgwrt(lunit,mbay(1,lun),mbyt(lun)) - else if(nsub(lun).eq.0.and.nmsg(lun).lt.msglim(lun)) then + else if(nsub(lun)==0.and.nmsg(lun)0) then do jj=1,ns01v - if(cmnem(jj).eq.'BEN') then - if(ivmnem(jj).eq.4) then + if(cmnem(jj)=='BEN') then + if(ivmnem(jj)==4) then ! Install Section 0 byte count for use by cnved4() ibit = 32 call pkb(mbyt,24,mgwa,ibit) @@ -665,7 +665,7 @@ subroutine msgwrt(lunit,mesg,mgbyt) ! Standardize the message if requested via module @ref moda_msgstd. However, we don't want to do this if the message ! contains DX BUFR table information, because in that case it's already standard. - if ( ( csmf.eq.'Y' ) .and. ( idxmsg(mgwa).ne.1 ) ) then + if ( ( csmf=='Y' ) .and. ( idxmsg(mgwa)/=1 ) ) then ! Install Section 0 byte count and Section 5 '7777' into the original message. This is necessary because ! subroutine stndrd() requires a complete and well-formed BUFR message as its input. ibit = 32 @@ -684,7 +684,7 @@ subroutine msgwrt(lunit,mesg,mgbyt) ! Append the tank receipt time to Section 1 if requested via module @ref moda_tnkrcp, unless the message contains ! DX BUFR table information. - if ( ( ctrt.eq.'Y' ) .and. ( idxmsg(mgwa).ne.1 ) ) then + if ( ( ctrt=='Y' ) .and. ( idxmsg(mgwa)/=1 ) ) then ! Install Section 0 byte count for use by subroutine atrcpt() ibit = 32 call pkb(mbyt,24,mgwa,ibit) @@ -704,11 +704,11 @@ subroutine msgwrt(lunit,mesg,mgbyt) ! Depending on the edition number of the message, we need to ensure that each section within the message has an even ! number of bytes. - if(iupbs01(mgwa,'BEN').lt.4) then - if(mod(len1,2).ne.0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') - if(mod(len2,2).ne.0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') - if(mod(len3,2).ne.0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') - if(mod(len4,2).ne.0) then + if(iupbs01(mgwa,'BEN')<4) then + if(mod(len1,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2') + if(mod(len2,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2') + if(mod(len3,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2') + if(mod(len4,2)/=0) then ! Pad Section 4 with an additional byte that is zeroed out iad4 = len0+len1+len2+len3 iad5 = iad4+len4 @@ -740,12 +740,12 @@ subroutine msgwrt(lunit,mesg,mgbyt) mwrd = nmwrd(mgwa) call status(lunit,lun,il,im) - if(null(lun).eq.0) then + if(null(lun)==0) then call blocks(mgwa,mwrd) call cwrbufr_c(lun,mgwa,mwrd) endif - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') write ( unit=errstr, fmt='(A,I4,A,I7)') 'BUFRLIB: MSGWRT: LUNIT =', lunit, ', BYTES =', mbyt+npbyt call errwrt(errstr) @@ -755,7 +755,7 @@ subroutine msgwrt(lunit,mesg,mgbyt) ! Save a memory copy of this message, unless it's a DX message. - if(idxmsg(mgwa).ne.1) then + if(idxmsg(mgwa)/=1) then ! Store a copy of this message within module @ref moda_bufrmg, for possible later retrieval during a future call to ! subroutine writsa() msglen(lun) = mwrd @@ -802,13 +802,13 @@ subroutine msgini(lun) subtag = tag(inode(lun))(1:8) call nemtba(lun,subtag,mtyp,msbt,inod) - if(inode(lun).ne.inod) then + if(inode(lun)/=inod) then write(bort_str,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",I7,") & POSITIONAL INDEX, INOD (",I7,") '// & 'OF SUBTAG (",A,") IN DICTIONARY")') inode(lun), inod, subtag call bort(bort_str) endif call nemtab(lun,subtag,isub,tab,iret) - if(iret.eq.0) then + if(iret==0) then write(bort_str,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subtag call bort(bort_str) endif @@ -822,10 +822,10 @@ subroutine msgini(lun) mour = mod(idate(lun) ,100) mmin = 0 - if(mcen.eq.1) call bort ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') + if(mcen==1) call bort ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000') - if(mear.eq.0) mcen = mcen-1 - if(mear.eq.0) mear = 100 + if(mear==0) mcen = mcen-1 + if(mear==0) mear = 100 ! Initialize the message @@ -888,8 +888,8 @@ subroutine msgini(lun) ! Double check initial message length - if(mod(mbit,8).ne.0) call bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END ON A BYTE BOUNDARY') - if(mbit/8.ne.nbyt) then + if(mod(mbit,8)/=0) call bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END ON A BYTE BOUNDARY') + if(mbit/8/=nbyt) then write(bort_str,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '// & 'CALCULATED, NBYT (",I6)') mbit/8, nbyt call bort(bort_str) @@ -938,14 +938,14 @@ logical function msgfull(msiz,itoadd,mxsiz) result(bool) ! But subroutine msgwrt() may also do any of all of the following: ! 6 bytes may be added by a call to subroutine atrcpt() - if(ctrt.eq.'Y') iwgbyt = iwgbyt + 6 + if(ctrt=='Y') iwgbyt = iwgbyt + 6 ! (maxnc*2) bytes (at most) may be added by a call to subroutine stndrd() - if(csmf.eq.'Y') iwgbyt = iwgbyt + (maxnc*2) + if(csmf=='Y') iwgbyt = iwgbyt + (maxnc*2) ! Determine whether the subset will fit. - if ( ( msiz + itoadd + iwgbyt ) .gt. mxsiz ) then + if ( ( msiz + itoadd + iwgbyt ) > mxsiz ) then bool = .true. else bool = .false. @@ -1000,14 +1000,14 @@ recursive subroutine maxout(maxo) return endif - if((maxo.eq.0).or.(maxo.gt.mxmsgl)) then + if((maxo==0).or.(maxo>mxmsgl)) then newsiz = mxmsgl else newsiz = maxo endif - if(iprt.ge.0) then - if(maxbyt.ne.newsiz) then + if(iprt>=0) then + if(maxbyt/=newsiz) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') write ( unit=errstr, fmt='(A,A,I7,A,I7)' ) 'BUFRLIB: MAXOUT - THE RECORD LENGTH OF ALL BUFR MESSAGES ',& 'CREATED FROM THIS POINT ON IS BEING CHANGED FROM ', maxbyt, ' TO ', newsiz @@ -1067,7 +1067,7 @@ subroutine padmsg(mesg,lmesg,npbyt) ! end of the message. nmw = nmwrd(mesg) - if(nmw.gt.lmesg) call bort('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + if(nmw>lmesg) call bort('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') ! Pad from the end of the message up to the next 8-byte boundary. @@ -1119,9 +1119,9 @@ recursive integer function nmsub(lunit) result(iret) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') iret = msub(lun) @@ -1151,7 +1151,7 @@ integer function nmwrd(mbay) result(iret) integer lenm, iupbs01 lenm = iupbs01(mbay,'LENM') - if(lenm.eq.0) then + if(lenm==0) then iret = 0 else iret = ((lenm/8)+1)*(8/nbytw) @@ -1241,25 +1241,25 @@ recursive subroutine getlens (mbay,ll,len0,len1,len2,len3,len4,len5) len4 = -1 len5 = -1 - if(ll.lt.0) return + if(ll<0) return len0 = iupbs01(mbay,'LEN0') - if(ll.lt.1) return + if(ll<1) return len1 = iupbs01(mbay,'LEN1') - if(ll.lt.2) return + if(ll<2) return iad2 = len0 + len1 len2 = iupb(mbay,iad2+1,24) * iupbs01(mbay,'ISC2') - if(ll.lt.3) return + if(ll<3) return iad3 = iad2 + len2 len3 = iupb(mbay,iad3+1,24) - if(ll.lt.4) return + if(ll<4) return iad4 = iad3 + len3 len4 = iupb(mbay,iad4+1,24) - if(ll.lt.5) return + if(ll<5) return len5 = 4 return @@ -1309,12 +1309,12 @@ recursive subroutine cnved4(msgin,lmsgot,msgot) return endif - if(iupbs01(msgin,'BEN').eq.4) then + if(iupbs01(msgin,'BEN')==4) then ! The input message is already encoded using edition 4, so just copy it from msgin to msgot and then return. nmw = nmwrd(msgin) - if(nmw.gt.lmsgot) & + if(nmw>lmsgot) & call bort('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') do i = 1, nmw msgot(i) = msgin(i) @@ -1335,7 +1335,7 @@ recursive subroutine cnved4(msgin,lmsgot,msgot) ! input message (i.e. 4 more bytes in Section 1, but 1 fewer byte in Section 3). lenmot = lenm + 3 - if(lenmot.gt.(lmsgot*nbytw)) & + if(lenmot>(lmsgot*nbytw)) & call bort('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') len1ot = len1 + 4 @@ -1424,13 +1424,13 @@ recursive integer function ifbget(lunit) result(iret) ! Make sure a file/message is open for input call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') ! Check if there's another subset in the message - if(nsub(lun).lt.msub(lun)) iret = 0 + if(nsub(lun)0) call bort('BUFRLIB: READSB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) return ! See if there is another subset in the message - if(nsub(lun).eq.msub(lun)) return + if(nsub(lun)==msub(lun)) return nsub(lun) = nsub(lun) + 1 ! Read the next subset and reset the pointers @@ -79,22 +79,22 @@ recursive subroutine readsb(lunit,iret) iscodes(lun) = 0 linbtm = .false. - if(msgunp(lun).eq.0) then + if(msgunp(lun)==0) then ibit = mbyt(lun)*8 call upb(nbyt,16,mbay(1,lun),ibit) call rdtree(lun,ier) - if(ier.ne.0) return + if(ier/=0) return mbyt(lun) = mbyt(lun) + nbyt - elseif(msgunp(lun).eq.1) then + elseif(msgunp(lun)==1) then ! message with "standard" Section 3 ibit = mbyt(lun) call rdtree(lun,ier) - if(ier.ne.0) return + if(ier/=0) return mbyt(lun) = ibit else ! compressed message call rdcmps(lun) - if (iscodes(lun) .ne. 0) return + if (iscodes(lun) /= 0) return endif iret = 0 @@ -196,9 +196,9 @@ recursive subroutine readns(lunit,subset,jdate,iret) ! Refresh the subset and jdate parameters call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: READNS - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: READNS - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(inode(lun).eq.0) then + if(il==0) call bort('BUFRLIB: READNS - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: READNS - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(inode(lun)==0) then subset = ' ' else subset = tag(inode(lun))(1:8) @@ -209,9 +209,9 @@ recursive subroutine readns(lunit,subset,jdate,iret) do while (.true.) call readsb(lunit,iret) - if (iret.eq.0) exit + if (iret==0) exit call readmg(lunit,subset,jdate,iret) - if (iret.ne.0) exit + if (iret/=0) exit enddo return @@ -325,14 +325,14 @@ recursive subroutine writsb(lunit) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: WRITSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: WRITSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: WRITSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') ! Pack up the subset and put it into the message call wrtree(lun) - if( ccmf.eq.'Y' ) then + if( ccmf=='Y' ) then call wrcmps(lunit) else call msgupd(lunit,lun) @@ -452,18 +452,18 @@ recursive subroutine writsa(lunxx,lmsgt,msgt,msgl) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') ! If lunxx < 0, force memory msg to be written (w/o any current subset) - if(lunxx.lt.0) call closmg(lunit) + if(lunxx<0) call closmg(lunit) ! Is there a completed BUFR message to be returned? - if(msglen(lun).gt.0) then - if(msglen(lun).gt.lmsgt) call bort('BUFRLIB: WRITSA - OVERFLOW OF OUTPUT BUFR MESSAGE ARRAY; TRY A LARGER '// & + if(msglen(lun)>0) then + if(msglen(lun)>lmsgt) call bort('BUFRLIB: WRITSA - OVERFLOW OF OUTPUT BUFR MESSAGE ARRAY; TRY A LARGER '// & 'DIMENSION FOR THIS ARRAY') msgl = msglen(lun) do n=1,msgl @@ -474,12 +474,12 @@ recursive subroutine writsa(lunxx,lmsgt,msgt,msgl) msgl = 0 endif - if(lunxx.lt.0) return + if(lunxx<0) return ! Pack up the subset and put it into the message call wrtree(lun) - if( ccmf.eq.'Y' ) then + if( ccmf=='Y' ) then call wrcmps(lunit) else call msgupd(lunit,lun) @@ -494,7 +494,7 @@ recursive subroutine writsa(lunxx,lmsgt,msgt,msgl) ! two BUFR messages available to be returned from this one call to writsa(). If sufficient space is available in the ! msgt array, then go ahead and return both messages now. - if( (msglen(lun).gt.0) .and. (msgl+msglen(lun).le.lmsgt) ) then + if( (msglen(lun)>0) .and. (msgl+msglen(lun)<=lmsgt) ) then do n = 1,msglen(lun) msgt(msgl+n) = msgtxt(n,lun) enddo @@ -571,7 +571,7 @@ recursive subroutine rdmgsb(lunit,imsg,isub) do i=1,imsg call readmg(lunit,subset,jdate,iret) - if(iret.lt.0) then + if(iret<0) then write(bort_str,'("BUFRLIB: RDMGSB - HIT END OF FILE BEFORE READING REQUESTED MESSAGE NO.",I5," IN '//& 'BUFR FILE CONNECTED TO UNIT",I4)') imsg,lunit call bort(bort_str) @@ -582,7 +582,7 @@ recursive subroutine rdmgsb(lunit,imsg,isub) do i=1,isub call readsb(lunit,iret) - if(iret.lt.0) then + if(iret<0) then write(bort_str,'("BUFRLIB: RDMGSB - ALL SUBSETS READ BEFORE READING REQ. SUBSET NO.",I3," IN '// & 'REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub,imsg,lunit call bort(bort_str) @@ -633,7 +633,7 @@ subroutine msgupd(lunit,lun) ! Check whether the new subset should be written into the currently open message - if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt.gt.65530).and.(nsub(lun).gt.0))) then + if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt>65530).and.(nsub(lun)>0))) then ! No it should not, either because it doesn't fit ! OR ! It has byte count > 65530 (sufficiently close to the upper limit for the 16 bit byte counter placed at the beginning @@ -647,7 +647,7 @@ subroutine msgupd(lunit,lun) if(msgfull(mbyt(lun),ibyt,maxbyt)) then ! This is an overlarge subset that won't fit in any message given the current value of maxbyt, so discard the subset ! and exit gracefully. - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I7,A)') 'BUFRLIB: MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE ', & '{MAXIMUM MESSAGE LENGTH = ', maxbyt, '}' @@ -686,7 +686,7 @@ subroutine msgupd(lunit,lun) ! If any long character strings are being held internally for storage into this subset, store them now - if(nh4wlc.gt.0) then + if(nh4wlc>0) then do ii = 1, nh4wlc call writlc(luh4wlc(ii),chh4wlc(ii),sth4wlc(ii)) enddo @@ -697,8 +697,8 @@ subroutine msgupd(lunit,lun) ! message because their beginning would be beyond the upper limit of 65535 in the 16-bit byte counter, meaning they ! could not be located!) - if(ibyt.gt.65530) then - if(iprt.ge.1) then + if(ibyt>65530) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,I7,A,A)') 'BUFRLIB: MSGUPD - SUBSET HAS BYTE COUNT = ',ibyt,' > UPPER LIMIT OF 65535' call errwrt(errstr) @@ -766,7 +766,7 @@ subroutine pad(ibay,ibit,ibyt,ipadb) call pkb(0,ipad,ibay,ibit) ibyt = ibit/8 - if(mod(ibit,8).ne.0) then + if(mod(ibit,8)/=0) then write(bort_str,'("BUFRLIB: PAD - THE NUMBER OF BITS IN A PACKED'// & ' SUBSET AFTER PADDING (",I8,") IS NOT A MULTIPLE OF 8")') ibit call bort(bort_str) @@ -830,7 +830,7 @@ recursive integer function lcmgdf(lunit,subset) result(iret) ! Get lun from lunit. call status(lunit,lun,il,im) - if (il.eq.0) call bort('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN') + if (il==0) call bort('BUFRLIB: LCMGDF - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN') ! Confirm that subset is defined for this logical unit. @@ -841,7 +841,7 @@ recursive integer function lcmgdf(lunit,subset) result(iret) nte = isc(inod)-inod do i = 1, nte - if ( (typ(inod+i).eq.'CHR') .and. (ibt(inod+i).gt.64) ) then + if ( (typ(inod+i)=='CHR') .and. (ibt(inod+i)>64) ) then iret = 1 return endif @@ -910,14 +910,14 @@ recursive subroutine ufbpos(lunit,irec,isub,subset,jdate) ! Make sure a file is open for input call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(il==0) call bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBPOS - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(irec.le.0) then + if(irec<=0) then write(bort_str,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER TO READ IN (",I5,") IS NOT VALID")') irec call bort(bort_str) endif - if(isub.le.0) then + if(isub<=0) then write(bort_str,'("BUFRLIB: UFBPOS - REQUESTED SUBSET NUMBER TO READ IN (",I5,") IS NOT VALID")') isub call bort(bort_str) endif @@ -928,7 +928,7 @@ recursive subroutine ufbpos(lunit,irec,isub,subset,jdate) ! Rewind file if requested pointers are behind current pointers - if(irec.lt.jrec .or. (irec.eq.jrec.and.isub.lt.jsub)) then + if(irecjrec) call readmg(lunit,subset,jdate,iret) - if(iret.lt.0) then + if(iret<0) then write(bort_str,'("BUFRLIB: UFBPOS - REQUESTED MESSAGE NUMBER '// & 'TO READ IN (",I5,") EXCEEDS THE NUMBER OF MESSAGES IN THE FILE (",I5,")")') irec, jrec call bort(bort_str) @@ -947,9 +947,9 @@ recursive subroutine ufbpos(lunit,irec,isub,subset,jdate) call ufbcnt(lunit,jrec,jsub) enddo - do while (isub.gt.jsub) + do while (isub>jsub) call readsb(lunit,iret) - if(iret.ne.0) then + if(iret/=0) then write(bort_str,'("BUFRLIB: UFBPOS - REQ. SUBSET NUMBER TO READ'// & ' IN (",I5,") EXCEEDS THE NUMBER OF SUBSETS (",I5,") IN THE REQ. MESSAGE (",I5,")")') isub, jsub, irec call bort(bort_str) @@ -1000,7 +1000,7 @@ subroutine rdtree(lun,iret) mbit(1) = ibit nbit(1) = 0 call rcstpl(lun,ier) - if(ier.ne.0) then + if(ier/=0) then iret = -1 return endif @@ -1015,21 +1015,21 @@ subroutine rdtree(lun,iret) do n=1,nval(lun) node = inv(n,lun) - if(itp(node).eq.1) then + if(itp(node)==1) then ! The unpacked value is a delayed descriptor replication factor. val(n,lun) = ival(n) - elseif(itp(node).eq.2) then + elseif(itp(node)==2) then ! The unpacked value is a real. - if (ival(n).lt.2_8**ibt(node)-1) then + if (ival(n)<2_8**ibt(node)-1) then val(n,lun) = ups(ival(n),node) else val(n,lun) = bmiss endif - elseif(itp(node).eq.3) then + elseif(itp(node)==3) then ! The value is a character string, so unpack it using an equivalenced real*8 value. Note that a maximum of 8 characters ! will be unpacked here, so a separate subsequent call to subroutine readlc() will be needed to fully unpack any string @@ -1039,7 +1039,7 @@ subroutine rdtree(lun,iret) kbit = mbit(n) nbt = min(8,nbit(n)/8) call upc(cval,nbt,mbay(1,lun),kbit,.true.) - if (nbit(n).le.64 .and. icbfms(cval,nbt).ne.0) then + if (nbit(n)<=64 .and. icbfms(cval,nbt)/=0) then val(n,lun) = bmiss else val(n,lun) = rval @@ -1085,10 +1085,10 @@ subroutine wrtree(lun) do n=1,nval(lun) node = inv(n,lun) - if(itp(node).eq.1) then + if(itp(node)==1) then ival(n) = nint(val(n,lun)) - elseif(typ(node).eq.'NUM') then - if( (ibfms(val(n,lun)).eq.1) .or. (val(n,lun).ne.val(n,lun)) ) then + elseif(typ(node)=='NUM') then + if( (ibfms(val(n,lun))==1) .or. (val(n,lun)/=val(n,lun)) ) then ! The user number is either "missing" or NaN. ival(n) = -1 else @@ -1103,20 +1103,20 @@ subroutine wrtree(lun) do n=1,nval(lun) node = inv(n,lun) - if(itp(node).lt.3) then + if(itp(node)<3) then ! The value to be packed is numeric. call pkb8(ival(n),ibt(node),ibay,ibit) else ! The value to be packed is a character string. ncr=ibt(node)/8 - if ( ncr.gt.8 .and. luncpy(lun).ne.0 ) then + if ( ncr>8 .and. luncpy(lun)/=0 ) then ! The string is longer than 8 characters and there was a preceeding call to ufbcpy() involving this output unit, ! so read the long string with readlc() and then write it into the output buffer using pkc(). call readlc(luncpy(lun),lstr,tag(node)) call pkc(lstr,ncr,ibay,ibit) else rval = val(n,lun) - if(ibfms(rval).ne.0) then + if(ibfms(rval)/=0) then ! The value is "missing", so set all bits to 1 before packing the field as a character string. numchr = min(ncr,len(lstr)) do jj = 1, numchr @@ -1197,7 +1197,7 @@ subroutine rcstpl(lun,iret) ! Set up the parameters for a level of recursion nr = nr+1 - if(nr.gt.maxrcr) then + if(nr>maxrcr) then write(bort_str,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION LEVELS EXCEEDS THE LIMIT (",I3,")")') maxrcr call bort(bort_str) endif @@ -1206,12 +1206,12 @@ subroutine rcstpl(lun,iret) n1 = iseq(node,1) n2 = iseq(node,2) - if(n1.eq.0) then + if(n1==0) then write(bort_str,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)') tag(nodi) call bort(bort_str) endif - if(n2-n1+1.gt.maxjl) THEN - if(iprt.ge.0) then + if(n2-n1+1>maxjl) then + if(iprt>=0) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt('BUFRLIB: RCSTPL - MAXJL OVERFLOW; SUBSET SKIPPED') call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') @@ -1233,11 +1233,11 @@ subroutine rcstpl(lun,iret) ! Store nodes at some recursion level do i=nbmp(1,nr),nbmp(2,nr) - if(knx(nr).eq.0) knx(nr) = knvn - if(i.gt.nbmp(1,nr)) newn(1,nr) = 1 + if(knx(nr)==0) knx(nr) = knvn + if(i>nbmp(1,nr)) newn(1,nr) = 1 do j=newn(1,nr),newn(2,nr) - if(knvn+1.gt.maxss) then - if(iprt.ge.0) then + if(knvn+1>maxss) then + if(iprt>=0) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt('BUFRLIB: RCSTPL - MAXSS OVERFLOW; SUBSET SKIPPED') call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') @@ -1254,10 +1254,10 @@ subroutine rcstpl(lun,iret) ! nbit is the number of bits in mbay occupied by packed subset element knvn nrfelm(knvn,lun) = igetrfel(knvn,lun) nbit(knvn) = ibt(node) - if(tag(node)(1:5).eq.'DPRI ') then + if(tag(node)(1:5)=='DPRI ') then ! This is a bitmap entry, so get and store the corresponding value call upbb(idpri,nbit(knvn),mbit(knvn),mbay(1,lun)) - if(idpri.eq.0) then + if(idpri==0) then val(knvn,lun) = 0.0 else val(knvn,lun) = bmiss @@ -1266,7 +1266,7 @@ subroutine rcstpl(lun,iret) endif ! Actual unpacked subset values are initialized here val(knvn,lun) = vutmp(j,nr) - if(itp(node).eq.1) then + if(itp(node)==1) then call upbb(mbmp,nbit(knvn),mbit(knvn),mbay(1,lun)) newn(1,nr) = j+1 nbmp(1,nr) = i @@ -1280,7 +1280,7 @@ subroutine rcstpl(lun,iret) ! Check if we need to continue one recursion level back - if(nr-1 .eq. 0) exit outer + if(nr-1 == 0) exit outer nr = nr-1 enddo @@ -1324,7 +1324,7 @@ subroutine usrtpl(lun,invn,nbmp) common /quiet/ iprt - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') write ( unit=errstr, fmt='(A,I3,A,I7,A,I5,A,A10)' ) & 'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ', lun, ':', invn, ':', nbmp, ':', tag(inode(lun)) @@ -1333,8 +1333,8 @@ subroutine usrtpl(lun,invn,nbmp) call errwrt(' ') endif - if(nbmp.le.0) then - if(iprt.ge.1) then + if(nbmp<=0) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') call errwrt('BUFRLIB: USRTPL - NBMP .LE. 0 - IMMEDIATE RETURN') call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') @@ -1349,27 +1349,27 @@ subroutine usrtpl(lun,invn,nbmp) ! Set up a node expansion - if(invn.eq.1) then + if(invn==1) then ! The node is a Table A mnemonic nodi = inode(lun) inv(1,lun) = nodi nval(lun) = 1 - if(nbmp.ne.1) then + if(nbmp/=1) then write(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// & 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET NODE) (",A,")")') nbmp, tag(nodi) call bort(bort_str) endif - elseif(invn.gt.0 .and. invn.le.nval(lun)) then + elseif(invn>0 .and. invn<=nval(lun)) then ! The node is (hopefully) a delayed replication factor nodi = inv(invn,lun) - drp = typ(nodi) .eq. 'DRP' - drs = typ(nodi) .eq. 'DRS' - drb = typ(nodi) .eq. 'DRB' + drp = typ(nodi) == 'DRP' + drs = typ(nodi) == 'DRS' + drb = typ(nodi) == 'DRB' drx = drp .or. drs .or. drb ival = nint(val(invn,lun)) jval = 2**ibt(nodi)-1 val(invn,lun) = ival+nbmp - if(drb.and.nbmp.ne.1) then + if(drb.and.nbmp/=1) then write(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'// & 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR) (",A,")")') nbmp, tag(nodi) call bort(bort_str) @@ -1379,11 +1379,11 @@ subroutine usrtpl(lun,invn,nbmp) 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")') typ(nodi), tag(nodi) call bort(bort_str) endif - if(ival.lt.0) then + if(ival<0) then write(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS NEGATIVE (=",I5,") (",A,")")') ival, tag(nodi) call bort(bort_str) endif - if(ival+nbmp.gt.jval) then + if(ival+nbmp>jval) then write(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW (EXCEEDS MAXIMUM OF",I6," (",A,")")') jval, tag(nodi) call errwrt(bort_str) iscodes(lun) = 1 @@ -1401,11 +1401,11 @@ subroutine usrtpl(lun,invn,nbmp) n1 = iseq(nodi,1) n2 = iseq(nodi,2) - if(n1.eq.0) then + if(n1==0) then write(bort_str,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",A,")")') tag(nodi) call bort(bort_str) endif - if(n2-n1+1.gt.maxjl) then + if(n2-n1+1>maxjl) then write(bort_str,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, EXCEEDS THE LIMIT (",I6,") (",A,")")') maxjl, tag(nodi) call bort(bort_str) endif @@ -1418,7 +1418,7 @@ subroutine usrtpl(lun,invn,nbmp) ! Move old nodes and store new ones - if(nval(lun)+newn*nbmp.gt.maxss) then + if(nval(lun)+newn*nbmp>maxss) then write(bort_str,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,"), EXCEEDS THE LIMIT (",I6,") (",A,")")') & nval(lun)+newn*nbmp, maxss, tag(nodi) call bort(bort_str) @@ -1444,7 +1444,7 @@ subroutine usrtpl(lun,invn,nbmp) nval(lun) = nval(lun) + newn*nbmp - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') write ( unit=errstr, fmt='(A,A,A10,2(A,I5),A,I7)' ) 'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:', & 'NVAL(LUN) = ', tag(inv(invn,lun)), ':', newn, ':', nbmp, ':', nval(lun) @@ -1462,10 +1462,10 @@ subroutine usrtpl(lun,invn,nbmp) invr = invn outer: do while (.true.) node = jmpb(node) - if(node.le.0) exit - if(itp(node).eq.0) then + if(node<=0) exit + if(itp(node)==0) then do invr=invr-1,1,-1 - if(inv(invr,lun).eq.node) then + if(inv(invr,lun)==node) then val(invr,lun) = val(invr,lun)+newn*nbmp cycle outer endif @@ -1534,27 +1534,27 @@ recursive subroutine invmrg(lubfi,lubfj) ! Step through the buffers comparing the inventory and merging data - do while(is.le.nval(luni)) + do while(is<=nval(luni)) ! Confirm we're at the same node in each buffer node = inv(is,luni) nodj = inv(js,lunj) - if(node.ne.nodj) then + if(node/=nodj) then write(bort_str,'("BUFRLIB: INVMRG - NODE FROM INPUT BUFR FILE '// & '(",I7,") DOES NOT EQUAL NODE FROM OUTPUT BUFR FILE (",I7,"), TABULAR MISMATCH")') node, nodj call bort(bort_str) endif ityp = itp(node) - if(ityp.eq.1) then + if(ityp==1) then ! Do an entire sequence replacement - if(typ(node).eq.'DRB') then + if(typ(node)=='DRB') then ioff = 0 else ioff = 1 endif iwrds = nwords(is,luni)+ioff jwrds = nwords(js,lunj)+ioff - if(iwrds.gt.ioff .and. jwrds.eq.ioff) then + if(iwrds>ioff .and. jwrds==ioff) then do n=nval(lunj),js+1,-1 inv(n+iwrds-jwrds,lunj) = inv(n,lunj) val(n+iwrds-jwrds,lunj) = val(n,lunj) @@ -1569,13 +1569,13 @@ recursive subroutine invmrg(lubfi,lubfj) endif is = is+iwrds js = js+jwrds - elseif((ityp.eq.2).or.(ityp.eq.3)) then + elseif((ityp==2).or.(ityp==3)) then ! Fill missing values - herei = ibfms(val(is,luni)).eq.0 - herej = ibfms(val(js,lunj)).eq.0 + herei = ibfms(val(is,luni))==0 + herej = ibfms(val(js,lunj))==0 missi = .not.(herei) missj = .not.(herej) - samei = val(is,luni).eq.val(js,lunj) + samei = val(is,luni)==val(js,lunj) if(herei.and.missj) then val(js,lunj) = val(is,luni) nmrg = nmrg+1 diff --git a/src/readwriteval.F90 b/src/readwriteval.F90 index 6b49c2cd..13c476c5 100644 --- a/src/readwriteval.F90 +++ b/src/readwriteval.F90 @@ -68,16 +68,16 @@ recursive subroutine setvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb, r8val, iret ! Get lun from lunit. call status (lunit, lun, il, im ) - if ( il .le. 0 ) return - if ( inode(lun) .ne. inv(1,lun) ) return + if ( il <= 0 ) return + if ( inode(lun) /= inv(1,lun) ) return ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv. call fstag( lun, tagpv, ntagpv, 1, npv, ierft ) - if ( ierft .ne. 0 ) return + if ( ierft /= 0 ) return ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb. call fstag( lun, tagnb, ntagnb, npv, nnb, ierft ) - if ( ierft .ne. 0 ) return + if ( ierft /= 0 ) return iret = 0 val(nnb,lun) = r8val @@ -148,16 +148,16 @@ recursive real*8 function getvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb ) resul ! Get lun from lunit. call status (lunit, lun, il, im ) - if ( il .ge. 0 ) return - if ( inode(lun) .ne. inv(1,lun) ) return + if ( il >= 0 ) return + if ( inode(lun) /= inv(1,lun) ) return ! Starting from the beginning of the subset, locate the (ntagpv)th occurrence of tagpv. call fstag( lun, tagpv, ntagpv, 1, npv, ierft ) - if ( ierft .ne. 0 ) return + if ( ierft /= 0 ) return ! Now, starting from the (ntagpv)th occurrence of tagpv, search forward or backward for the (ntagnb)th occurrence of tagnb. call fstag( lun, tagnb, ntagnb, npv, nnb, ierft ) - if ( ierft .ne. 0 ) return + if ( ierft /= 0 ) return r8val = val(nnb,lun) @@ -234,13 +234,13 @@ recursive subroutine writlc(lunit,chr,str) ! Check the file status. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') ! Check for tags (mnemonics) in input string (there can only be one) call parstr(str,tgs,maxtg,ntg,' ',.true.) - if(ntg.gt.1) then + if(ntg>1) then write(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '// & ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4,")")') str,ntg call bort(bort_str) @@ -248,12 +248,12 @@ recursive subroutine writlc(lunit,chr,str) ! Check if a specific occurrence of the input string was requested; if not, then the default is to write the first occurrence call parutg(lun,1,tgs(1),nnod,kon,roid) - if(kon.eq.6) then + if(kon==6) then ioid=nint(roid) - if(ioid.le.0) ioid = 1 + if(ioid<=0) ioid = 1 ctag = ' ' ii = 1 - do while((ii.le.10).and.(tgs(1)(ii:ii).ne.'#')) + do while((ii<=10).and.(tgs(1)(ii:ii)/='#')) ctag(ii:ii)=tgs(1)(ii:ii) ii = ii + 1 enddo @@ -262,21 +262,21 @@ 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')>0) then ! The message is compressed n = 1 itagct = 0 call usrtpl(lun,n,n) - do while (n+1.le.nval(lun)) + do while (n+1<=nval(lun)) n = n+1 node = inv(n,lun) - if(itp(node).eq.1) then + if(itp(node)==1) then nbmp=int(matx(n,ncol)) call usrtpl(lun,n,nbmp) - elseif(ctag.eq.tag(node)) then + elseif(ctag==tag(node)) then itagct = itagct + 1 - if(itagct.eq.ioid) then - if(itp(node).ne.3) then + if(itagct==ioid) then + if(itp(node)/=3) then write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') & ctag,typ(node) call bort(bort_str) @@ -297,14 +297,14 @@ recursive subroutine writlc(lunit,chr,str) mbyte = len0 + len1 + len2 + len3 + 4 nsubs = 1 ! Find the most recently written subset in the message. - do while(nsubs.lt.nsub(lun)) + do while(nsubs=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // & ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING' @@ -320,18 +320,18 @@ recursive subroutine writlc(lunit,chr,str) nbit = 0 n = 1 call usrtpl(lun,n,n) - do while (n+1.le.nval(lun)) + do while (n+1<=nval(lun)) n = n+1 node = inv(n,lun) mbit = mbit+nbit nbit = ibt(node) - if(itp(node).eq.1) then + if(itp(node)==1) then call upbb(ival,nbit,mbit,mbay(1,lun)) call usrtpl(lun,n,ival) - elseif(ctag.eq.tag(node)) then + elseif(ctag==tag(node)) then itagct = itagct + 1 - if(itagct.eq.ioid) then - if(itp(node).ne.3) then + if(itagct==ioid) then + if(itp(node)/=3) then write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') & ctag,typ(node) call bort(bort_str) @@ -350,7 +350,7 @@ recursive subroutine writlc(lunit,chr,str) endif ! If we made it here, then we couldn't find the requested string. - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE ' // & 'SUBSET DEFINITION' @@ -446,13 +446,13 @@ recursive subroutine readlc(lunit,chr,str) ! Check the file status call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') ! Check for tags (mnemonics) in input string (there can only be one) call parstr(str,tgs,maxtg,ntg,' ',.true.) - if(ntg.gt.1) then + if(ntg>1) then write(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '// & 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntg call bort(bort_str) @@ -461,12 +461,12 @@ recursive subroutine readlc(lunit,chr,str) ! Check if a specific occurrence of the input string was requested; if not, then the default is to return the ! first occurrence. call parutg(lun,0,tgs(1),nnod,kon,roid) - if(kon.eq.6) then + if(kon==6) then ioid=nint(roid) - if(ioid.le.0) ioid = 1 + if(ioid<=0) ioid = 1 ctag = ' ' ii = 1 - do while((ii.le.10).and.(tgs(1)(ii:ii).ne.'#')) + do while((ii<=10).and.(tgs(1)(ii:ii)/='#')) ctag(ii:ii)=tgs(1)(ii:ii) ii = ii + 1 enddo @@ -476,21 +476,21 @@ recursive subroutine readlc(lunit,chr,str) endif ! Locate and decode the long character string - if(msgunp(lun).eq.0.or.msgunp(lun).eq.1) then + if(msgunp(lun)==0.or.msgunp(lun)==1) then ! The message is not compressed itagct = 0 do n=1,nval(lun) nod = inv(n,lun) - if(ctag.eq.tag(nod)) then + if(ctag==tag(nod)) then itagct = itagct + 1 - if(itagct.eq.ioid) then - if(itp(nod).ne.3) then + if(itagct==ioid) then + if(itp(nod)/=3) then write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '// & 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod) call bort(bort_str) endif nchr = nbit(n)/8 - if(nchr.gt.lchr) Then + if(nchr>lchr) then write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// & 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr call bort(bort_str) @@ -503,14 +503,14 @@ recursive subroutine readlc(lunit,chr,str) enddo else ! The message is compressed - if(nrst.gt.0) then + if(nrst>0) then itagct = 0 do ii=1,nrst - if(ctag.eq.crtag(ii)) then + if(ctag==crtag(ii)) then itagct = itagct + 1 - if(itagct.eq.ioid) then + if(itagct==ioid) then nchr = irnch(ii) - if(nchr.gt.lchr) then + if(nchr>lchr) then write(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '// & 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr call bort(bort_str) @@ -525,7 +525,7 @@ recursive subroutine readlc(lunit,chr,str) endif ! If we made it here, then we couldn't find the requested string. - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // & ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT' @@ -684,16 +684,16 @@ recursive subroutine ufbint(lunin,usr,i1,i2,iret,str) ! Check the file status and inode lunit = abs(lunin) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN') - if(im.eq.0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & + if(il==0) call bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(im==0) call bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') io = min(max(0,il),1) - if(lunit.ne.lunin) io = 0 + if(lunit/=lunin) io = 0 - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -702,14 +702,14 @@ recursive subroutine ufbint(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.eq.-1) ifirst1 = 1 - if(io.eq.0 .or. ifirst1.eq.0 .or. iprt.ge.1) then + elseif(i2<=0) then + if(iprt==-1) ifirst1 = 1 + if(io==0 .or. ifirst1==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) - if(iprt.eq.0 .and. io.eq.1) then + if(iprt==0 .and. io==1) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -728,7 +728,7 @@ recursive subroutine ufbint(lunin,usr,i1,i2,iret,str) call string(str,lun,i1,io) ! Initialize usr array preceeding an input operation - if(io.eq.0) then + if(io==0) then do j=1,i2 do i=1,I1 usr(i,j) = bmiss @@ -740,21 +740,21 @@ recursive subroutine ufbint(lunin,usr,i1,i2,iret,str) call ufbrw(lun,usr,i1,i2,io,iret) ! If incomplete write try to initialize replication sequence or return - if(io.eq.1 .and. iret.ne.i2 .and. iret.ge.0) then + if(io==1 .and. iret/=i2 .and. iret>=0) then call trybump(lun,usr,i1,i2,io,iret) - if(iret.ne.i2) then + if(iret/=i2) then write(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS: ",A)') str write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// & 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2 call bort2(bort_str1,bort_str2) endif - elseif(iret.eq.-1) then + elseif(iret==-1) then iret = 0 endif - if(iret.eq.0) then - if(io.eq.0) then - if(iprt.ge.1) then + if(iret==0) then + if(io==0) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -763,14 +763,14 @@ recursive subroutine ufbint(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif else - if(iprt.eq.-1) ifirst2 = 1 - if(ifirst2.eq.0 .or. iprt.ge.1) then + if(iprt==-1) ifirst2 = 1 + if(ifirst2==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) call errwrt('MAY NOT BE IN THE BUFR TABLE(?)') - if(iprt.eq.0) then + if(iprt==0) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -923,16 +923,16 @@ recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str) ! Check the file status and inode lunit = abs(lunin) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN') - if(im.eq.0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & + if(il==0) call bort('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(im==0) call bort('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') io = min(max(0,il),1) - if(lunit.ne.lunin) io = 0 + if(lunit/=lunin) io = 0 - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -941,14 +941,14 @@ recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.eq.-1) ifirst1 = 1 - if(io.eq.0 .or. ifirst1.eq.0 .or. iprt.ge.1) then + elseif(i2<=0) then + if(iprt==-1) ifirst1 = 1 + if(io==0 .or. ifirst1==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) - if(iprt.eq.0 .and. io.eq.1) then + if(iprt==0 .and. io==1) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -964,7 +964,7 @@ recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str) endif ! Initialize usr array preceeding an input operation - if(io.eq.0) then + if(io==0) then do j=1,i2 do i=1,i1 usr(i,j) = bmiss @@ -981,14 +981,14 @@ recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str) ! Call the mnemonic reader/writer call ufbrp(lun,usr,i1,i2,io,iret) - if(io.eq.1 .and. iret.lt.i2) then + if(io==1 .and. iret=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -1136,16 +1136,16 @@ recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str) ! Check the file status and inode lunit = abs(lunin) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE OPEN') - if(im.eq.0) call bort('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & + if(il==0) call bort('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(im==0) call bort('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR BUFR FILE DOES NOT AGREE ' // & 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') io = min(max(0,il),1) - if(lunit.ne.lunin) io = 0 + if(lunit/=lunin) io = 0 - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -1154,14 +1154,14 @@ recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.eq.-1) ifirst1 = 1 - if(io.eq.0 .or. ifirst1.eq.0 .or. iprt.ge.1) then + elseif(i2<=0) then + if(iprt==-1) ifirst1 = 1 + if(io==0 .or. ifirst1==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) - if(iprt.eq.0 .and. io.eq.1) then + if(iprt==0 .and. io==1) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -1177,7 +1177,7 @@ recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str) endif ! Initialize usr array preceeding an input operation - if(io.eq.0) then + if(io==0) then do j=1,i2 do i=1,I1 usr(i,j) = bmiss @@ -1191,14 +1191,14 @@ recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str) ! Call the mnemonic reader/writer call ufbsp(lun,usr,i1,i2,io,iret) - if(io.eq.1 .and. iret.ne.i2) then + if(io==1 .and. iret/=i2) then write(bort_str1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS: ",A)') str write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// & 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2 call bort2(bort_str1,bort_str2) endif - if(iret.eq.0 .and. io.eq.0 .and. iprt.ge.1) then + if(iret==0 .and. io==0 .and. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -1362,14 +1362,14 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) ! Check the file status and inode lunit = abs(lunin) call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN') - if(im.eq.0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(im==0) call bort('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR FILE, NONE ARE') io = min(max(0,il),1) - if(lunit.ne.lunin) io = 0 + if(lunit/=lunin) io = 0 - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -1378,14 +1378,14 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.eq.-1) ifirst1 = 1 - if(io.eq.0 .or. ifirst1.eq.0 .or. iprt.ge.1) then + elseif(i2<=0) then + if(iprt==-1) ifirst1 = 1 + if(io==0 .or. ifirst1==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) - if(iprt.eq.0 .and. io.eq.1) then + if(iprt==0 .and. io==1) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -1402,20 +1402,20 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) ! Check for valid sequence and sequence length arguments call parstr(str,tags,mtag,ntag,' ',.true.) - if(ntag.lt.1) then + if(ntag<1) then write(bort_str,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") DOES NOT CONTAIN ANY MNEMONICS!!")') str call bort(bort_str) endif - if(ntag.gt.1) then + if(ntag>1) then write(bort_str,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '// & 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3,")")') str,ntag call bort(bort_str) endif - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// & + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '// & 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') ! Initialize usr array preceeding an input operation - if(io.eq.0) then + if(io==0) then do j=1,i2 do i=1,I1 usr(i,j) = bmiss @@ -1425,28 +1425,28 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) ! Find the parameters of the specified sequence outer: do node=inode(lun),isc(inode(lun)) - if(str.eq.tag(node)) then - if(typ(node).eq.'SEQ' .or. typ(node).eq.'RPC') then + if(str==tag(node)) then + if(typ(node)=='SEQ' .or. typ(node)=='RPC') then ins1 = 1 do while (.true.) ins1 = invtag(node,lun,ins1,nval(lun)) - if(ins1.eq.0) exit outer - if(typ(node).ne.'RPC' .or. val(ins1,lun).ne.0.) exit + if(ins1==0) exit outer + if(typ(node)/='RPC' .or. val(ins1,lun)/=0.) exit ins1 = ins1+1 enddo ins2 = invtag(node,lun,ins1+1,nval(lun)) - if(ins2.eq.0) ins2 = 10E5 + if(ins2==0) ins2 = 10E5 nods = node - do while(link(nods).eq.0 .and. jmpb(nods).gt.0) + do while(link(nods)==0 .and. jmpb(nods)>0) nods = jmpb(nods) enddo - if(link(nods).eq.0) then + if(link(nods)==0) then insx = nval(lun) - elseif(link(nods).gt.0) then + elseif(link(nods)>0) then insx = invwin(link(nods),lun,ins1+1,nval(lun))-1 endif ins2 = min(ins2,insx) - elseif(typ(node).eq.'SUB') then + elseif(typ(node)=='SUB') then ins1 = 1 ins2 = nval(lun) else @@ -1457,9 +1457,9 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) nseq = 0 do isq=ins1,ins2 ityp = itp(inv(isq,lun)) - if(ityp.gt.1) nseq = nseq+1 + if(ityp>1) nseq = nseq+1 enddo - if(nseq.gt.i1) then + if(nseq>i1) then write(bort_str,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A," CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. '// & 'SPECIFIED IN (INPUT) ARGUMENT 3 (",I3,")")') tags(1),nseq,i1 call bort(bort_str) @@ -1467,13 +1467,13 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) ! Frame a section of the buffer - return when no frame inner: do while (.true.) ins1 = invtag(node,lun,ins1,nval(lun)) - if(ins1.gt.nval(lun)) exit outer - if(ins1.gt.0) then - if(typ(node).eq.'RPC' .and. val(ins1,lun).eq.0.) then + if(ins1>nval(lun)) exit outer + if(ins1>0) then + if(typ(node)=='RPC' .and. val(ins1,lun)==0.) then ins1 = ins1+1 cycle - elseif(io.eq.0 .and. iret+1.gt.i2) then - if(iprt.ge.0) then + elseif(io==0 .and. iret+1>i2) then + if(iprt>=0) then call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++') write ( unit=errstr, fmt='(A,I5,A,A,A)' ) 'BUFRLIB: UFBSEQ - INCOMPLETE READ; ONLY THE FIRST ', i2, & ' (=4TH INPUT ARG.) ''LEVELS'' OF INPUT MNEMONIC ', tags(1), ' WERE READ' @@ -1483,8 +1483,8 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) endif exit outer endif - elseif(ins1.eq.0) then - if(io.eq.1 .and. iret.lt.i2) then + elseif(ins1==0) then + if(io==1 .and. iret=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -1522,14 +1522,14 @@ recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str) call errwrt(' ') endif else - if(iprt.eq.-1) ifirst2 = 1 - if(ifirst2.eq.0 .or. iprt.ge.1) then + if(iprt==-1) ifirst2 = 1 + if(ifirst2==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) call errwrt('MAY NOT BE IN THE BUFR TABLE(?)') - if(iprt.eq.0) then + if(iprt==0) then errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // & 'all such messages,' call errwrt(errstr) @@ -1619,7 +1619,7 @@ recursive subroutine drfini(lunit,mdrf,ndrf,drftag) n = 0 do n = n+1, nval(lun) node = inv(n,lun) - if(itp(node).eq.1 .and. tag(node).eq.drftag) then + if(itp(node)==1 .and. tag(node)==drftag) then m = m+1 call usrtpl(lun,n,mdrf(m)) endif @@ -1681,21 +1681,21 @@ subroutine ufbrw(lun,usr,i1,i2,io,iret) inc2 = 1 outer: do while (.true.) call conwin(lun,inc1,inc2) - if(nnod.eq.0) then + if(nnod==0) then iret = i2 return - elseif(inc1.eq.0) then + elseif(inc1==0) then return else do j=1,nnod - if(nods(j).gt.0) then + if(nods(j)>0) then ins2 = inc1 call getwin(nods(j),lun,ins1,ins2) - if(ins1.eq.0) return + if(ins1==0) return do while (.true.) ! Loop over store nodes iret = iret+1 - if(iprt.ge.2) then + if(iprt>=2) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//SUBSET) call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') @@ -1703,32 +1703,32 @@ subroutine ufbrw(lun,usr,i1,i2,io,iret) if(io==0) tagstr=tag(nods(i))(1:8)//' R' if(io==1) tagstr=tag(nods(i))(1:8)//' W' invn = invwin(nods(i),lun,ins1,ins2) - if(invn.eq.0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn) + if(invn==0.and.io==1) call drstpl(nods(i),lun,ins1,ins2,invn) write(errstr,'("LEV=",I5,1X,A,3I7)') iret,tagstr,ins1,invn,ins2 call errwrt(errstr) enddo endif ! Write user values - if(io.eq.1 .and. iret.le.i2) then + if(io==1 .and. iret<=i2) then do i=1,nnod - if(nods(i).gt.0) then - if(ibfms(usr(i,iret)).eq.0) then + if(nods(i)>0) then + if(ibfms(usr(i,iret))==0) then invn = invwin(nods(i),lun,ins1,ins2) - if(invn.eq.0) then + if(invn==0) then call drstpl(nods(i),lun,ins1,ins2,invn) - if(invn.eq.0) then + if(invn==0) then iret = 0 return endif call newwin(lun,inc1,inc2) val(invn,lun) = usr(i,iret) - elseif(lstjpb(nods(i),lun,'RPS').eq.0) then + elseif(lstjpb(nods(i),lun,'RPS')==0) then val(invn,lun) = usr(i,iret) - elseif(ibfms(val(invn,lun)).ne.0) then + elseif(ibfms(val(invn,lun))/=0) then val(invn,lun) = usr(i,iret) else call drstpl(nods(i),lun,ins1,ins2,invn) - if(invn.eq.0) then + if(invn==0) then iret = 0 return endif @@ -1740,20 +1740,20 @@ subroutine ufbrw(lun,usr,i1,i2,io,iret) enddo endif ! Read user values - if(io.eq.0 .and. iret.le.i2) then + if(io==0 .and. iret<=i2) then do i=1,nnod usr(i,iret) = bmiss - if(nods(i).gt.0) then + if(nods(i)>0) then invn = invwin(nods(i),lun,ins1,ins2) - if(invn.gt.0) usr(i,iret) = val(invn,lun) + if(invn>0) usr(i,iret) = val(invn,lun) endif enddo endif ! Decide what to do next - if(io.eq.1.and.iret.eq.i2) return + if(io==1.and.iret==i2) return call nxtwin(lun,ins1,ins2) - if(ins1.gt.0 .and. ins1.lt.inc2) cycle - if(ncon.gt.0) cycle outer + if(ins1>0 .and. ins10) cycle outer return enddo endif @@ -1809,31 +1809,31 @@ subroutine ufbrp(lun,usr,i1,i2,io,iret) ! Find first non-zero node in string do nz=1,nnod - if(nods(nz).gt.0) then + if(nods(nz)>0) then do while (.true.) ! Frame a section of the buffer - return when no frame - if(ins1+1.gt.nval(lun)) return - if(io.eq.1 .and. iret.eq.i2) return + if(ins1+1>nval(lun)) return + if(io==1 .and. iret==i2) return ins1 = invtag(nods(nz),lun,ins1+1,nval(lun)) - if(ins1.eq.0) return + if(ins1==0) return ins2 = invtag(nods(nz),lun,ins1+1,nval(lun)) - if(ins2.eq.0) ins2 = nval(lun) + if(ins2==0) ins2 = nval(lun) iret = iret+1 ! Read user values - if(io.eq.0 .and. iret.le.i2) then + if(io==0 .and. iret<=i2) then do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then invn = invtag(nods(i),lun,ins1,ins2) - if(invn.gt.0) usr(i,iret) = val(invn,lun) + if(invn>0) usr(i,iret) = val(invn,lun) endif enddo endif ! Write user values - if(io.eq.1 .and. iret.le.i2) then + if(io==1 .and. iret<=i2) then do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then invn = invtag(nods(i),lun,ins1,ins2) - if(invn.gt.0) val(invn,lun) = usr(i,iret) + if(invn>0) val(invn,lun) = usr(i,iret) endif enddo endif @@ -1893,30 +1893,30 @@ subroutine ufbsp(lun,usr,i1,i2,io,iret) do while (.true.) ! Frame a section of the buffer - return when no frame - if(ins1+1.gt.nval(lun)) return + if(ins1+1>nval(lun)) return ins1 = invtag(nods(1),lun,ins1+1,nval(lun)) - if(ins1.eq.0) return + if(ins1==0) return ins2 = invtag(nods(1),lun,ins1+1,nval(lun)) - if(ins2.eq.0) ins2 = nval(lun) + if(ins2==0) ins2 = nval(lun) iret = iret+1 ! Read user values - if(io.eq.0 .and. iret.le.i2) then + if(io==0 .and. iret<=i2) then invm = ins1 do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then invn = invtag(nods(i),lun,invm,ins2) - if(invn.gt.0) usr(i,iret) = val(invn,lun) + if(invn>0) usr(i,iret) = val(invn,lun) invm = max(invn,invm) endif enddo endif ! Write user values - if(io.eq.1 .and. iret.le.i2) then + if(io==1 .and. iret<=i2) then invm = ins1 do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then invn = invtag(nods(i),lun,invm,ins2) - if(invn.gt.0) val(invn,lun) = usr(i,iret) + if(invn>0) val(invn,lun) = usr(i,iret) invm = max(invn,invm) endif enddo @@ -2002,15 +2002,15 @@ recursive subroutine hold4wlc(lunit,chr,str) endif call strsuc( str, mystr, lens ) - if ( lens .eq. -1 ) return + if ( lens == -1 ) return lenc = min( len( chr ), 120 ) ! If this subroutine has already been called with this mnemonic for this particular subset, then overwrite the ! corresponding entry in the internal holding area - if ( nh4wlc .gt. 0 ) then + if ( nh4wlc > 0 ) then do i = 1, nh4wlc - if ( ( lunit .eq. luh4wlc(i) ) .and. ( mystr(1:lens) .eq. sth4wlc(i)(1:lens) ) ) then + if ( ( lunit == luh4wlc(i) ) .and. ( mystr(1:lens) == sth4wlc(i)(1:lens) ) ) then chh4wlc(i) = '' chh4wlc(i)(1:lenc) = chr(1:lenc) return @@ -2019,8 +2019,8 @@ recursive subroutine hold4wlc(lunit,chr,str) endif ! Otherwise, use the next available unused entry in the holding area - if ( nh4wlc .ge. mxh4wlc ) then - if(iprt.ge.0) then + if ( nh4wlc >= mxh4wlc ) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') write ( unit=errstr, fmt='(A,A,I3)' ) 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ', & 'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc @@ -2082,14 +2082,14 @@ subroutine trybump(lun,usr,i1,i2,io,iret) ! See if there's a delayed replication group involved ndrp = lstjpb(nods(1),lun,'DRP') - if(ndrp.le.0) return + if(ndrp<=0) return ! If so, clean it out and bump it to i2 invn = invwin(ndrp,lun,1,nval(lun)) val(invn,lun) = 0 jnvn = invn+1 - do while(nint(val(jnvn,lun)).gt.0) + do while(nint(val(jnvn,lun))>0) jnvn = jnvn+nint(val(jnvn,lun)) enddo do knvn=1,nval(lun)-jnvn+1 @@ -2167,16 +2167,16 @@ recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str) ! Check the file status and inode call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: UFBOVR - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: UFBOVR - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBOVR - LOCATION OF INTERNAL TABLE FOR '// & 'OUTPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') io = min(max(0,il),1) - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBOVR - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) @@ -2185,14 +2185,14 @@ recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.eq.-1) ifirst1 = 1 - if(io.eq.0 .or. ifirst1.eq.0 .or. iprt.ge.1) then + elseif(i2<=0) then + if(iprt==-1) ifirst1 = 1 + if(io==0 .or. ifirst1==0 .or. iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBOVR - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) =' call errwrt(errstr) call errwrt(str) - if(iprt.eq.0 .and. io.eq.1) then + if(iprt==0 .and. io==1) then errstr = 'Note: Only the first occurrence of this WARNING ' // & 'message is printed, there may be more. To output all such messages,' call errwrt(errstr) @@ -2212,7 +2212,7 @@ recursive subroutine ufbovr(lunit,usr,i1,i2,iret,str) call string(str,lun,i1,io) call trybump(lun,usr,i1,i2,io,iret) - if(io.eq.1 .and. iret.ne.i2) then + if(io==1 .and. iret/=i2) then write(bort_str1,'("BUFRLIB: UFBOVR - MNEMONIC STRING READ IN IS: ",A)') str write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// & 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret, i2 @@ -2309,14 +2309,14 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) ! Check the file status and inode call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '// & 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBEVN - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -2325,8 +2325,8 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.ge.0) then + elseif(i2<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBEVN - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -2335,8 +2335,8 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) call errwrt(' ') endif return - elseif(i3.le.0) then - if(iprt.ge.0) then + elseif(i3<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBEVN - 5th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -2367,18 +2367,18 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) inc2 = 1 outer: do while (.true.) call conwin(lun,inc1,inc2) - if(nnod.eq.0) then + if(nnod==0) then iret = i2 return - elseif(inc1.eq.0) then + elseif(inc1==0) then return else nodgt0 = .false. do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then ins2 = inc1 call getwin(nods(i),lun,ins1,ins2) - if(ins1.eq.0) return + if(ins1==0) return nodgt0 = .true. exit endif @@ -2390,9 +2390,9 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) ! Read push down stack data into 3D arrays inner: do while (.true.) iret = iret+1 - if(iret.le.i2) then + if(iret<=i2) then do j=1,nnod - if(nods(j).gt.0) then + if(nods(j)>0) then nnvn = nvnwin(nods(j),lun,ins1,ins2,invn,i3) maxevn = max(nnvn,maxevn) do k=1,nnvn @@ -2403,14 +2403,14 @@ recursive subroutine ufbevn(lunit,usr,i1,i2,i3,iret,str) endif ! Decide what to do next call nxtwin(lun,ins1,ins2) - if(ins1.le.0 .or. ins1.ge.inc2) exit inner + if(ins1<=0 .or. ins1>=inc2) exit inner enddo inner - if(ncon.le.0) exit outer + if(ncon<=0) exit outer endif enddo outer - if(iret.eq.0) then - if(iprt.ge.1) then + if(iret==0) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) =' call errwrt(errstr) @@ -2513,14 +2513,14 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) ! Check the file status and inode call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') - if(inode(lun).ne.inv(1,lun)) call bort('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// & + if(il==0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(inode(lun)/=inv(1,lun)) call bort('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '// & 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY') - if(i1.le.0) then - if(iprt.ge.0) then + if(i1<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0, ' // & 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) =' @@ -2530,8 +2530,8 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) call errwrt(' ') endif return - elseif(i2.le.0) then - if(iprt.ge.0) then + elseif(i2<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS .LE. 0, ' // & 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) =' @@ -2541,8 +2541,8 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) call errwrt(' ') endif return - elseif(i3.le.0) then - if(iprt.ge.0) then + elseif(i3<=0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS .LE. 0, ' // & 'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) =' @@ -2574,18 +2574,18 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) inc2 = 1 outer: do while (.true.) call conwin(lun,inc1,inc2) - if(nnod.eq.0) then + if(nnod==0) then iret = i2 return - elseif(inc1.eq.0) then + elseif(inc1==0) then return else nodgt0 = .false. do i=1,nnod - if(nods(i).gt.0) then + if(nods(i)>0) then ins2 = inc1 call getwin(nods(i),lun,ins1,ins2) - if(ins1.eq.0) return + if(ins1==0) return nodgt0 = .true. exit endif @@ -2597,7 +2597,7 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) ! Read push down stack data into 3D arrays inner: do while (.true.) iret = iret+1 - if(iret.le.i2) then + if(iret<=i2) then do j=1,nnod nnvn = nevn(nods(j),lun,ins1,ins2,i1,i2,i3,usr(j,iret,1)) jret = max(jret,nnvn) @@ -2605,14 +2605,14 @@ recursive subroutine ufbin3(lunit,usr,i1,i2,i3,iret,jret,str) endif ! Decide what to do next call nxtwin(lun,ins1,ins2) - if(ins1.le.0 .or. ins1.ge.inc2) exit inner + if(ins1<=0 .or. ins1>=inc2) exit inner enddo inner - if(ncon.le.0) exit outer + if(ncon<=0) exit outer endif enddo outer - if(iret.eq.0 .or. jret.eq.0) then - if(iprt.ge.1) then + if(iret==0 .or. jret==0) then + if(iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' // & 'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; 8th ARG. (STR) =' @@ -2695,7 +2695,7 @@ recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str) endif call status(lunit,lun,il,im) - openit = il.eq.0 + openit = il==0 if(openit) then ! Open BUFR file connected to unit lunit if it isn't already open @@ -2708,7 +2708,7 @@ recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str) ! Skip to the requested message do i=1,imsg call readmg(lunit,subset,jdate,jret) - if(jret.lt.0) then + if(jret<0) then write(bort_str,'("BUFRLIB: UFBINX - HIT END OF FILE BEFORE '// & 'READING REQUESTED MESSAGE NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') imsg, lunit call bort(bort_str) @@ -2718,7 +2718,7 @@ recursive subroutine ufbinx(lunit,imsg,isub,usr,i1,i2,iret,str) ! Position at the requested subset do i=1,isub call readsb(lunit,jret) - if(jret.ne.0) then + if(jret/=0) then write(bort_str,'("BUFRLIB: UFBINX - ALL SUBSETS READ BEFORE '// & 'READING REQ. SUBSET NO.",I3," IN REQ. MSG NO.",I5," IN BUFR FILE CONNECTED TO UNIT",I4)') isub, imsg, lunit call bort(bort_str) @@ -2801,13 +2801,13 @@ recursive subroutine ufbget(lunit,tab,i1,iret,str) ! Make sure a file/message is open for input call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') ! See if there's another subset in the message - if(nsub(lun).eq.msub(lun)) then + if(nsub(lun)==msub(lun)) then iret = -1 return endif @@ -2826,10 +2826,10 @@ recursive subroutine ufbget(lunit,tab,i1,iret,str) node = inv(n,lun) nbit(n) = ibt(node) mbit(n) = mbit(n-1)+nbit(n-1) - if(node.eq.nods(nnod)) then + if(node==nods(nnod)) then nval(lun) = n exit - elseif(itp(node).eq.1) then + elseif(itp(node)==1) then call upb8(ival,nbit(n),mbit(n),mbay(1,lun)) nbmp=int(ival) call usrtpl(lun,n,nbmp) @@ -2841,13 +2841,13 @@ recursive subroutine ufbget(lunit,tab,i1,iret,str) do i=1,nnod node = nods(i) invn = invwin(node,lun,1,nval(lun)) - if(invn.gt.0) then + if(invn>0) then call upb8(ival,nbit(invn),mbit(invn),mbay(1,lun)) - if(itp(node).eq.1) then + if(itp(node)==1) then tab(i) = ival - elseif(itp(node).eq.2) then - if(ival.lt.2_8**(ibt(node))-1) tab(i) = ups(ival,node) - elseif(itp(node).eq.3) then + elseif(itp(node)==2) then + if(ival<2_8**(ibt(node))-1) tab(i) = ups(ival,node) + elseif(itp(node)==3) then cval = ' ' kbit = mbit(invn) call upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.) @@ -2903,13 +2903,13 @@ integer function nevn(node,lun,inv1,inv2,i1,i2,i3,usr) result(iret) ! Find the enclosing event stack descriptor ndrs = lstjpb(node,lun,'DRS') - if(ndrs.le.0) return + if(ndrs<=0) return invn = invwin(ndrs,lun,inv1,inv2) - if(invn.eq.0) call bort('BUFRLIB: iret - CAN''T FIND THE EVENT STACK!!!!!!') + if(invn==0) call bort('BUFRLIB: iret - CAN''T FIND THE EVENT STACK!!!!!!') iret = nint(val(invn,lun)) - if(iret.gt.i3) then + if(iret>i3) then write(bort_str,'("BUFRLIB: NEVN - THE NO. OF EVENTS FOR THE '// & 'REQUESTED STACK (",I3,") EXCEEDS THE VALUE OF THE 3RD DIM. OF THE USR ARRAY (",I3,")")') iret, i3 call bort(bort_str) @@ -2923,7 +2923,7 @@ integer function nevn(node,lun,inv1,inv2,i1,i2,i3,usr) result(iret) n1 = n2 n2 = n2 + nint(val(n1,lun)) do n=n1,n2 - if(inv(n,lun).eq.node) usr(1,1,l) = val(n,lun) + if(inv(n,lun)==node) usr(1,1,l) = val(n,lun) enddo enddo diff --git a/src/s013vals.F90 b/src/s013vals.F90 index 1e54d9af..fbd11287 100644 --- a/src/s013vals.F90 +++ b/src/s013vals.F90 @@ -74,116 +74,116 @@ recursive subroutine gets1loc(s1mnem,iben,isbyt,iwid,iret) iret = 0 iwid = 8 - if(s1mnem.eq.'LEN1') then + if(s1mnem=='LEN1') then isbyt = 1 iwid = 24 - else if(s1mnem.eq.'BMT') then + else if(s1mnem=='BMT') then isbyt = 4 - else if(s1mnem.eq.'OGCE') then - if(iben.eq.3) then + else if(s1mnem=='OGCE') then + if(iben==3) then isbyt = 6 else ! Note that this location is actually the same for both edition 2 and edition 4 of BUFR isbyt = 5 iwid = 16 endif - else if(s1mnem.eq.'GSES') then - if(iben.eq.3) then + else if(s1mnem=='GSES') then + if(iben==3) then isbyt = 5 - else if(iben.eq.4) then + else if(iben==4) then isbyt = 7 iwid = 16 else iret = -1 endif - else if(s1mnem.eq.'USN') then - if(iben.eq.4) then + else if(s1mnem=='USN') then + if(iben==4) then isbyt = 9 else isbyt = 7 endif - else if(s1mnem.eq.'ISC2') then + else if(s1mnem=='ISC2') then iwid = 1 - if(iben.eq.4) then + if(iben==4) then isbyt = 10 else isbyt = 8 endif - else if(s1mnem.eq.'MTYP') then - if(iben.eq.4) then + else if(s1mnem=='MTYP') then + if(iben==4) then isbyt = 11 else isbyt = 9 endif - else if(s1mnem.eq.'MSBTI') then - if(iben.eq.4) then + else if(s1mnem=='MSBTI') then + if(iben==4) then isbyt = 12 else iret = -1 endif - else if(s1mnem.eq.'MSBT') then - if(iben.eq.4) then + else if(s1mnem=='MSBT') then + if(iben==4) then isbyt = 13 else isbyt = 10 endif - else if(s1mnem.eq.'MTV') then - if(iben.eq.4) then + else if(s1mnem=='MTV') then + if(iben==4) then isbyt = 14 else isbyt = 11 endif - else if(s1mnem.eq.'MTVL') then - if(iben.eq.4) then + else if(s1mnem=='MTVL') then + if(iben==4) then isbyt = 15 else isbyt = 12 endif - else if(s1mnem.eq.'YEAR') then - if(iben.eq.4) then + else if(s1mnem=='YEAR') then + if(iben==4) then isbyt = 16 iwid = 16 else iret = -1 endif - else if(s1mnem.eq.'YCEN') then - if(iben.lt.4) then + else if(s1mnem=='YCEN') then + if(iben<4) then isbyt = 13 else iret = -1 endif - else if(s1mnem.eq.'CENT') then - if(iben.lt.4) then + else if(s1mnem=='CENT') then + if(iben<4) then isbyt = 18 else iret = -1 endif - else if(s1mnem.eq.'MNTH') then - if(iben.eq.4) then + else if(s1mnem=='MNTH') then + if(iben==4) then isbyt = 18 else isbyt = 14 endif - else if(s1mnem.eq.'DAYS') then - if(iben.eq.4) then + else if(s1mnem=='DAYS') then + if(iben==4) then isbyt = 19 else isbyt = 15 endif - else if(s1mnem.eq.'HOUR') then - if(iben.eq.4) then + else if(s1mnem=='HOUR') then + if(iben==4) then isbyt = 20 else isbyt = 16 endif - else if(s1mnem.eq.'MINU') then - if(iben.eq.4) then + else if(s1mnem=='MINU') then + if(iben==4) then isbyt = 21 else isbyt = 17 endif - else if(s1mnem.eq.'SECO') then - if(iben.eq.4) then + else if(s1mnem=='SECO') then + if(iben==4) then isbyt = 22 else iret = -1 @@ -257,7 +257,7 @@ recursive integer function iupbs01(mbay,s01mnem) result(iret) logical ok4cent ! This statement function checks whether its input value contains a valid century value. - ok4cent(ival) = ((ival.ge.19).and.(ival.le.21)) + ok4cent(ival) = ((ival>=19).and.(ival<=21)) ! Check for I8 integers. @@ -272,13 +272,13 @@ recursive integer function iupbs01(mbay,s01mnem) result(iret) ! Handle some simple requests that do not depend on the BUFR edition number. - if(s01mnem.eq.'LENM') then + if(s01mnem=='LENM') then iret = iupb(mbay,5,24) return endif len0 = 8 - if(s01mnem.eq.'LEN0') then + if(s01mnem=='LEN0') then iret = len0 return endif @@ -286,7 +286,7 @@ recursive integer function iupbs01(mbay,s01mnem) result(iret) ! Get the BUFR edition number. iben = iupb(mbay,8,8) - if(s01mnem.eq.'BEN') then + if(s01mnem=='BEN') then iret = iben return endif @@ -294,15 +294,15 @@ recursive integer function iupbs01(mbay,s01mnem) result(iret) ! Use the BUFR edition number to handle any other requests. call gets1loc(s01mnem,iben,isbyt,iwid,iretgs) - if(iretgs.eq.0) then + if(iretgs==0) then iret = iupb(mbay,len0+isbyt,iwid) - if(s01mnem.eq.'CENT') then + if(s01mnem=='CENT') then ! Test whether the returned value was a valid century value. if(.not.ok4cent(iret)) iret = -1 endif - else if( (s01mnem.eq.'YEAR') .and. (iben.lt.4) ) then + else if( (s01mnem=='YEAR') .and. (iben<4) ) then ! Calculate the 4-digit year. @@ -374,11 +374,11 @@ recursive integer function iupbs3(mbay,s3mnem) result(iret) ! Unpack the requested value. - if(s3mnem.eq.'NSUB') then + if(s3mnem=='NSUB') then iret = iupb(mbay,ipt+5,16) - else if( (s3mnem.eq.'IOBS') .or. (s3mnem.eq.'ICMP') ) then + else if( (s3mnem=='IOBS') .or. (s3mnem=='ICMP') ) then ival = iupb(mbay,ipt+7,8) - if(s3mnem.eq.'IOBS') then + if(s3mnem=='IOBS') then imask = 128 else imask = 64 @@ -469,9 +469,9 @@ recursive integer function iupvs01(lunit,s01mnem) result(iret) ! Check the file status call status(lunit,lun,ilst,imst) - if(ilst.eq.0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') - if(ilst.gt.0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') - if(imst.eq.0) call bort('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') + if(ilst==0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT') + if(ilst>0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT') + if(imst==0) call bort('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE') ! Unpack the requested value @@ -548,11 +548,11 @@ recursive subroutine pkbs1(ival,mbay,s1mnem) ! 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 + if ( (iret==0) .and. & + ( (s1mnem=='USN') .or. (s1mnem=='BMT') .or. (s1mnem=='OGCE') .or. (s1mnem=='GSES') .or. (s1mnem=='MTYP') .or. & + (s1mnem=='MSBTI') .or. (s1mnem=='MSBT') .or. (s1mnem=='MTV') .or. (s1mnem=='MTVL') .or. (s1mnem=='YCEN') .or.& + (s1mnem=='CENT') .or. (s1mnem=='YEAR') .or. (s1mnem=='MNTH') .or. (s1mnem=='DAYS') .or. (s1mnem=='HOUR') .or.& + (s1mnem=='MINU') .or. (s1mnem=='SECO') ) ) then ! Store the value. ibit = (iupbs01(mbay,'LEN0')+isbyt-1)*8 call pkb(ival,iwid,mbay,ibit) @@ -652,9 +652,9 @@ recursive subroutine pkvs01(s01mnem,ival) ! If an ival has already been assigned for this particular s01mnem, then overwrite that entry in module @ref moda_s01cm ! using the new ival. - if(ns01v.gt.0) then + if(ns01v>0) then do i=1,ns01v - if(s01mnem.eq.cmnem(i)) then + if(s01mnem==cmnem(i)) then ivmnem(i) = ival return endif @@ -663,7 +663,7 @@ recursive subroutine pkvs01(s01mnem,ival) ! Otherwise, use the next available unused entry in module @ref moda_s01cm. - if(ns01v.ge.mxs01v) then + if(ns01v>=mxs01v) then write(bort_str,'("BUFRLIB: PKVS01 - CANNOT OVERWRITE MORE THAN ",I2," DIFFERENT LOCATIONS WITHIN SECTION 0 '// & 'OR SECTION 1")') mxs01v call bort(bort_str) @@ -710,7 +710,7 @@ subroutine reads3 ( lun ) ! Check whether the appropriate BUFR master table information has already been read into internal memory for this message. - if ( ireadmt ( lun ) .eq. 1 ) then + if ( ireadmt ( lun ) == 1 ) then ! NO (i.e. we just had to read in new master table information for this message), so reset some corresponding values in ! other parts of the library. call dxinit ( lun, 0 ) @@ -733,14 +733,14 @@ subroutine reads3 ( lun ) ! bypassed whenever a list is already in the cache. incach = .false. - if ( ncnem .gt. 0 ) then + if ( ncnem > 0 ) then ii = 1 - do while ( (.not.incach) .and. (ii.le.ncnem) ) - if ( ncds3 .eq. ndc(ii) ) then + do while ( (.not.incach) .and. (ii<=ncnem) ) + if ( ncds3 == ndc(ii) ) then jj = 1 incach = .true. - do while ( (incach) .and. (jj.le.ncds3) ) - if ( ids3(jj) .eq. idcach(ii,jj) ) then + do while ( (incach) .and. (jj<=ncds3) ) + if ( ids3(jj) == idcach(ii,jj) ) then jj = jj + 1 else incach = .false. @@ -750,7 +750,7 @@ subroutine reads3 ( lun ) ! The list is already in the cache, so store the corresponding Table A mnemonic into module @ref moda_sc3bfr and return. - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') errstr = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // cnem(ii) call errwrt(errstr) @@ -777,13 +777,13 @@ subroutine reads3 ( lun ) ! Store the Table A mnemonic and sequence into the cache. ncnem = ncnem + 1 - if ( ncnem .gt. mxcnem ) call bort('BUFRLIB: READS3 - MXCNEM OVERFLOW') + if ( ncnem > mxcnem ) call bort('BUFRLIB: READS3 - MXCNEM OVERFLOW') cnem(ncnem) = tamnem(lun) ndc(ncnem) = ncds3 do jj = 1, ncds3 idcach(ncnem,jj) = ids3(jj) enddo - if ( iprt .ge. 2 ) then + if ( iprt >= 2 ) then call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++') errstr = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' // cnem(ncnem) call errwrt(errstr) @@ -861,7 +861,7 @@ recursive subroutine upds3(mbay,lcds3,cds3,nds3) nds3 = 0 do jj = 8,(len3-1),2 nds3 = nds3 + 1 - if(nds3.gt.lcds3) call bort('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') + if(nds3>lcds3) call bort('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') cds3(nds3) = adn30(iupb(mbay,ipt+jj,16),6) enddo @@ -908,7 +908,7 @@ recursive subroutine datelen(len) return endif - if(len.ne.8 .and. len.ne.10) then + if(len/=8 .and. len/=10) then write(bort_str,'("BUFRLIB: DATELEN - INPUT ARGUMENT IS",I4," - IT MUST BE EITHER 8 OR 10")') len call bort(bort_str) endif @@ -973,7 +973,7 @@ recursive subroutine datebf(lunit,mear,mmon,mday,mour,idate) ! See if the file is already open to the library (a no-no!). call status(lunit,lun,jl,jm) - if(jl.ne.0) call bort ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + if(jl/=0) call bort ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') ! Read to the first data message and pick out the date. @@ -981,8 +981,8 @@ recursive subroutine datebf(lunit,mear,mmon,mday,mour,idate) idx = 1 do while (idx==1) call rdmsgw(lunit,mgwa,ier) - if(ier.lt.0) then - if (iprt.ge.1) then + if(ier<0) then + if (iprt>=1) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: DATEBF - SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH IDATE = -1' call errwrt(errstr) @@ -1047,7 +1047,7 @@ recursive integer function igetdate(mbay,iyr,imo,idy,ihr) result(iret) imo = iupbs01(mbay,'MNTH') idy = iupbs01(mbay,'DAYS') ihr = iupbs01(mbay,'HOUR') - if(lendat.ne.10) iyr = mod(iyr,100) + if(lendat/=10) iyr = mod(iyr,100) iret = (iyr*1000000) + (imo*10000) + (idy*100) + ihr return @@ -1087,9 +1087,9 @@ recursive integer function i4dy(idate) result(iret) return endif - if(idate.lt.10**8) then + if(idate<10**8) then iy = idate/10**6 - if(iy.gt.40) then + if(iy>40) then iret = idate + 19*100000000 else iret = idate + 20*100000000 @@ -1170,23 +1170,23 @@ recursive subroutine dumpbf(lunit,jdate,jdump) ! See if the file is already open to the library (a no-no!). call status(lunit,lun,jl,jm) - if(jl.ne.0) call bort('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') + if(jl/=0) call bort('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED') call openbf(lunit,'INX',lunit) do while (.true.) call rdmsgw(lunit,mgwa,ier) - if(ier.ne.0) exit - if(idxmsg(mgwa).eq.1) cycle ! Skip past any dictionary messages + if(ier/=0) exit + if(idxmsg(mgwa)==1) cycle ! Skip past any dictionary messages ! The dump center YY,MM,DD,HH,MM should be in this message, which is the first message containing zero subsets - if(iupbs3(mgwa,'NSUB').ne.0) exit + if(iupbs3(mgwa,'NSUB')/=0) exit ii = igetdate(mgwa,jdate(1),jdate(2),jdate(3),jdate(4)) jdate(5) = iupbs01(mgwa,'MINU') ! The dump clock YY,MM,DD,HH,MM should be in the next message, which is the second message containing zero subsets call rdmsgw(lunit,mgwa,ier) - if(ier.ne.0) exit - if(iupbs3(mgwa,'NSUB').ne.0) exit + if(ier/=0) exit + if(iupbs3(mgwa,'NSUB')/=0) exit ii = igetdate(mgwa,jdump(1),jdump(2),jdump(3),jdump(4)) jdump(5) = iupbs01(mgwa,'MINU') @@ -1194,13 +1194,13 @@ recursive subroutine dumpbf(lunit,jdate,jdump) return enddo - if (iprt.ge.1 .and. (jdate(1).eq.-1.or.jdump(1).eq.-1)) then + if (iprt>=1 .and. (jdate(1)==-1.or.jdump(1)==-1)) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') - if(jdate(1).eq.-1) then + if(jdate(1)==-1) then errstr = 'BUFRLIB: DUMPBF - FIRST EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH JDATE = 5*-1' call errwrt(errstr) endif - if(jdump(1).eq.-1) then + if(jdump(1)==-1) then errstr = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH JDUMP = 5*-1' call errwrt(errstr) endif @@ -1245,9 +1245,9 @@ recursive subroutine minimg(lunit,mini) endif call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') - if(il.lt.0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') - if(im.eq.0) call bort('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') + if(il==0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT') + if(il<0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT') + if(im==0) call bort('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE') call pkbs1(mini,mbay(1,lun),'MINU') @@ -1303,11 +1303,11 @@ subroutine cktaba(lun,subset,jdate,iret) msbt = iupbs01(mbay(1,lun),'MSBT') jdate = igetdate(mbay(1,lun),iyr,imo,idy,ihr) - if(mtyp.eq.11) then + if(mtyp==11) then ! This is a BUFR table (dictionary) message iret = 11 ! There's no need to proceed any further unless Section 3 is being used for decoding - if(isc3(lun).eq.0) then + if(isc3(lun)==0) then subset = " " return endif @@ -1328,11 +1328,11 @@ subroutine cktaba(lun,subset,jdate,iret) outer: do while (.true.) - if(isc3(lun).ne.0) then + if(isc3(lun)/=0) then ! Section 3 is being used for decoding subset = tamnem(lun) call nemtbax(lun,subset,mty1,msb1,inod) - if(inod.gt.0) then + if(inod>0) then mbyt(lun) = 8*(iad4+4) msgunp(lun) = 1 exit outer @@ -1343,7 +1343,7 @@ subroutine cktaba(lun,subset,jdate,iret) call numtab(lun,isub,subset,tab,itab) call nemtbax(lun,subset,mty1,msb1,inod) - if(inod.gt.0) then + if(inod>0) then ! The second descriptor in Section 3 corresponds to the Table A mnemonic, so the message contains non-standard ! NCEP extensions mbyt(lun) = (iad4+4) @@ -1353,7 +1353,7 @@ subroutine cktaba(lun,subset,jdate,iret) call numtab(lun,ksub,subset,tab,itab) call nemtbax(lun,subset,mty1,msb1,inod) - if(inod.gt.0) then + if(inod>0) then ! The first descriptor in Section 3 corresponds to the Table A mnemonic, so the message is WMO-standard mbyt(lun) = 8*(iad4+4) msgunp(lun) = 1 @@ -1363,11 +1363,11 @@ subroutine cktaba(lun,subset,jdate,iret) ! OK, still no luck, so try "NCtttsss" (where ttt=mtyp and sss=msbt) as the Table A mnemonic, and if that doesn't work ! then also try "FRtttsss" AND "FNtttsss" ii=1 - do while(ii.le.ncpfx) + do while(ii<=ncpfx) write(subset,'(A2,2I3.3)') cpfx(ii),mtyp,msbt call nemtbax(lun,subset,mty1,msb1,inod) - if(inod.gt.0) then - if(ksub.eq.ibct) then + if(inod>0) then + if(ksub==ibct) then mbyt(lun) = (iad4+4) msgunp(lun) = 0 else @@ -1383,7 +1383,7 @@ subroutine cktaba(lun,subset,jdate,iret) ! Make one last desperate attempt by checking whether the application program contains an in-line version of ! subroutine openbt() to override the default version in the library trybt = .false. - if(iprt.ge.1) then + if(iprt>=1) then call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++') errstr = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL BUFR TABLE VIA CALL TO IN-LINE OPENBT' call errwrt(errstr) @@ -1391,7 +1391,7 @@ subroutine cktaba(lun,subset,jdate,iret) call errwrt(' ') endif call openbt(lundx,mtyp) - if(lundx.gt.0) then + if(lundx>0) then ! There was an in-line replacement for the default library version of openbt(), so read DX table information from ! the specified logical unit and look for the Table A mnemonic there call rdusdx(lundx,lun) @@ -1400,7 +1400,7 @@ subroutine cktaba(lun,subset,jdate,iret) endif ! Give up and report the bad news - if(iprt.ge.0) then + if(iprt>=0) then call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++') errstr = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE (' // SUBSET // ') - RETURN WITH IRET = -1' call errwrt(errstr) @@ -1416,17 +1416,17 @@ subroutine cktaba(lun,subset,jdate,iret) ! Confirm the validity of the message type and subtype, and also check for compression - if(isc3(lun).eq.0) then - if(mtyp.ne.mty1) then + if(isc3(lun)==0) then + if(mtyp/=mty1) then write(bort_str,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH (SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') subset,mtyp,mty1 call bort(bort_str) endif - if( msbt.ne.msb1 .and. ( verify(subset(3:8),'1234567890') == 0 ) ) then + if( msbt/=msb1 .and. ( verify(subset(3:8),'1234567890') == 0 ) ) then write(bort_str,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH (SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') subset,msbt,msb1 call bort(bort_str) endif endif - if(iupbs3(mbay(1,lun),'ICMP').gt.0) msgunp(lun) = 2 + if(iupbs3(mbay(1,lun),'ICMP')>0) msgunp(lun) = 2 ! Update values in @ref moda_msgcwd @@ -1434,7 +1434,7 @@ subroutine cktaba(lun,subset,jdate,iret) inode(lun) = inod msub(lun) = iupbs3(mbay(1,lun),'NSUB') nsub(lun) = 0 - if(iret.ne.11) nmsg(lun) = nmsg(lun)+1 + if(iret/=11) nmsg(lun) = nmsg(lun)+1 return end subroutine cktaba @@ -1507,18 +1507,18 @@ recursive subroutine mesgbc(lunin,mesgtyp,icomp) lunit = abs(lunin) - if(lunit.eq.lunin) then + if(lunit==lunin) then ! Open the file, read past any DX BUFR tables and "dummy" messages, and return the first message type found irec = 0 call openbf(lunit,'INX',lunit) do while (.true.) call rdmsgw(lunit,mgwa,ier) - if(ier.eq.-1) then - if(irec.eq.0) then + if(ier==-1) then + if(irec==0) then mesgtyp = -256 icomp = -3 else - if(mesgtyp.ge.0) mesgtyp = -mesgtyp + if(mesgtyp>=0) mesgtyp = -mesgtyp icomp = -2 endif call closbf(lunit) @@ -1526,7 +1526,7 @@ recursive subroutine mesgbc(lunin,mesgtyp,icomp) endif irec = irec + 1 mesgtyp = iupbs01(mgwa,'MTYP') - if( (idxmsg(mgwa).ne.1) .and. (iupbs3(mgwa,'NSUB').ne.0) ) exit + if( (idxmsg(mgwa)/=1) .and. (iupbs3(mgwa,'NSUB')/=0) ) exit enddo call closbf(lunit) else @@ -1596,9 +1596,9 @@ recursive subroutine mesgbf(lunit,mesgtyp) do while (.true.) call rdmsgw(lunit,mgwa,ier) - if(ier.eq.0) then + if(ier==0) then mesgtyp = iupbs01(mgwa,'MTYP') - if(idxmsg(mgwa).ne.1) exit + if(idxmsg(mgwa)/=1) exit endif enddo diff --git a/src/standard.F90 b/src/standard.F90 index 64b2c08e..7ad642b3 100644 --- a/src/standard.F90 +++ b/src/standard.F90 @@ -42,7 +42,7 @@ subroutine stdmsg(cf) character*128 bort_str call capit(cf) - if(cf.ne.'Y'.and. cf.ne.'N') then + if(cf/='Y'.and. cf/='N') then write(bort_str,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf call bort(bort_str) endif @@ -110,7 +110,7 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) ! lunit must point to an open bufr file. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE OPEN') + if(il==0) call bort('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE OPEN') ! Identify the section lengths and addresses in msgin. @@ -123,7 +123,7 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) lenm = iupbs01(msgin,'LENM') - if(lenn.ne.lenm) then + if(lenn/=lenm) then write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL '// & 'SECTION LENGTHS (",I6,")")') lenm,lenn call bort(bort_str) @@ -131,7 +131,7 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) mbit = (lenn-4)*8 call upc(sevn,4,msgin,mbit,.true.) - if(sevn.ne.'7777') then + if(sevn/='7777') then write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT END WITH ""7777"" (ENDS WITH ",A)') sevn call bort(bort_str) endif @@ -141,25 +141,25 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) mxbyto = (lmsgot*nbytw) - 8 lbyto = iad3+7 - if(lbyto.gt.mxbyto) call bort(bort_arrayoverflow) + if(lbyto>mxbyto) call bort(bort_arrayoverflow) call mvb(msgin,1,msgot,1,lbyto) ! Rewrite new Section 3 in a standard form. First, locate the top-level Table A descriptor. found = .false. ii = 10 - do while ((.not.found).and.(ii.ge.8)) + do while ((.not.found).and.(ii>=8)) isub = iupb(msgin,iad3+ii,16) call numtab(lun,isub,subset,tab,itab) - if((itab.ne.0).and.(tab.eq.'D')) then + if((itab/=0).and.(tab=='D')) then call nemtbax(lun,subset,mtyp,msbt,inod) - if(inod.ne.0) found = .true. + if(inod/=0) found = .true. endif ii = ii - 2 enddo if(.not.found) call bort('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR NOT FOUND') - if (istdesc(isub).eq.0) then + if (istdesc(isub)==0) then ! isub is a non-standard Table A descriptor and needs to be expanded into an equivalent standard sequence call restd_c(lun,isub,ncd,ids3) else @@ -172,11 +172,11 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) len3 = 7+(ncd*2) iben = iupbs01(msgin,'BEN') - if(iben.lt.4) then + if(iben<4) then len3 = len3+1 endif lbyto = lbyto + len3 - 7 - if(lbyto.gt.mxbyto) call bort(bort_arrayoverflow) + if(lbyto>mxbyto) call bort(bort_arrayoverflow) ! Store the descriptors into the new Section 3. @@ -187,7 +187,7 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) ! Depending on the edition number, pad out the new Section 3 with an additional zeroed-out byte to ensure an even byte count. - if(iben.lt.4) then + if(iben<4) then call pkb(0,8,msgot,ibit) endif @@ -198,11 +198,11 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) ! Now the tricky part - new Section 4. - if(iupbs3(msgin,'ICMP').eq.1) then + if(iupbs3(msgin,'ICMP')==1) then ! The data in Section 4 is compressed and is therefore already standardized, so copy it "as is" into the new Section 4. - if((lbyto+len4+4).gt.mxbyto) call bort(bort_arrayoverflow) + if((lbyto+len4+4)>mxbyto) call bort(bort_arrayoverflow) call mvb(msgin,iad4+1,msgot,lbyto+1,len4) jbit = (lbyto+len4)*8 @@ -222,25 +222,25 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) subset_copy: do i=1,nsub call upb(lsub,16,msgin,ibit) - if(nsub.gt.1) then + if(nsub>1) then ! Use the byte counter to copy this subset. islen = lsub-2 else ! This is the only subset in the message, and it could possibly be an overlarge (> 65530 bytes) subset, in ! which case we can't rely on the value stored in the byte counter. either way, we don't really need it. islen = iad4+len4-(ibit/8) - if (mod(len4,2).eq.0) islen = islen - 1 + if (mod(len4,2)==0) islen = islen - 1 endif do l=1,islen call upb(nval,8,msgin,ibit) lbyto = lbyto + 1 - if(lbyto.gt.mxbyto) call bort(bort_arrayoverflow) + if(lbyto>mxbyto) call bort(bort_arrayoverflow) call pkb(nval,8,msgot,jbit) enddo do k=1,8 kbit = ibit-k-8 call upb(kval,8,msgin,kbit) - if(kval.eq.k) then + if(kval==k) then jbit = jbit-k-8 cycle subset_copy endif @@ -252,18 +252,18 @@ recursive subroutine stndrd(lunit,msgin,lmsgot,msgot) ! standardized message (i.e. we will need (at most) 2 more zeroed-out bytes in Section 4, plus the 4 bytes '7777' in ! Section 5), so do a final msgot overflow check now. - if(lbyto+6.gt.mxbyto) call bort(bort_arrayoverflow) + if(lbyto+6>mxbyto) call bort(bort_arrayoverflow) ! Pad the new Section 4 with zeroes up to the next whole byte boundary. - do while(.not.(mod(jbit,8).eq.0)) + do while(.not.(mod(jbit,8)==0)) call pkb(0,1,msgot,jbit) enddo ! Depending on the edition number, we may need to further pad the new Section 4 with an additional zeroed-out byte in ! order to ensure that the padding is up to an even byte boundary. - if( (iben.lt.4) .and. (mod(jbit/8,2).ne.0) ) then + if( (iben<4) .and. (mod(jbit/8,2)/=0) ) then call pkb(0,8,msgot,jbit) endif @@ -306,13 +306,13 @@ integer function istdesc( idn ) result( iret ) adsc = adn30( idn, 6 ) read(adsc,'(I1,I2,I3)') if,ix,iy - if ( if .eq. 1 ) then + if ( if == 1 ) then ! adsc is a replication descriptor and therefore standard by default iret = 1 - else if ( if .eq. 2 ) then + else if ( if == 2 ) then ! adsc is an operator descriptor iret = iokoper( adsc ) - else if ( ( ix .lt. 48 ) .and. ( iy .lt. 192 ) ) then + else if ( ( ix < 48 ) .and. ( iy < 192 ) ) then iret = 1 else iret = 0 diff --git a/src/strings.F90 b/src/strings.F90 index 4f387b2c..cf75fc33 100644 --- a/src/strings.F90 +++ b/src/strings.F90 @@ -48,7 +48,7 @@ subroutine string(str,lun,i1,io) nxt = 0 ust = str ind = inode(lun) - if(len(str).gt.80) then + if(len(str)>80) then write(bort_str1,'("BUFRLIB: STRING - INPUT STRING (",A,") HAS")') str write(bort_str2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') len(str) call bort2(bort_str1,bort_str2) @@ -58,13 +58,13 @@ subroutine string(str,lun,i1,io) incache = .false. do n=1,nstr - if(lux(iord(n),2).eq.ind) then + if(lux(iord(n),2)==ind) then iorx(nxt+1) = iord(n) nxt = nxt+1 endif enddo do n=1,nxt - if(ust.eq.usr(iorx(n))) then + if(ust==usr(iorx(n))) then ! Yes, so copy parameters from the cache @@ -97,7 +97,7 @@ subroutine string(str,lun,i1,io) iord(1) = lstr endif - if(jcon(1).gt.i1) then + if(jcon(1)>i1) then write(bort_str1,'("BUFRLIB: STRING - INPUT STRING (",A,")")') str write(bort_str2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE LIMIT (THIRD INPUT ARGUMENT) IS",I5)') jcon(1), i1 call bort2(bort_str1,bort_str2) @@ -167,7 +167,7 @@ subroutine parusr(str,lun,i1,io) common /usrstr/ nnod, ncon, nods(maxnod), nodc(maxcon), ivls(maxcon), kons(maxcon) ust = str - if(len(str).gt.80) then + if(len(str)>80) then write(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS ")') str write(bort_str2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') len(str) call bort2(bort_str1,bort_str2) @@ -183,10 +183,10 @@ subroutine parusr(str,lun,i1,io) do n=1,ntot ! For each mnemonic, determine if it's a condition node or a store node call parutg(lun,io,utg(n),nod,kon,val) - if(kon.ne.0) then + if(kon/=0) then ! It's a condition node ncon = ncon+1 - if(ncon.gt.maxcon) then + if(ncon>maxcon) then write(bort_str1,'("BUFRLIB: PARUSR - THE NUMBER OF CONDITION NODES IN INPUT STRING")') write(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') str,maxcon call bort2(bort_str1,bort_str2) @@ -197,7 +197,7 @@ subroutine parusr(str,lun,i1,io) else ! It's a store node nnod = nnod+1 - if(nnod.gt.maxnod) then + if(nnod>maxnod) then write(bort_str1,'("BUFRLIB: PARUSR - THE NUMBER OF STORE NODES IN INPUT STRING")') write(bort_str2,'(18X,A,") EXCEEDS THE MAXIMUM (",I3,")")') str,maxnod call bort2(bort_str1,bort_str2) @@ -210,7 +210,7 @@ subroutine parusr(str,lun,i1,io) do i=1,ncon do j=i+1,ncon - if(nodc(i).gt.nodc(j)) then + if(nodc(i)>nodc(j)) then nod = nodc(i) nodc(i) = nodc(j) nodc(j) = nod @@ -228,13 +228,13 @@ subroutine parusr(str,lun,i1,io) bump = .false. do n=1,ncon - if(kons(n).eq.5) then - if(io.eq.0) then + if(kons(n)==5) then + if(io==0) then write(bort_str1,'("BUFRLIB: PARUSR - BUMP NODE (^ IN INPUT STRING ",A)') str write(bort_str2,'(18X,"IS SPECIFIED FOR A BUFR FILE OPEN FOR INPUT, THE BUFR FILE MUST BE OPEN FOR OUTPUT")') call bort2(bort_str1,bort_str2) endif - if(n.ne.ncon) then + if(n/=ncon) then write(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") CONTAINS")') str write(bort_str2,'(18X,"CONDITIONAL NODES IN ADDITION TO BUMP NODE - THE BUMP MUST BE ON THE INNER NODE")') call bort2(bort_str1,bort_str2) @@ -245,12 +245,12 @@ subroutine parusr(str,lun,i1,io) ! Check store node count and alignment - if(.not.bump .and. nnod.eq.0) then + if(.not.bump .and. nnod==0) then write(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") HAS")') str write(bort_str2,'(18X,"NO STORE NODES")') call bort2(bort_str1,bort_str2) endif - if(nnod.gt.i1) then + if(nnod>i1) then write(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,")")') str write(bort_str2,'(18X,"HAS",I5," STORE NODES (MNEMONICS) - THE LIMIT {THIRD (INPUT) ARGUMENT} IS",I5)') nnod,i1 call bort2(bort_str1,bort_str2) @@ -258,9 +258,9 @@ subroutine parusr(str,lun,i1,io) irpc = -1 do i=1,nnod - if(nods(i).gt.0) then - if(irpc.lt.0) irpc = lstjpb(nods(i),lun,'RPC') - if(irpc.ne.lstjpb(nods(i),lun,'RPC').and.iac.eq.0) then + if(nods(i)>0) then + if(irpc<0) irpc = lstjpb(nods(i),lun,'RPC') + if(irpc/=lstjpb(nods(i),lun,'RPC').and.iac==0) then write(bort_str1,'("BUFRLIB: PARUSR - INPUT STRING (",A,") CONTAINS")') str write(bort_str2,'(18X,"STORE NODES (MNEMONICS) THAT ARE IN MORE THAN ONE REPLICATION GROUP")') call bort2(bort_str1,bort_str2) @@ -381,13 +381,13 @@ subroutine parutg(lun,io,utg,nod,kon,val) ! But first, take care of the special case where utg denotes the short (i.e. 1-bit) delayed replication of a Table D ! mnemonic. This will prevent confusion later on since '<' and '>' are each also valid as condition characters. - if((utg(1:1).eq.'<').and.(index(utg(3:),'>').ne.0)) then + if((utg(1:1)=='<').and.(index(utg(3:),'>')/=0)) then atag = utg else outer: do i=1,ltg - if(utg(i:i).eq.' ') exit + if(utg(i:i)==' ') exit do j=1,ncond - if(utg(i:i).eq.cond(j)) then + if(utg(i:i)==cond(j)) then kon = j icv = i+1 exit outer @@ -401,30 +401,30 @@ subroutine parutg(lun,io,utg,nod,kon,val) inod = inode(lun) do nod=inod,isc(inod) - if(atag.eq.tag(nod)) then + if(atag==tag(nod)) then ! We found it, now make sure it has a valid node type - if(kon.eq.5) then + if(kon==5) then ! Condition char "^" must be associated with a delayed replication sequence (this is a "bump" node). This is an ! obsolete feature but remains in the library for compatibility with older application programs. - if(typ(nod-1).ne.'DRP' .and. typ(nod-1).ne.'DRS') then + if(typ(nod-1)/='DRP' .and. typ(nod-1)/='DRS') then write(bort_str1,'("BUFRLIB: PARUTG - BUMP NODE (MNEMONIC ",A,")'// & ' MUST REFER TO A DELAYED REPLICATION SEQUENCE, HERE TYPE IS ",A)') atag,typ(nod-1) call bort(bort_str1) endif - elseif(kon.ne.6) then + elseif(kon/=6) then ! Allow reading (but not writing) of delayed replication factors. atyp = typ(nod) do i=1,nchk - if(atyp.eq.btyp(i) .and. io.gt.iok(i)) then + if(atyp==btyp(i) .and. io>iok(i)) then write(bort_str1,'("BUFRLIB: PARUTG - ILLEGAL NODE TYPE: ",A," FOR MNEMONIC ",A)') atyp,atag call bort(bort_str1) endif enddo endif ! If it's a condition node, then get the condition value which is a number following it - if(kon.ne.0) then + if(kon/=0) then call strnum(utg(icv:ltg),num,ier) - if(ier.lt.0) then + if(ier<0) then write(bort_str1,'("BUFRLIB: PARUTG - CONDITION VALUE IN MNEMONIC ",A," CONTAINS NON-NUMERIC CHARACTERS")') utg call bort(bort_str1) endif @@ -443,7 +443,7 @@ subroutine parutg(lun,io,utg,nod,kon,val) ! (and quietly, if iprt happened to be set to -1 in common /quiet/) not actually store the value corresponding 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 + if(kon==0 .and. (io==0 .or. atag=='NUL' .or. .not.picky)) then nod = 0 else write(bort_str1,'("BUFRLIB: PARUTG - TRYING TO WRITE A MNEMONIC'// & @@ -487,7 +487,7 @@ subroutine parstr(str,tags,mtag,ntag,sep,limit80) lstr = len(str) ltag = len(tags(1)) - if( limit80 .and. (lstr.gt.80) ) then + if( limit80 .and. (lstr>80) ) then write(bort_str1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") HAS ")') str write(bort_str2,'(18X,"LENGTH (",I4,"), > LIMIT OF 80 CHAR.")') lstr call bort2(bort_str1,bort_str2) @@ -497,20 +497,20 @@ subroutine parstr(str,tags,mtag,ntag,sep,limit80) substr = .false. do i=1,lstr - if( .not.substr .and. (str(i:i).ne.sep) ) then + if( .not.substr .and. (str(i:i)/=sep) ) then ntag = ntag+1 - if(ntag.gt.mtag) then + if(ntag>mtag) then write(bort_str1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") CONTAINS",I4)') str,ntag write(bort_str2,'(18X,"SUBSTRINGS, EXCEEDING THE LIMIT {",I4," - THIRD (INPUT) ARGUMENT}")') mtag call bort2(bort_str1,bort_str2) endif tags(ntag) = ' ' endif - if( substr .and. (str(i:i).eq.sep) ) nchr = 0 - substr = str(i:i).ne.sep + if( substr .and. (str(i:i)==sep) ) nchr = 0 + substr = str(i:i)/=sep if(substr) then nchr = nchr+1 - if(nchr.gt.ltag) then + if(nchr>ltag) then write(bort_str1,'("BUFRLIB: PARSTR - INPUT STRING (",A,") ")') str write(bort_str2,'(18X,"CONTAINS A PARSED SUBSTRING WITH LENGTH EXCEEDING THE MAXIMUM OF",I4," CHARACTERS")') ltag call bort2(bort_str1,bort_str2) diff --git a/src/tankrcpt.F90 b/src/tankrcpt.F90 index b7e55ed4..b163aa13 100644 --- a/src/tankrcpt.F90 +++ b/src/tankrcpt.F90 @@ -56,7 +56,7 @@ recursive subroutine atrcpt(msgin,lmsgot,msgot) ! Check for overflow of the output array. Note that the new message will be 6 bytes longer than the input message. lenmot = lenm + 6 - if(lenmot.gt.(lmsgot*nbytw)) & + if(lenmot>(lmsgot*nbytw)) & call bort('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY') len1ot = len1 + 6 @@ -141,12 +141,12 @@ recursive subroutine rtrcptb(mbay,iyr,imo,idy,ihr,imi,iret) ! Check whether the message contains a tank receipt time. - if(iupbs01(mbay,'BEN').eq.4) then + if(iupbs01(mbay,'BEN')==4) then is1byt = 23 else is1byt = 19 endif - if( (is1byt+5) .gt. iupbs01(mbay,'LEN1') ) return + if( (is1byt+5) > iupbs01(mbay,'LEN1') ) return ! Unpack the tank receipt time. @@ -216,9 +216,9 @@ recursive subroutine rtrcpt(lunit,iyr,imo,idy,ihr,imi,iret) ! Check the file status. call status(lunit,lun,il,im) - if(il.eq.0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT MUST BE OPEN FOR INPUT') - if(il.gt.0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR OUTPUT; IT MUST BE OPEN FOR INPUT') - if(im.eq.0) call bort('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE; NONE ARE') + if(il==0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT MUST BE OPEN FOR INPUT') + if(il>0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR OUTPUT; IT MUST BE OPEN FOR INPUT') + if(im==0) call bort('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE; NONE ARE') ! Unpack the tank receipt time. @@ -285,13 +285,13 @@ recursive subroutine strcpt(cf,iyr,imo,idy,ihr,imi) endif call capit(cf) - if(cf.ne.'Y' .and. cf.ne.'N') then + if(cf/='Y' .and. cf/='N') then write(bort_str,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf call bort(bort_str) endif ctrt = cf - if(ctrt.eq.'Y') then + if(ctrt=='Y') then itryr = iyr itrmo = imo itrdy = idy diff --git a/test/intest1.F90 b/test/intest1.F90 index a864a3e4..cb20f890 100644 --- a/test/intest1.F90 +++ b/test/intest1.F90 @@ -56,78 +56,78 @@ program intest1 ! Read a BUFR message from the test file into a memory array. call crbmg_c(bfmg, mxbf, nbyt, ierr) - if (ierr .ne. 0) stop 1 + if (ierr /= 0) stop 1 ! Read and check some values from Section 1. - if (iupbs01(ibfmg, 'MTYP') .ne. 2) stop 2 - if (iupbs01(ibfmg, 'MTV') .ne. 14) stop 3 - if (iupbs01(ibfmg, 'LENM') .ne. 4169) stop 4 + if (iupbs01(ibfmg, 'MTYP') /= 2) stop 2 + if (iupbs01(ibfmg, 'MTV') /= 14) stop 3 + if (iupbs01(ibfmg, 'LENM') /= 4169) stop 4 - ! Read and check some values from Section 3. - if (iupbs3(ibfmg, 'NSUB') .ne. 1) stop 5 - if (iupbs3(ibfmg, 'ICMP') .ne. 0) stop 6 + ! Read and check some values from Section 3. + if (iupbs3(ibfmg, 'NSUB') /= 1) stop 5 + if (iupbs3(ibfmg, 'ICMP') /= 0) stop 6 ! Read and check some data descriptors from Section 3. call upds3(ibfmg, mxds3, cds3, nds3) - IF (nds3 .ne. 8 .or. cds3(1) .ne. '309052' .or. cds3(5) .ne. '002095') stop 7 + IF (nds3 /= 8 .or. cds3(1) /= '309052' .or. cds3(5) /= '002095') stop 7 ! Pass the BUFR message from the memory array into the library. call openbf(11, 'QUIET', 2) ! Turn on some extra print statements for testing call readerme(ibfmg, 11, cmgtag, imgdt, ierme) ! Call readerme a second time with the same BUFR message, to test reusing the Section 3 cache from the first call. call readerme(ibfmg, 11, cmgtag, imgdt, ierme) - if (ierme .ne. 0 .or. cmgtag .ne. 'MSTTB001') stop 8 + if (ierme /= 0 .or. cmgtag /= 'MSTTB001') stop 8 call openbf(11, 'QUIET', 0) ! Turn off extra print statements ! Get and check the element names and units associated with some ! Table B mnemonics. call nemdefs(11, 'VSIGX', celem, cunit, ierndv) - if (ierndv .ne. 0 .or. celem(1:40) .ne. 'Extended vertical sounding significance ' .or. & - cunit(1:12) .ne. 'FLAG TABLE ') stop 9 + if (ierndv /= 0 .or. celem(1:40) /= 'Extended vertical sounding significance ' .or. & + cunit(1:12) /= 'FLAG TABLE ') stop 9 call nemdefs(11, 'SMID', celem, cunit, iernds) - if (iernds .ne. 0 .or. celem(1:39) .ne. 'Ship or mobile land station identifier ' .or. & - cunit(1:10) .ne. 'CCITT IA5 ') stop 10 + if (iernds /= 0 .or. celem(1:39) /= 'Ship or mobile land station identifier ' .or. & + cunit(1:10) /= 'CCITT IA5 ') stop 10 ! Read and check the Section 1 date-time. - if (imgdt .ne. 2012093012) stop 11 + if (imgdt /= 2012093012) stop 11 ! Read a data subset from the BUFR message. - if (ireadsb(11) .ne. 0 ) stop 12 + if (ireadsb(11) /= 0 ) stop 12 ! Get and check the parent of a Table B mnemonic. call gettagpr(11, 'PRLC', 192, tagpr, iertgp) - if (iertgp .ne. 0 .or. tagpr .ne. 'WSPLRAOB') stop 13 + if (iertgp /= 0 .or. tagpr /= 'WSPLRAOB') stop 13 ! Read and check some data values. call ufbint(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'CLONH A4ME HSMSL QCEVR') - IF (nr8lv .ne. 1 .or. nint(r8arr(1,1)*100000) .ne. 10388797 .or. & - nint(r8arr(2,1)) .ne. 7 .or. nint(r8arr(3,1)) .ne. 14 .or. & - ibfms(r8arr(4,1)) .ne. 1) stop 14 + IF (nr8lv /= 1 .or. nint(r8arr(1,1)*100000) /= 10388797 .or. & + nint(r8arr(2,1)) /= 7 .or. nint(r8arr(3,1)) /= 14 .or. & + ibfms(r8arr(4,1)) /= 1) stop 14 ! Read and check a sequence of data values. call ufbseq(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'TDWPRAOB') - IF (nr8lv .ne. 191 .or. nint(r8arr(8,3)*100) .ne. 29416 .or. & - nint(r8arr(10,11)*10) .ne. 55 .or. nint(r8arr(2,12)) .ne. 2048 .or. & - nint(r8arr(5,67)*100000) .ne. -1167 .or. nint(r8arr(1,186)) .ne. 2523) stop 15 + IF (nr8lv /= 191 .or. nint(r8arr(8,3)*100) /= 29416 .or. & + nint(r8arr(10,11)*10) /= 55 .or. nint(r8arr(2,12)) /= 2048 .or. & + nint(r8arr(5,67)*100000) /= -1167 .or. nint(r8arr(1,186)) /= 2523) stop 15 ! Read and check some long character strings. call readlc(11, smidstg, 'SMID') - IF (smidstg(7:9) .ne. 'UAO') stop 16 + IF (smidstg(7:9) /= 'UAO') stop 16 call readlc(11, softvstg, 'SOFTV') - IF (softvstg(5:12) .ne. '5.8.5.10') stop 17 + IF (softvstg(5:12) /= '5.8.5.10') stop 17 ! Read and check section lengths call getlens(ibfmg,5,len0,len1,len2,len3,len4,len5) - if (.not. all((/len0,len1,len2,len3,len4,len5/) .eq. (/8,22,0,24,4111,4/))) stop 18 + if (.not. all((/len0,len1,len2,len3,len4,len5/) == (/8,22,0,24,4111,4/))) stop 18 ! Close the test file. call ccbfl_c() ! Test the i4dy() function. - if (i4dy(80123023) .ne. 1980123023) stop 19 + if (i4dy(80123023) /= 1980123023) stop 19 ! Test idxmsg(). - if (idxmsg(1) .ne. 0) stop 20 + if (idxmsg(1) /= 0) stop 20 print *, 'SUCCESS!' end program intest1 diff --git a/test/intest10.F90 b/test/intest10.F90 index cb4ae764..b3d39c61 100644 --- a/test/intest10.F90 +++ b/test/intest10.F90 @@ -7,26 +7,26 @@ module Share_errstr_intest10 ! This module is needed in order to share information between the test program and subroutine errwrt, because ! the latter is not called by the former but rather is called directly from within the NCEPLIBS-bufr software. - + character*18000 errstr - + integer errstr_len end module Share_errstr_intest10 subroutine errwrt(str) ! This subroutine supersedes the subroutine of the same name within the NCEPLIBS-bufr software, so that we can ! easily test the generation of error messages from within the library. - + use Share_errstr_intest10 - + character*(*) str - + integer str_len - + str_len = len(str) errstr ( errstr_len + 1 : errstr_len + str_len + 1 ) = str errstr_len = errstr_len + str_len - + return end subroutine errwrt @@ -55,11 +55,11 @@ program intest10 call setim8b ( .true. ) #endif - if ( ( isetprm ( 'MAXMSG', 125 ) .ne. 0 ) .or. ( isetprm ( 'MAXMEM', 125000 ) .ne. 0 ) ) stop 1 + if ( ( isetprm ( 'MAXMSG', 125 ) /= 0 ) .or. ( isetprm ( 'MAXMEM', 125000 ) /= 0 ) ) stop 1 ! Test the errwrt branch in status. call status ( 21, lun, il, im ) - if ( index( errstr(1:errstr_len), 'STATUS WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF' ) .eq. 0 ) stop 2 + if ( index( errstr(1:errstr_len), 'STATUS WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF' ) == 0 ) stop 2 ! Test some various out-of-bounds verbosity settings, and test the errwrt branch in arallocf. ! The verbosity level is the 3rd argument whenever the 2nd argument to openbf is 'QUIET'. Any @@ -67,54 +67,54 @@ program intest10 ! request less than -1 should automatically reset internally to the min value of -1. errstr_len = 0 call openbf ( 21, 'QUIET', 4 ) - if ( index( errstr(1:errstr_len), 'ARRAYS WILL BE DYNAMICALLY ALLOCATED USING THE FOLLOWING VALUES' ) .eq. 0 ) stop 3 + if ( index( errstr(1:errstr_len), 'ARRAYS WILL BE DYNAMICALLY ALLOCATED USING THE FOLLOWING VALUES' ) == 0 ) stop 3 call openbf ( 21, 'QUIET', -2 ) call openbf ( 21, 'QUIET', 1 ) ! Test the errwrt branches in ufbmem. open ( unit = 21, file = 'testfiles/IN_10_infile1', form = 'unformatted', iostat = ios1 ) open ( unit = 22, file = 'testfiles/IN_10_infile2', form = 'unformatted', iostat = ios2 ) - if ( ( ios1 .ne. 0 ) .or. ( ios2 .ne. 0 ) ) stop 4 + if ( ( ios1 /= 0 ) .or. ( ios2 /= 0 ) ) stop 4 errstr_len = 0 call ufbmem ( 21, 0, icnt, iunt ) - if ( ( icnt .ne. 125 ) .or. & - ( index( errstr(1:errstr_len), 'UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ALL MESSAGES' ) .eq. 0 ) ) stop 5 + if ( ( icnt /= 125 ) .or. & + ( index( errstr(1:errstr_len), 'UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ALL MESSAGES' ) == 0 ) ) stop 5 call ufbmem ( 22, 0, icnt, iunt ) - if ( ( icnt .ne. 97 ) .or. & - ( index( errstr(1:errstr_len), 'UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ALL MESSAGES' ) .eq. 0 ) ) stop 6 + if ( ( icnt /= 97 ) .or. & + ( index( errstr(1:errstr_len), 'UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ALL MESSAGES' ) == 0 ) ) stop 6 ! Test some errwrt branches in rdmemm (via readmm). errstr_len = 0 imsg = 0 call readmm ( imsg, cmgtag, idate, iret ) - if ( index( errstr(1:errstr_len), 'REQUESTED MEMORY MESSAGE NUMBER {FIRST (INPUT) ARGUMENT} IS 0' ) .eq. 0 ) stop 7 + if ( index( errstr(1:errstr_len), 'REQUESTED MEMORY MESSAGE NUMBER {FIRST (INPUT) ARGUMENT} IS 0' ) == 0 ) stop 7 imsg = 350 call readmm ( imsg, cmgtag, idate, iret ) - if ( index( errstr(1:errstr_len), '1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY' ) .eq. 0 ) stop 8 + if ( index( errstr(1:errstr_len), '1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY' ) == 0 ) stop 8 ! Reset the input files. call closbf ( 21 ) call closbf ( 22 ) open ( unit = 21, file = 'testfiles/IN_10_infile1', form = 'unformatted', iostat = ios1 ) open ( unit = 22, file = 'testfiles/IN_10_infile2', form = 'unformatted', iostat = ios2 ) - if ( ( ios1 .ne. 0 ) .or. ( ios2 .ne. 0 ) ) stop 9 + if ( ( ios1 /= 0 ) .or. ( ios2 /= 0 ) ) stop 9 ! Test the errwrt branches in ufbmex. errstr_len = 0 call ufbmex ( 21, 21, 0, icnt, imesg ) - if ( ( icnt .ne. 125 ) .or. & - ( index( errstr(1:errstr_len), 'UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ALL MESSAGES' ) .eq. 0 ) ) stop 10 + if ( ( icnt /= 125 ) .or. & + ( index( errstr(1:errstr_len), 'UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ALL MESSAGES' ) == 0 ) ) stop 10 call ufbmex ( 22, 22, 0, icnt, imesg ) - if ( ( icnt .ne. 97 ) .or. & - ( index( errstr(1:errstr_len), 'UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ALL MESSAGES' ) .eq. 0 ) ) stop 11 + if ( ( icnt /= 97 ) .or. & + ( index( errstr(1:errstr_len), 'UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ALL MESSAGES' ) == 0 ) ) stop 11 ! Test the errwrt branch in openbt, both indirectly and directly. errstr_len = 0 call rdmemm ( 50, cmgtag, idate, iret ) - if ( index( errstr(1:errstr_len), 'OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE' ) .eq. 0 ) stop 12 + if ( index( errstr(1:errstr_len), 'OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE' ) == 0 ) stop 12 errstr_len = 0 call openbt ( lundx, 255 ) - if ( index( errstr(1:errstr_len), 'OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE' ) .eq. 0 ) stop 13 + if ( index( errstr(1:errstr_len), 'OPENBT - THIS IS A DUMMY BUFRLIB ROUTINE' ) == 0 ) stop 13 ! Test the errwrt branch in readerme. errstr_len = 0 @@ -125,9 +125,9 @@ program intest10 call openbf ( 31, 'QUIET', 2 ) do ii = 1, 4 call crbmg_c ( bfmg, mxbf, lenmg, ierrb ) - if ( ierrb .ne. 0 ) stop 14 + if ( ierrb /= 0 ) stop 14 call readerme ( ibfmg, 31, cmgtag, idate, iret ) - if ( ii .eq. 4 .and. index( errstr(1:errstr_len), 'READERME - STORED NEW DX TABLE' ) .eq. 0 ) stop 15 + if ( ii == 4 .and. index( errstr(1:errstr_len), 'READERME - STORED NEW DX TABLE' ) == 0 ) stop 15 enddo print *, 'SUCCESS!' diff --git a/test/intest11.F90 b/test/intest11.F90 index 44791bc7..fd893246 100644 --- a/test/intest11.F90 +++ b/test/intest11.F90 @@ -10,14 +10,14 @@ program intest11 integer*4, parameter :: mxbf = 200000 integer*4 lenmg, ierrb - + integer, parameter :: mxbfd4 = mxbf/4 integer ibfmg(mxbfd4), ibfmg2(mxbfd4), imesg(50) integer ios1, ios2, ncds3, iret, imgdt - + character bfmg(mxbf), cds3(5)*6, cmgtag*8 character filnam*25 / 'testfiles/IN_11' / - + equivalence ( bfmg(1), ibfmg(1) ) print *, 'Testing reading IN_11 using STNDRD and RDMEMS' @@ -29,30 +29,30 @@ program intest11 ! Use crbmg to read the first message from the file into an array. call cobfl_c ( filnam, 'r' ) call crbmg_c ( bfmg, mxbf, lenmg, ierrb ) - if ( ierrb .ne. 0 ) stop 1 + if ( ierrb /= 0 ) stop 1 call ccbfl_c () ! Re-open the file for reading via openbf, then pass the array message into stndrd and check some values. open ( unit = 11, file = filnam, form = 'unformatted', iostat = ios1 ) open ( unit = 12, file = 'testfiles/IN_11_bufrtab', iostat = ios2 ) - if ( ios1 .ne. 0 .or. ios2 .ne. 0 ) stop 2 - call openbf ( 11, 'IN', 12 ) + if ( ios1 /= 0 .or. ios2 /= 0 ) stop 2 + call openbf ( 11, 'IN', 12 ) call stndrd ( 11, ibfmg, mxbfd4, ibfmg2 ) call upds3 ( ibfmg2, 5, cds3, ncds3 ) - if ( ncds3 .ne. 1 .or. cds3(1) .ne. '310190' ) stop 3 + if ( ncds3 /= 1 .or. cds3(1) /= '310190' ) stop 3 call closbf ( 11 ) ! Re-open the file for reading via ufbmex. open ( unit = 11, file = filnam, form = 'unformatted', iostat = ios1 ) - if ( ios1 .ne. 0 ) stop 4 + if ( ios1 /= 0 ) stop 4 call ufbmex ( 11, 12, 0, iret, imesg ) - if ( iret .ne. 2 .or. imesg(1) .ne. 3 ) stop 5 + if ( iret /= 2 .or. imesg(1) /= 3 ) stop 5 ! Read the 8th subset from the 2nd message, which is a standardized copy of the 1st message. call rdmemm ( 2, cmgtag, imgdt, iret ) - if ( iret .ne. 0 .or. cmgtag .ne. 'NC003010') stop 6 + if ( iret /= 0 .or. cmgtag /= 'NC003010') stop 6 call rdmems ( 8, iret ) - if ( iret .ne. 0 ) stop 7 + if ( iret /= 0 ) stop 7 print *, 'SUCCESS!' end program intest11 diff --git a/test/intest12.F90 b/test/intest12.F90 index 83b4e192..89e45695 100644 --- a/test/intest12.F90 +++ b/test/intest12.F90 @@ -7,26 +7,26 @@ module Share_errstr_intest12 ! This module is needed in order to share information between the test program and subroutine errwrt, because ! the latter is not called by the former but rather is called directly from within the NCEPLIBS-bufr software. - + character(len=:), allocatable :: errstr - + integer errstr_len end module Share_errstr_intest12 subroutine errwrt(str) ! This subroutine supersedes the subroutine of the same name within the NCEPLIBS-bufr software, so that we can ! easily test the generation of error messages from within the library. - + use Share_errstr_intest12 - + character*(*) str - + integer str_len - + str_len = len(str) errstr ( errstr_len + 1 : errstr_len + str_len + 1 ) = str errstr_len = errstr_len + str_len - + return end subroutine errwrt @@ -52,37 +52,37 @@ program intest12 ! Open the input file. open ( unit = 21, file = 'testfiles/IN_12', form = 'unformatted', iostat = ios1 ) - if ( ios1 .ne. 0 ) stop 1 + if ( ios1 /= 0 ) stop 1 call openbf ( 21, 'IN', 21 ) ! Subroutine readmg will automatically read past the DX table messages at the front of the file. However, ! we also want to read past the 2 dummy messages at the start of the file which contain the dump center and ! initiation times, in order to get to the first message containing actual data subsets. do ii = 1, 3 - if ( ireadmg ( 21, cmgtag, idate ) .ne. 0 ) stop 2 + if ( ireadmg ( 21, cmgtag, idate ) /= 0 ) stop 2 enddo icnt = nmsub (21) - if ( icnt .ne. 215 ) stop 3 + if ( icnt /= 215 ) stop 3 ! Read through all of the subsets in the message. Increase the print verbosity for the last subset to ! check some errwrt branches. do ii = 1, icnt errstr_len = 0 - if ( ii .eq. icnt ) call openbf ( 21, 'QUIET', 2 ) - if ( ireadsb ( 21 ) .ne. 0 ) stop 4 - if ( ii .eq. icnt ) then + if ( ii == icnt ) call openbf ( 21, 'QUIET', 2 ) + if ( ireadsb ( 21 ) /= 0 ) stop 4 + if ( ii == icnt ) then call openbf ( 21, 'QUIET', 0 ) - if ( ( index( errstr(1:errstr_len), ':INVN:NBMP:TAG(INODE(LUN)) = 1: 66: 431:NC021206' ) .eq. 0 ) .or. & - ( index( errstr(1:errstr_len), ':NEWN:NBMP:NVAL(LUN) = (CRCHNM) : 3: 431' ) .eq. 0 ) ) stop 5 + if ( ( index( errstr(1:errstr_len), ':INVN:NBMP:TAG(INODE(LUN)) = 1: 66: 431:NC021206' ) == 0 ) .or. & + ( index( errstr(1:errstr_len), ':NEWN:NBMP:NVAL(LUN) = (CRCHNM) : 3: 431' ) == 0 ) ) stop 5 endif enddo ! Try to read the first subset of the next message, which should trigger a different errwrt branch. errstr_len = 0 - if ( ireadmg ( 21, cmgtag, idate ) .ne. 0 ) stop 6 + if ( ireadmg ( 21, cmgtag, idate ) /= 0 ) stop 6 call readsb ( 21, iret ) - if ( ( iret .ne. -1 ) .or. ( igetsc ( 21 ) .ne. 1 ) .or. & - ( index( errstr(1:errstr_len), 'USRTPL - REPLICATION FACTOR OVERFLOW' ) .eq. 0 ) ) stop 7 + if ( ( iret /= -1 ) .or. ( igetsc ( 21 ) /= 1 ) .or. & + ( index( errstr(1:errstr_len), 'USRTPL - REPLICATION FACTOR OVERFLOW' ) == 0 ) ) stop 7 deallocate ( errstr ) diff --git a/test/intest2.F90 b/test/intest2.F90 index c038fdc8..3ef2e045 100644 --- a/test/intest2.F90 +++ b/test/intest2.F90 @@ -28,38 +28,38 @@ program intest2 call openbf(11, 'IN', 12) ! Read the BUFR message from the BUFR file. - if (ireadmg(11, cmgtag, imgdt) .ne. 0 ) stop 1 + if (ireadmg(11, cmgtag, imgdt) /= 0 ) stop 1 ! Check some values from the message. - if (cmgtag .ne. 'NC005064' .or. imgdt .ne. 12101013) stop 2 - if (iupvs01(11,'MSBT') .ne. 64 .or. iupvs01(11,'OGCE') .ne. 7 .or. & - iupvs01(11,'LENM') .ne. 19926) stop 3 - if (nmsub(11) .ne. 154) stop 4 + if (cmgtag /= 'NC005064' .or. imgdt /= 12101013) stop 2 + if (iupvs01(11,'MSBT') /= 64 .or. iupvs01(11,'OGCE') /= 7 .or. & + iupvs01(11,'LENM') /= 19926) stop 3 + if (nmsub(11) /= 154) stop 4 ! Read the 5th data subset from the BUFR message. do ii = 1, 5 call readsb(11, ierrsb) end do - if (ierrsb .ne. 0) stop 5 + if (ierrsb /= 0) stop 5 ! Read some data values from the file and check them. call ufbint(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'CLAT SAZA PRLC WDIR RPID SIDP') - if (nr8lv .ne. 1 .or. nint(r8arr(1,1)*100) .ne. 1260 .or. & - nint(r8arr(2,1)*100) .ne. 2765 .or. nint(r8arr(3,1)) .ne. 25540 .or. & - nint(r8arr(4,1)) .ne. 218 .or. ibfms(r8arr(5,1)) .ne. 1) stop 6 + if (nr8lv /= 1 .or. nint(r8arr(1,1)*100) /= 1260 .or. & + nint(r8arr(2,1)*100) /= 2765 .or. nint(r8arr(3,1)) /= 25540 .or. & + nint(r8arr(4,1)) /= 218 .or. ibfms(r8arr(5,1)) /= 1) stop 6 ! Find and check the bit settings for SIDP. call upftbv(11, 'SIDP', r8arr(6,1), 32, ibit, nib) - if (nib .ne. 1 .or. ibit(1) .ne. 9) stop 7 + if (nib /= 1 .or. ibit(1) /= 9) stop 7 ! Read and check some values from the data subset currently open. call ufbrep(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'GNAP PCCF MAQC NCTH') - if (nr8lv .ne. 12 .or. nint(r8arr(1,2)) .ne. 2 .or. nint(r8arr(2,4)) .ne. 86 .or. & - nint(r8arr(2,6)) .ne. 0 .or. ibfms(r8arr(3,8)) .ne. 1 .or. & - ibfms(r8arr(4,9)) .ne. 1 .or. nint(r8arr(2,11)) .ne. 97 .or. & - nint(r8arr(1,12)) .ne. 3) stop 8 - if (nint(getvalnb(11,'NCTH',3,'PCCF',-1)) .ne. 0 .or. & - nint(getvalnb(11,'SSNX',1,'SWCM',1)) .ne. 1) stop 9 + if (nr8lv /= 12 .or. nint(r8arr(1,2)) /= 2 .or. nint(r8arr(2,4)) /= 86 .or. & + nint(r8arr(2,6)) /= 0 .or. ibfms(r8arr(3,8)) /= 1 .or. & + ibfms(r8arr(4,9)) /= 1 .or. nint(r8arr(2,11)) /= 97 .or. & + nint(r8arr(1,12)) /= 3) stop 8 + if (nint(getvalnb(11,'NCTH',3,'PCCF',-1)) /= 0 .or. & + nint(getvalnb(11,'SSNX',1,'SWCM',1)) /= 1) stop 9 print *, 'SUCCESS!' end program intest2 diff --git a/test/intest3.F90 b/test/intest3.F90 index a0799a5b..e335c2e4 100644 --- a/test/intest3.F90 +++ b/test/intest3.F90 @@ -33,28 +33,28 @@ program intest3 ! First, read some values from all of the data subsets. call ufbtab(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'CLAT CLON HSMSL {SHRVFFSQ}') - if (nr8lv .ne. 10 .or. nint(r8arr(1,1)*100) .ne. 4025 .or. nint(r8arr(3,1)) .ne. 88 .or. & - nint(r8arr(4,1)) .ne. 12 .or. nint(r8arr(2,2)*100) .ne. -8852 .or. & - nint(r8arr(4,2)) .ne. 20 .or. nint(r8arr(1,5)*100) .ne. 3352 .or. & - ibfms(r8arr(3,5)) .ne. 1 .or. nint(r8arr(1,8)*100) .ne. 3277 .or. & - nint(r8arr(1,9)*100) .ne. 3693 .or. nint(r8arr(2,9)*100) .ne. -9496 .or. & - nint(r8arr(3,9)) .ne. 228 .or. nint(r8arr(4,9)) .ne. 20) stop 1 + if (nr8lv /= 10 .or. nint(r8arr(1,1)*100) /= 4025 .or. nint(r8arr(3,1)) /= 88 .or. & + nint(r8arr(4,1)) /= 12 .or. nint(r8arr(2,2)*100) /= -8852 .or. & + nint(r8arr(4,2)) /= 20 .or. nint(r8arr(1,5)*100) /= 3352 .or. & + ibfms(r8arr(3,5)) /= 1 .or. nint(r8arr(1,8)*100) /= 3277 .or. & + nint(r8arr(1,9)*100) /= 3693 .or. nint(r8arr(2,9)*100) /= -9496 .or. & + nint(r8arr(3,9)) /= 228 .or. nint(r8arr(4,9)) /= 20) stop 1 call ufbtab(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'RPID') - if (nr8lv .ne. 10) stop 2 + if (nr8lv /= 10) stop 2 r8val = r8arr(1,1) - if (c8val(1:5) .ne. 'HARP1') stop 3 + if (c8val(1:5) /= 'HARP1') stop 3 r8val = r8arr(1,3) - if (c8val(1:5) .ne. 'IOLK1') stop 4 + if (c8val(1:5) /= 'IOLK1') stop 4 r8val = r8arr(1,8) - if (c8val(1:5) .ne. 'WLDA1') stop 5 + if (c8val(1:5) /= 'WLDA1') stop 5 r8val = r8arr(1,9) - if (c8val(1:5) .ne. 'COMO2') stop 6 + if (c8val(1:5) /= 'COMO2') stop 6 ! (Re)open the file for usual reading of each subset one at a time. call openbf ( 11, 'IN', 11 ) isct = 0 - do while (ireadns( 11, cmgtag, imgdt ) .eq. 0) + do while (ireadns( 11, cmgtag, imgdt ) == 0) ! Continue checking with the next subset. isct = isct + 1 @@ -65,95 +65,95 @@ program intest3 call ufbint ( 11, r8ardr, 1, mxr8lv, nr8rdr, '{SHRVDCSQ}' ) call ufbseq ( 11, r8ard, mxr8pm, mxr8lv, nr8rd, 'SHRVDCSQ' ) - if (isct .eq. 1) then + if (isct == 1) then call rtrcpt ( 11, ityr, itmo, itdy, ithr, itmi, ier ) - if ( ier .ne. -1 ) stop 11 - - 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 ) ) stop 12 - - 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 ) ) stop 13 - - 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 ) ) stop 14 - - else if ( isct .eq. 4 ) then + if ( ier /= -1 ) stop 11 + + if ( ( nr8rr /= 1 ) .or. ( nint(r8arr(2,1)) /= 2 ) .or. & + ( nint(r8arr(4,1)) /= 14 ) .or. ( nint(r8arr(5,1)) /= 3 ) ) stop 12 + + if ( ( nr8rf /= 12 ) .or. ( nint(r8arf(1,1)) /= 4 ) .or. ( nint(r8arf(2,1)) /= 2015 ) .or. & + ( nint(r8arf(3,1)) /= 2 ) .or. ( nint(r8arf(4,1)) /= 12 ) .or. ( nint(r8arf(5,1)) /= 18 ) & + .or. ( nint(r8arf(4,4)) /= 13 ) .or. ( nint(r8arf(5,4)) /= 12 ) .or. & + ( nint(r8arf(4,10)) /= 15 ) .or. ( nint(r8arf(5,10)) /= 0 ) .or. & + ( nint(r8arf(1,11)) /= 4 ) .or. ( nint(r8arf(4,11)) /= 15 ) .or. & + ( nint(r8arf(5,11)) /= 6 ) ) stop 13 + + if ( ( nr8rhr /= 12 ) .or. ( nint(r8arhr(1,1)) /= 1 ) .or. ( nint(r8arhr(1,2)) /= 1 ) .or. & + ( nint(r8arhr(1,3)) /= 1 ) .or. ( nint(r8arhr(1,8)) /= 1 ) .or. ( nr8rh /= 12 ) .or. & + ( nint(r8arh(3,1)*1000) /= 1402 ) .or. ( nint(r8arh(5,1)) /= 26 ) .or. ( nint(r8arh(3,2)*1000) /= 1372 ) .or. & + ( nint(r8arh(1,8)) /= 0 ) .or. ( nint(r8arh(2,8)) /= 0 ) .or. ( nr8rdr /= 12 ) .or. & + ( nint(r8ardr(1,1)) /= 0 ) .or. ( nint(r8ardr(1,2)) /= 1 ) .or. ( nint(r8ardr(1,4)) /= 0 ) .or. & + ( nint(r8ardr(1,6)) /= 1 ) .or. ( nint(r8ardr(1,9)) /= 0 ) .or. ( nint(r8ardr(1,10)) /= 1 ) .or. & + ( nr8rd /= 3 ) .or. ( nint(r8ard(3,1)*100) /= 33980 ) .or. ( nint(r8ard(3,2)*100) /= 33131 ) .or. & + ( nint(r8ard(5,2)) /= 26 ) .or. ( nint(r8ard(1,3)) /= 0 ) .or. ( nint(r8ard(2,3)) /= 1 ) .or. & + ( nint(r8ard(3,3)*100) /= 32564 ) ) stop 14 + + else if ( isct == 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 ) ) stop 41 - - 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 ) ) stop 42 - - else if ( isct .eq. 6 ) then - if ( ifbget ( 11 ) .ne. 0 ) stop 61 - - if ( lcmgdf ( 11, cmgtag ) .ne. 0 ) stop 62 - - 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 ) ) stop 63 - - 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 ) ) stop 64 - - 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 ) ) stop 71 - - else if ( isct .eq. 10 ) then - if ( ifbget ( 11 ) .eq. 0 ) stop 101 + if ( ( ier /= 0 ) .or. ( ityr /= 2014 ) .or. ( itmo /= 10 ) .or. ( itdy /= 5 ) .or. & + ( ithr /= 12 ) .or. ( itmi /= 52 ) ) stop 41 + + if ( ( nr8rhr /= 20 ) .or. ( NINT(r8arhr(1,1)) /= 2 ) .or. ( NINT(r8arhr(1,2)) /= 2 ) .or. & + ( nint(r8arhr(1,12)) /= 2 ) .or. ( nint(r8arhr(1,19)) /= 2 ) .or. ( nr8rh /= 40 ) .or. & + ( nint(r8arh(1,1)) /= 0 ) .or. ( nint(r8arh(3,1)*1000) /= 2286 ) .or. ( nint(r8arh(1,2)) /= 2 ) .or. & + ( nint(r8arh(3,2)*1000) /= 2286 ) .or. ( nint(r8arh(1,3)) /= 0 ) .or. ( nint(r8arh(3,3)*1000) /= 2256 ) .or. & + ( nint(r8arh(1,4)) /= 2 ) .or. ( nint(r8arh(3,4)*1000) /= 2256 ) .or. ( nint(r8arh(1,37)) /= 0 ) .or. & + ( nint(r8arh(3,37)*1000) /= 2225 ) .or. ( nint(r8arh(1,38)) /= 2 ) .or. ( nint(r8arh(3,38)*1000) /= 2225 ) .or. & + ( nr8rdr /= 20 ) .or. ( nint(r8ardr(1,4)) /= 0 ) .or. ( nint(r8ardr(1,6)) /= 0 ) .or. & + ( nint(r8ardr(1,9)) /= 0 ) .or. & + ( nint(r8ardr(1,10)) /= 0 ) .or. ( nint(r8ardr(1,18)) /= 0 ) .or. ( nr8rd /= 0 ) ) stop 42 + + else if ( isct == 6 ) then + if ( ifbget ( 11 ) /= 0 ) stop 61 + + if ( lcmgdf ( 11, cmgtag ) /= 0 ) stop 62 + + if ( ( nr8rr /= 1 ) .or. ( nint(r8arr(2,1)) /= 10 ) .or. ( nint(r8arr(4,1)) /= 12 ) .or. & + ( nint(r8arr(5,1)) /= 49 ) ) stop 63 + + if ( ( nr8rf /= 20 ) .or. ( nint(r8arf(1,1)) /= 4 ) .or. ( nint(r8arf(2,1)) /= 2014 ) .or. & + ( nint(r8arf(3,1)) /= 10 ) .or. & + ( nint(r8arf(4,1)) /= 5 ) .or. ( nint(r8arf(5,1)) /= 18 ) .or. & + ( nint(r8arf(4,3)) /= 6 ) .or. ( nint(r8arf(5,3)) /= 6 ) .or. & + ( nint(r8arf(4,9)) /= 7 ) .or. ( nint(r8arf(5,9)) /= 18 ) .or. & + ( nint(r8arf(1,16)) /= 4 ) .or. ( nint(r8arf(4,16)) /= 9 ) .or. & + ( nint(r8arf(5,16)) /= 12 ) .or. ( nint(r8arf(4,18)) /= 10 ) .or. & + ( nint(r8arf(5,18)) /= 0 ) ) stop 64 + + else if ( isct == 7 ) then + if ( ( nr8rhr /= 20 ) .or. ( nint(r8arhr(1,1)) /= 0 ) .or. & + ( nint(r8arhr(1,5)) /= 0 ) .or. ( nint(r8arhr(1,13)) /= 0 ) .or. & + ( nint(r8arhr(1,18)) /= 0 ) .or. ( nr8rh /= 0 ) .or. & + ( nr8rdr /= 20 ) .or. ( nint(r8ardr(1,1)) /= 1 ) .or. & + ( nint(r8ardr(1,2)) /= 1 ) .or. ( nint(r8ardr(1,11)) /= 1 ) .or. & + ( nint(r8ardr(1,12)) /= 1 ) .or. ( nint(r8ardr(1,13)) /= 1 ) .or. & + ( nint(r8ardr(1,15)) /= 1 ) .or. ( nr8rd /= 20 ) .or. & + ( nint(r8ard(3,1)*100) /= 10421 ) .or. ( nint(r8ard(3,4)*100) /= 8976 ) .or. & + ( nint(r8ard(3,11)*100) /= 5069 ) .or. ( nint(r8ard(3,12)*100) /= 4616 ) .or. & + ( nint(r8ard(1,13)) /= 0 ) .or. ( nint(r8ard(2,13)) /= 0 ) .or. & + ( nint(r8ard(3,13)*100) /= 4163 ) .or. ( nint(r8ard(4,13)) /= 1 ) .or. & + ( nint(r8ard(5,13)) /= 26 ) .or. ( nint(r8ard(3,15)*100) /= 3766 ) ) stop 71 + + else if ( isct == 10 ) then + if ( ifbget ( 11 ) == 0 ) stop 101 endif enddo ! Verify that all available subsets were successfully read. - if ( isct .ne. 10 ) stop 112 + if ( isct /= 10 ) stop 112 ! Check some mnemonic definitions. call nemdefs ( 11, 'HSMSL', celem, cunit, ier ) - if ( ( ier .ne. 0 ) .or. ( celem(1:36) .ne. 'HEIGHT OF STATION GROUND ABOVE MSL ' ) .or. & - ( cunit(1:9) .ne. 'METERS ' ) ) stop 113 + if ( ( ier /= 0 ) .or. ( celem(1:36) /= 'HEIGHT OF STATION GROUND ABOVE MSL ' ) .or. & + ( cunit(1:9) /= 'METERS ' ) ) stop 113 call nemdefs ( 11, 'SHRV', celem, cunit, ier ) - if ( ( ier .ne. 0 ) .or. ( celem(1:24) .ne. 'SHEF DATA REVISION FLAG ' ) .or. & - ( cunit(1:12) .ne. 'CODE TABLE ' ) ) stop 114 + if ( ( ier /= 0 ) .or. ( celem(1:24) /= 'SHEF DATA REVISION FLAG ' ) .or. & + ( cunit(1:12) /= 'CODE TABLE ' ) ) stop 114 call nemdefs ( 11, 'DCHG', celem, cunit, ier ) - if ( ( ier .ne. 0 ) .or. ( celem(1:15) .ne. 'DISCHARGE ' ) .or. & - ( cunit(1:20) .ne. 'METERS**3/SECOND ' ) ) stop 115 + if ( ( ier /= 0 ) .or. ( celem(1:15) /= 'DISCHARGE ' ) .or. & + ( cunit(1:20) /= 'METERS**3/SECOND ' ) ) stop 115 print *, 'SUCCESS!' end program intest3 diff --git a/test/intest4.F90 b/test/intest4.F90 index bcb3b471..9686e2b1 100644 --- a/test/intest4.F90 +++ b/test/intest4.F90 @@ -53,62 +53,62 @@ program intest4 open(unit = 11, file = '/dev/null') call openbf(11, 'SEC3', 11) - ! Specify location of master BUFR tables on local file system. + ! Specify location of master BUFR tables on local file system. call mtinfo('../tables', 90, 91) ! Read the BUFR message from the BUFR file. call crbmg_c(bfmg, mxbf, nbyt, ierr) - if (ierr .ne. 0) stop 1 + if (ierr /= 0) stop 1 ! Check some values in Section 1 of the message. - if (iupbs01(ibfmg, 'MTYP') .ne. 5 .or. iupbs01(ibfmg, 'MTV' ) .ne. 12 & - .or. iupbs01(ibfmg, 'LENM') .ne. 3588) stop 2 + if (iupbs01(ibfmg, 'MTYP') /= 5 .or. iupbs01(ibfmg, 'MTV' ) /= 12 & + .or. iupbs01(ibfmg, 'LENM') /= 3588) stop 2 ! Check some values in Section 3 of the message. - if (iupbs3(ibfmg, 'NSUB') .ne. 31 .or. iupbs3(ibfmg, 'ICMP') .ne. 1) stop 3 + if (iupbs3(ibfmg, 'NSUB') /= 31 .or. iupbs3(ibfmg, 'ICMP') /= 1) stop 3 call upds3(ibfmg, mxds3, cds3, nds3) - if (nds3 .ne. 51 .or. cds3(1) .ne. '310023' .or. cds3(5) .ne. '031031' .or. & - cds3(32) .ne. '237000' .or. cds3(44) .ne. '224255') stop 4 + if (nds3 /= 51 .or. cds3(1) /= '310023' .or. cds3(5) /= '031031' .or. & + cds3(32) /= '237000' .or. cds3(44) /= '224255') stop 4 ! Pass the message into the library so that Section 4 data can be read. call readerme(ibfmg, 11, cmgtag, imgdt, ier) - if (ier .ne. 0 .or. cmgtag .ne. 'MSTTB001' .or. imgdt .ne. 2016041815 ) stop 5 + if (ier /= 0 .or. cmgtag /= 'MSTTB001' .or. imgdt /= 2016041815 ) stop 5 ! Read a data subset from the BUFR message. - if (ireadsb(11) .ne. 0) stop 6 - + if (ireadsb(11) /= 0) stop 6 + ! Check some data values in the data subset. call ufbint(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'CLONH SAID SAZA HITE') - if (nr8lv .ne. 1 .or. nint(r8arr(1,1)*100000) .ne. -4246453 .or. & - nint(r8arr(2,1)) .ne. 57 .or. nint(r8arr(3,1)*100) .ne. 5407 .or. & - ibfms(r8arr(4,1)) .ne. 1) stop 7 + if (nr8lv /= 1 .or. nint(r8arr(1,1)*100000) /= -4246453 .or. & + nint(r8arr(2,1)) /= 57 .or. nint(r8arr(3,1)*100) /= 5407 .or. & + ibfms(r8arr(4,1)) /= 1) stop 7 call ufbrep(11, r8arr, mxr8pm, mxr8lv, nr8lv, 'PCCF') - if ( nr8lv .ne. 180 .or. nint(r8arr(1,12)) .ne. 86 .or. nint(r8arr(1,15)) .ne. 38 .or. & - nint(r8arr(1,102)) .ne. 88 .or. nint(r8arr(1,141)) .ne. 10 ) stop 8 + if ( nr8lv /= 180 .or. nint(r8arr(1,12)) /= 86 .or. nint(r8arr(1,15)) /= 38 .or. & + nint(r8arr(1,102)) /= 88 .or. nint(r8arr(1,141)) /= 10 ) stop 8 call ufbrep(11, r8arr, mxr8pm, mxr8lv, nr8lv, '224255') - if ( nr8lv .ne. 72 .or. nint(r8arr(1,12)*10) .ne. 6 .or. nint(r8arr(1,33)*10) .ne. 4) stop 9 + if ( nr8lv /= 72 .or. nint(r8arr(1,12)*10) /= 6 .or. nint(r8arr(1,33)*10) /= 4) stop 9 ! Check some bitmap and marker operator references in the data subset. call gettagre(11, 'PCCF', 57, tag, ntag, ier) - if ( ier .ne. 0 .or. ntag .ne. 7 .or. tag .ne. 'TMBRST ' ) stop 10 + if ( ier /= 0 .or. ntag /= 7 .or. tag /= 'TMBRST ' ) stop 10 call gettagre(11, 'PCCF', 154, tag, ntag, ier) - if ( ier .ne. 0 .or. ntag .ne. 4 .or. tag .ne. 'SPRD ' ) stop 11 + if ( ier /= 0 .or. ntag /= 4 .or. tag /= 'SPRD ' ) stop 11 call gettagre(11, '224255', 65, tag, ntag, ier) - if ( ier .ne. 0 .or. ntag .ne. 10 .or. tag .ne. 'RDNE ' ) stop 12 + if ( ier /= 0 .or. ntag /= 10 .or. tag /= 'RDNE ' ) stop 12 ! Check the output from lmsg, nmwrd, ipkm, and iupm. do ii = 1, 8 sec0(ii:ii) = bfmg(ii) end do - if ( lmsg(sec0) .ne. 898 ) stop 13 - if ( nmwrd(ibfmg) .ne. 898 ) stop 14 + if ( lmsg(sec0) /= 898 ) stop 13 + if ( nmwrd(ibfmg) /= 898 ) stop 14 call ipkm(cbay,3,3588) do ii = 1, 3 - if ( cbay(ii:ii) .ne. sec0(ii+4:ii+4) ) stop 15 + if ( cbay(ii:ii) /= sec0(ii+4:ii+4) ) stop 15 end do - if ( iupm(cbay(1:3),24) .ne. 3588 ) stop 16 + if ( iupm(cbay(1:3),24) /= 3588 ) stop 16 ! Close the test file. call ccbfl_c() diff --git a/test/intest5.F90 b/test/intest5.F90 index 46b434e0..38eb6a60 100644 --- a/test/intest5.F90 +++ b/test/intest5.F90 @@ -35,40 +35,40 @@ program intest5 ! Read a data subset. call readns ( 11, cmgtag, imgdt, ier ) - if ( ier .ne. 0 ) stop 1 + if ( ier /= 0 ) stop 1 ! Read and verify some 1-dimensional values from this data subset. call ufbget ( 11, r81dvals, mxr8pm, nlv, 'XOB YOB DHR ELV T29 {PRSLEVEL}' ) - if ( ( nlv .ne. 0 ) .or. ( nint(r81dvals(1)*100) .ne. 12223 ) .or. ( nint(r81dvals(2)*100) .ne. -1795 ) .or. & - ( nint(r81dvals(3)) .ne. -1 ) .or. ( nint(r81dvals(4)) .ne. 9 ) .or. ( nint(r81dvals(5)) .ne. 11 ) .or. & - ( nint(r81dvals(6)) .ne. 44 ) ) stop 2 + if ( ( nlv /= 0 ) .or. ( nint(r81dvals(1)*100) /= 12223 ) .or. ( nint(r81dvals(2)*100) /= -1795 ) .or. & + ( nint(r81dvals(3)) /= -1 ) .or. ( nint(r81dvals(4)) /= 9 ) .or. ( nint(r81dvals(5)) /= 11 ) .or. & + ( nint(r81dvals(6)) /= 44 ) ) stop 2 ! Retrieve and check some code/flag meaning strings. call getcfmng ( 11, 'PRC', 106, ' ', -1, cmeang, lcmg, ier ) - if ( ( ier .ne. 1 ) .or. ( lcmg .ne. 8 ) .or. ( cmeang(1:lcmg) .ne. 'PPC ' ) ) stop 3 + if ( ( ier /= 1 ) .or. ( lcmg /= 8 ) .or. ( cmeang(1:lcmg) /= 'PPC ' ) ) stop 3 call getcfmng ( 11, 'PRC', 106, 'PPC', 5, cmeang, lcmg, ier ) - if ( ( ier .ne. 0 ) .or. ( lcmg .ne. 34 ) .or. & - ( cmeang(1:lcmg) .ne. 'Surface pressure observation error' ) ) stop 4 + if ( ( ier /= 0 ) .or. ( lcmg /= 34 ) .or. & + ( cmeang(1:lcmg) /= 'Surface pressure observation error' ) ) stop 4 call getcfmng ( 11, 'GSES', 10, ' ', -1, cmeang, lcmg, ier ) - if ( ( ier .ne. 3 ) .or. ( lcmg .ne. 24 ) .or. ( cmeang(1:lcmg) .ne. 'GCLONG OGCE ORIGC ' ) ) stop 5 + if ( ( ier /= 3 ) .or. ( lcmg /= 24 ) .or. ( cmeang(1:lcmg) /= 'GCLONG OGCE ORIGC ' ) ) stop 5 call getcfmng ( 11, 'GSES', 10, 'GCLONG', 173, cmeang, lcmg, ier ) - if ( ( ier .ne. 0 ) .or. ( lcmg .ne. 20 ) .or. ( cmeang(1:lcmg) .ne. 'Stennis Space Center' ) ) stop 6 + if ( ( ier /= 0 ) .or. ( lcmg /= 20 ) .or. ( cmeang(1:lcmg) /= 'Stennis Space Center' ) ) stop 6 call getcfmng ( 11, 'GCLONG', 10, ' ', -1, cmeang, lcmg, ier ) - if ( ( ier .ne. 0 ) .or. ( lcmg .ne. 12 ) .or. (cmeang(1:lcmg) .ne. 'Cairo (RSMC)') ) stop 7 + if ( ( ier /= 0 ) .or. ( lcmg /= 12 ) .or. (cmeang(1:lcmg) /= 'Cairo (RSMC)') ) stop 7 call getcfmng ( 11, 'OGCE', 241, ' ', -1, cmeang, lcmg, ier ) - if ( ( ier .ne. 0 ) .or. ( lcmg .ne. 6 ) .or. (cmeang(1:lcmg) .ne. 'Monaco') ) stop 8 + if ( ( ier /= 0 ) .or. ( lcmg /= 6 ) .or. (cmeang(1:lcmg) /= 'Monaco') ) stop 8 call getcfmng ( 11, 'TABLASS', 0, ' ', -1, cmeang, lcmg, ier ) - if ( ( ier .ne. 1 ) .or. ( lcmg .ne. 8 ) .or. (cmeang(1:lcmg) .ne. 'TABLAT ') ) stop 9 + if ( ( ier /= 1 ) .or. ( lcmg /= 8 ) .or. (cmeang(1:lcmg) /= 'TABLAT ') ) stop 9 ! For these two cases, cmeang_short will not get updated, so no check on the value. call getcfmng ( 11, 'TABLASS', 0, ' ', -1, cmeang_short, lcmg, ier ) - if ( ( ier .ne. -1 ) .or. ( lcmg .ne. 5 ) ) stop 10 + if ( ( ier /= -1 ) .or. ( lcmg /= 5 ) ) stop 10 call getcfmng ( 11, 'GSES', 0, 'DUMMY', -1, cmeang_short, lcmg, ier ) - if ( ( ier .ne. -1 ) .or. ( lcmg .ne. 5 ) ) stop 11 + if ( ( ier /= -1 ) .or. ( lcmg /= 5 ) ) stop 11 ! Read and verify some values from the 2nd data subset of the 2nd message. call ufbinx ( 11, 2, 2, r8vals, mxr8pm, mxr8lv, nlv, 'CLAM CLTP' ) - if ( ( nlv .ne. 3 ) .or. ( nint(r8vals(1,1)) .ne. 7 ) .or. ( nint(r8vals(2,1)) .ne. 38 ) .or. & - ( nint(r8vals(2,2)) .ne. 61 ) .or. ( nint(r8vals(2,3)) .ne. 60 ) ) stop 12 + if ( ( nlv /= 3 ) .or. ( nint(r8vals(1,1)) /= 7 ) .or. ( nint(r8vals(2,1)) /= 38 ) .or. & + ( nint(r8vals(2,2)) /= 61 ) .or. ( nint(r8vals(2,3)) /= 60 ) ) stop 12 ! Free the memory that was dynamically allocated when reading the code and flag tables. call dlloctbf_c() @@ -77,8 +77,8 @@ program intest5 ! Test ufbinx's openbf/closbf calls. open ( unit = 12, file = 'testfiles/IN_5', form ='unformatted') call ufbinx ( 12, 2, 2, r8vals, mxr8pm, mxr8lv, nlv, 'CLAM CLTP' ) - if ( ( nlv .ne. 3 ) .or. ( nint(r8vals(1,1)) .ne. 7 ) .or. ( nint(r8vals(2,1)) .ne. 38 ) .or. & - ( nint(r8vals(2,2)) .ne. 61 ) .or. ( nint(r8vals(2,3)) .ne. 60 ) ) stop 13 + if ( ( nlv /= 3 ) .or. ( nint(r8vals(1,1)) /= 7 ) .or. ( nint(r8vals(2,1)) /= 38 ) .or. & + ( nint(r8vals(2,2)) /= 61 ) .or. ( nint(r8vals(2,3)) /= 60 ) ) stop 13 print *, 'SUCCESS!' end program intest5 diff --git a/test/intest6.F90 b/test/intest6.F90 index e7bbd20e..187cc987 100644 --- a/test/intest6.F90 +++ b/test/intest6.F90 @@ -35,7 +35,7 @@ program intest6 use Share_errstr_intest6 implicit none - + integer*4 nmsub integer iyr, imon, iday, ihour, imgdt, ier, icnt, iunt, nsub @@ -63,47 +63,47 @@ program intest6 ! Verify the Section 1 date-time in the first data message of one of the input files. call datebf ( 22, iyr, imon, iday, ihour, imgdt ) - if ( ( imgdt .ne. 21031900 ) .or. ( iyr .ne. 21 ) .or. ( iday .ne. 19 ) ) stop 1 + if ( ( imgdt /= 21031900 ) .or. ( iyr /= 21 ) .or. ( iday /= 19 ) ) stop 1 ! Rewind that input file. rewind ( 22 ) ! Open both input files and read the contents into internal arrays. call ufbmem ( 21, 0, icnt, iunt ) - if ( ( icnt .ne. 926 ) .or. ( iunt .ne. 21 ) ) stop 2 + if ( ( icnt /= 926 ) .or. ( iunt /= 21 ) ) stop 2 call ufbmem ( 22, 1, icnt, iunt ) - if ( ( icnt .ne. 344 ) .or. ( iunt .ne. 21 ) ) stop 3 + if ( ( icnt /= 344 ) .or. ( iunt /= 21 ) ) stop 3 ! Locate message #167 within the internal arrays and verify some values. call rdmemm ( 167, cmgtag, imgdt, ier ) - if ( ( cmgtag .ne. 'NC004002' ) .or. ( imgdt .ne. 21031713 ) .or. ( nmsub(iunt) .ne. 3 ) ) stop 4 + if ( ( cmgtag /= 'NC004002' ) .or. ( imgdt /= 21031713 ) .or. ( nmsub(iunt) /= 3 ) ) stop 4 ! Locate subset #18364 within the internal arrays and verify some values. ! Also check an errwrt case while doing this. call openbf ( 21, 'QUIET', 2 ) errstr_len = 0 call ufbmns ( 18364, cmgtag, imgdt ) - if ( ( cmgtag .ne. 'NC002003' ) .or. ( imgdt .ne. 21031900 ) .or. ( nmsub(iunt) .ne. 2 ) ) stop 5 - if ( ( index( errstr(1:errstr_len), 'RDMEMM - RESETTING TO USE DX TABLE #' ) .eq. 0 ) ) stop 6 + if ( ( cmgtag /= 'NC002003' ) .or. ( imgdt /= 21031900 ) .or. ( nmsub(iunt) /= 2 ) ) stop 5 + if ( ( index( errstr(1:errstr_len), 'RDMEMM - RESETTING TO USE DX TABLE #' ) == 0 ) ) stop 6 call openbf ( 21, 'QUIET', 0 ) ! Scan for certain values across all of the data subsets in the internal arrays, and verify some of them. call ufbtam ( r8vals, mxr8pm, mxr8lv, nsub, 'CLAT CLON' ) - if ( ( nsub .ne. 18447 ) .or. & - ( nint(r8vals(1,1285)*100) .ne. 4328 ) .or. ( nint(r8vals(2,1285)*100) .ne. -7910 ) .or. & - ( nint(r8vals(1,5189)*100) .ne. 3918 ) .or. ( nint(r8vals(2,5189)*100) .ne. 11638 ) .or. & - ( nint(r8vals(1,17961)*100) .ne. 3070 ) .or. ( nint(r8vals(2,17961)*100) .ne. 10383 ) ) stop 7 + if ( ( nsub /= 18447 ) .or. & + ( nint(r8vals(1,1285)*100) /= 4328 ) .or. ( nint(r8vals(2,1285)*100) /= -7910 ) .or. & + ( nint(r8vals(1,5189)*100) /= 3918 ) .or. ( nint(r8vals(2,5189)*100) /= 11638 ) .or. & + ( nint(r8vals(1,17961)*100) /= 3070 ) .or. ( nint(r8vals(2,17961)*100) /= 10383 ) ) stop 7 call ufbtam ( r8vals, mxr8pm, mxr8lv, nsub, 'BUHD' ) - if ( nsub .ne. 18447 ) stop 8 + if ( nsub /= 18447 ) stop 8 r8val = r8vals(1, 6314) - if (c8val(1:6) .ne. 'IUAD01') stop 9 + if (c8val(1:6) /= 'IUAD01') stop 9 r8val = r8vals(1, 17888) - if (c8val(1:6) .ne. 'IUSN08') stop 10 + if (c8val(1:6) /= 'IUSN08') stop 10 ! Test an errwrt case in ufbtam. errstr_len = 0 call ufbtam ( r8vals, mxr8pm, 1000, nsub, 'BUHD' ) - if ( ( index( errstr(1:errstr_len), 'UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY IS .GT. LIMIT' ) .eq. 0 ) ) stop 11 + if ( ( index( errstr(1:errstr_len), 'UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY IS .GT. LIMIT' ) == 0 ) ) stop 11 print *, 'SUCCESS!' end program intest6 diff --git a/test/intest7.F90 b/test/intest7.F90 index f5876797..19694d9a 100644 --- a/test/intest7.F90 +++ b/test/intest7.F90 @@ -59,11 +59,11 @@ program intest7 ! Check error messages in ISETPRM. iret = isetprm ( 'MXNRV', 5 ) - if ( iret .ne. 0 ) stop 1 + if ( iret /= 0 ) stop 1 errstr_len = 0 iret = isetprm ( 'DUMMY', 20 ) - if ( ( iret .ne. -1 ) .or. & - ( index( errstr(1:errstr_len), 'ISETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) .eq. 0 ) ) stop 2 + if ( ( iret /= -1 ) .or. & + ( index( errstr(1:errstr_len), 'ISETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) == 0 ) ) stop 2 ! Open the input file and DX table. open ( unit = 11, file = 'testfiles/IN_7', form ='unformatted') @@ -72,123 +72,123 @@ program intest7 call openbf ( 11, 'QUIET', 2 ) errstr_len = 0 call openbf ( 11, 'IN', 12 ) - if ( index( errstr(1:errstr_len), 'TABLE FROM USER-SUPPLIED TEXT FILE' ) .eq. 0 ) stop 3 + if ( index( errstr(1:errstr_len), 'TABLE FROM USER-SUPPLIED TEXT FILE' ) == 0 ) stop 3 call openbf ( 11, 'QUIET', 1 ) ! Check error messages in IGETPRM. iret = igetprm ( 'MXNRV' ) - if ( iret .ne. 5 ) stop 4 + if ( iret /= 5 ) stop 4 errstr_len = 0 iret = igetprm ( 'DUMMY' ) - if ( ( iret .ne. -1 ) .or. & - ( index( errstr(1:errstr_len), 'IGETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) .eq. 0 ) ) stop 5 + if ( ( iret /= -1 ) .or. & + ( index( errstr(1:errstr_len), 'IGETPRM - UNKNOWN INPUT PARAMETER DUMMY' ) == 0 ) ) stop 5 ! Read some data values from the 1st message, which uses the 2-03-YYY operator to change one of the ! reference values. - if ( ireadns ( 11, cmgtag, imgdt ) .ne. 0 ) stop 6 + if ( ireadns ( 11, cmgtag, imgdt ) /= 0 ) stop 6 call ufbrep ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'TIDER' ) - if ( ( nr8v .ne. 2 ) .or. & - ( nint ( r8arr(1,1) ) .ne. -10000 ) .or. ( nint ( r8arr(1,2) ) .ne. 16 ) ) stop 7 + if ( ( nr8v /= 2 ) .or. & + ( nint ( r8arr(1,1) ) /= -10000 ) .or. ( nint ( r8arr(1,2) ) /= 16 ) ) stop 7 errstr_len = 0 call ufbrep ( 11, r8val, 1, 1, nr8v, 'DUMMY' ) idx = index( errstr(1:errstr_len), 'UFBREP - NO SPECIFIED VALUES READ IN' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 8 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 8 errstr_len = 0 call ufbrep ( 11, r8val, 0, 1, nr8v, 'TIDER' ) idx = index( errstr(1:errstr_len), 'UFBREP - 3rd ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 9 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 9 errstr_len = 0 call ufbrep ( 11, r8val, 1, 0, nr8v, 'TIDER' ) idx = index( errstr(1:errstr_len), 'UFBREP - 4th ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 10 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 10 ! Jump ahead to the 5th subset of the 23rd message and read some data values. call ufbpos ( 11, 23, 5, cmgtag, jdate ) call ufbint ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'CLATH CLONH TMDB SWRAD' ) - if ( ( nr8v .ne. 1 ) .or. & - ( nint ( r8arr(1,1)*100000 ) .ne. 2001191 ) .or. ( nint ( r8arr(2,1)*100000 ) .ne. -3785017 ) .or. & - ( nint ( r8arr(3,1)*100 ) .ne. 30035 ) .or. ( nint ( r8arr(4,1) ) .ne. 2187000 ) ) stop 11 + if ( ( nr8v /= 1 ) .or. & + ( nint ( r8arr(1,1)*100000 ) /= 2001191 ) .or. ( nint ( r8arr(2,1)*100000 ) /= -3785017 ) .or. & + ( nint ( r8arr(3,1)*100 ) /= 30035 ) .or. ( nint ( r8arr(4,1) ) /= 2187000 ) ) stop 11 errstr_len = 0 call ufbint ( 11, r8val, 1, 1, nr8v, 'DUMMY' ) idx = index( errstr(1:errstr_len), 'UFBINT - NO SPECIFIED VALUES READ IN' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 12 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 12 errstr_len = 0 call ufbint ( 11, r8val, 0, 1, nr8v, 'TMDB' ) idx = index( errstr(1:errstr_len), 'UFBINT - 3rd ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 13 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 13 errstr_len = 0 call ufbint ( 11, r8val, 1, 0, nr8v, 'TMDB' ) idx = index( errstr(1:errstr_len), 'UFBINT - 4th ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 14 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 14 errstr_len = 0 call ufbseq ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'RPSEQ005' ) idx = index( errstr(1:errstr_len), 'UFBSEQ - INCOMPLETE READ; ONLY THE FIRST' ) - if ( ( nr8v .ne. 5 ) .or. ( idx .eq. 0 ) ) stop 15 + if ( ( nr8v /= 5 ) .or. ( idx == 0 ) ) stop 15 ! Jump ahead to the 2nd subset of the 30th message and read some data values. call ufbpos ( 11, 30, 2, cmgtag, jdate ) call ufbstp ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'CLAT CLON HSMSL' ) - if ( ( nr8v .ne. 1 ) .or. & - ( nint ( r8arr(1,1)*100 ) .ne. 3163 ) .or. ( nint ( r8arr(2,1)*100 ) .ne. -11017 ) .or. & - ( nint ( r8arr(3,1) ) .ne. 1205 ) ) stop 16 + if ( ( nr8v /= 1 ) .or. & + ( nint ( r8arr(1,1)*100 ) /= 3163 ) .or. ( nint ( r8arr(2,1)*100 ) /= -11017 ) .or. & + ( nint ( r8arr(3,1) ) /= 1205 ) ) stop 16 errstr_len = 0 call ufbstp ( 11, r8val, 1, 1, nr8v, 'DUMMY' ) idx = index( errstr(1:errstr_len), 'UFBSTP - NO SPECIFIED VALUES READ IN' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 17 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 17 errstr_len = 0 call ufbstp ( 11, r8val, 0, 1, nr8v, 'CLON' ) idx = index( errstr(1:errstr_len), 'UFBSTP - 3rd ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 18 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 18 errstr_len = 0 call ufbstp ( 11, r8val, 1, 0, nr8v, 'CLON' ) idx = index( errstr(1:errstr_len), 'UFBSTP - 4th ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 19 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 19 ! Jump backwards to the 88th subset of the 29th message and read some data values. call ufbpos ( 11, 29, 88, cmgtag, jdate ) call ufbseq ( 11, r8arr, mxr8pm, mxr8lv, nr8v, 'NC008023' ) - if ( ( nr8v .ne. 1 ) .or. & - ( nint ( r8arr(6,1)*100000 ) .ne. 2967000 ) .or. ( nint ( r8arr(7,1)*100000 ) .ne. -9512833 ) .or. & - ( nint ( r8arr(5,1) ) .ne. 482011039 ) ) stop 20 + if ( ( nr8v /= 1 ) .or. & + ( nint ( r8arr(6,1)*100000 ) /= 2967000 ) .or. ( nint ( r8arr(7,1)*100000 ) /= -9512833 ) .or. & + ( nint ( r8arr(5,1) ) /= 482011039 ) ) stop 20 errstr_len = 0 call ufbseq ( 11, r8val, 1, 1, nr8v, 'DUMMY' ) idx = index( errstr(1:errstr_len), 'UFBSEQ - NO SPECIFIED VALUES READ IN' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 21 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 21 errstr_len = 0 call ufbseq ( 11, r8val, 0, 1, nr8v, 'CLON' ) idx = index( errstr(1:errstr_len), 'UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 22 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 22 errstr_len = 0 call ufbseq ( 11, r8val, 1, 0, nr8v, 'CLON' ) idx = index( errstr(1:errstr_len), 'UFBSEQ - 4th ARG. (INPUT) IS .LE. 0' ) - if ( ( nr8v .ne. 0 ) .or. ( idx .eq. 0 ) ) stop 23 + if ( ( nr8v /= 0 ) .or. ( idx == 0 ) ) stop 23 ! Test ufbcnt. call ufbcnt(11, kmsg, ksub) - if ( kmsg.ne.29 .or. ksub.ne.88) stop 24 + if ( kmsg/=29 .or. ksub/=88) stop 24 ! Rewind the file and get a total count of the subsets. call ufbtab ( -11, r8val, 1, 1, nsub, ' ' ) - if ( ( nsub .ne. 402 ) .or. ( ibfms ( r8val(1,1) ) .ne. 1 ) ) stop 25 + if ( ( nsub /= 402 ) .or. ( ibfms ( r8val(1,1) ) /= 1 ) ) stop 25 ! Test datebf & dumpbf when Section 1 date cannot be found. errstr_len = 0 call datebf ( 12, iyr, imon, iday, ihour, imgdt ) idx = index(errstr(1:errstr_len), "DATEBF - SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH IDATE = -1") - if ( (imgdt .ne. -1) .or. (idx .eq. 0) ) stop 26 + if ( (imgdt /= -1) .or. (idx == 0) ) stop 26 errstr_len = 0 call dumpbf ( 12, jdatearr, jdumparr) idx = index(errstr(1:errstr_len), "DUMPBF - FIRST EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED") - if (idx .eq. 0) stop 27 + if (idx == 0) stop 27 idx = index(errstr(1:errstr_len), "DUMPBF - SECOND EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED") - if (idx .eq. 0) stop 28 - if (.not. (all(jdatearr .eq. -1) .and. all(jdumparr .eq. -1))) stop 29 + if (idx == 0) stop 28 + if (.not. (all(jdatearr == -1) .and. all(jdumparr == -1))) stop 29 ! Rewind the file and check an error message within UFBTAB. errstr_len = 0 call ufbtab ( 11, r8arr, mxr8pm, mxr8lv, nsub, 'CLATH' ) idx = index(errstr(1:errstr_len), "BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE IS .GT. LIMIT OF") - if ( (idx .eq. 0) .or. ( nsub .ne. 5 ) .or. ( r8arr(1,2)*100000 .ne. 5012537 ) ) stop 30 + if ( (idx == 0) .or. ( nsub /= 5 ) .or. ( r8arr(1,2)*100000 /= 5012537 ) ) stop 30 print *, 'SUCCESS!' end program intest7 diff --git a/test/intest8.F90 b/test/intest8.F90 index 4c9fdc50..6195d9b4 100644 --- a/test/intest8.F90 +++ b/test/intest8.F90 @@ -88,9 +88,9 @@ program intest8 if ( iqcd /= 14 ) stop 5 call ufbqcp ( 11, 2, mnem ) - if ( mnem(1:7) .ne. 'SYNDATA' ) stop 6 + if ( mnem(1:7) /= 'SYNDATA' ) stop 6 call ufbqcp ( 11, 8, mnem ) - if ( mnem(1:6) .ne. 'VIRTMP' ) stop 7 + if ( mnem(1:6) /= 'VIRTMP' ) stop 7 r8v = 224. call upftbv ( 11, 'RSRD', r8v, 6, ibit, nib ) @@ -102,13 +102,13 @@ program intest8 ! Test some errwrt cases in ufbevn errstr_len = 0 call ufbevn ( 11, r8vals, (-1)*mxr8pm, mxr8lv, mxr8en, ilv, 'QOB QQM QPC QRC' ) - if ( ( index( errstr(1:errstr_len), 'UFBEVN - 3rd ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 10 + if ( ( index( errstr(1:errstr_len), 'UFBEVN - 3rd ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 10 errstr_len = 0 call ufbevn ( 11, r8vals, mxr8pm, (-1)*mxr8lv, mxr8en, ilv, 'QOB QQM QPC QRC' ) - if ( ( index( errstr(1:errstr_len), 'UFBEVN - 4th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 11 + if ( ( index( errstr(1:errstr_len), 'UFBEVN - 4th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 11 errstr_len = 0 call ufbevn ( 11, r8vals, mxr8pm, mxr8lv, (-1)*mxr8en, ilv, 'QOB QQM QPC QRC' ) - if ( ( index( errstr(1:errstr_len), 'UFBEVN - 5th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 12 + if ( ( index( errstr(1:errstr_len), 'UFBEVN - 5th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 12 print *, 'SUCCESS!' end program intest8 diff --git a/test/intest9.F90 b/test/intest9.F90 index c255ee02..007c6b4f 100644 --- a/test/intest9.F90 +++ b/test/intest9.F90 @@ -71,7 +71,7 @@ program intest9 do ii = 1, 2 if ( ireadmg ( 11, cmgtag, imgdt ) /= 0 ) stop 3 end do - if ( cmgtag .ne. 'ADPUPA ' ) stop 4 + if ( cmgtag /= 'ADPUPA ' ) stop 4 if ( ireadsb (11) /= 0 ) stop 5 call ufbin3 ( 11, r8vals, mxr8pm, mxr8lv, mxr8en, iret, jret, 'POB QOB UOB CAPE VENT' ) if ( ( iret /= 49 ) .or. ( jret /= 1 ) .or. & @@ -82,7 +82,7 @@ program intest9 ! Now, read the 7th subset from the 4th message of the prepfits file, and check some wind ! values for levels where the pressure is between 800mb and 400mb. if ( ireadmg ( 11, cmgtag, imgdt ) /= 0 ) stop 7 - if ( cmgtag .ne. 'VADWND ' ) stop 8 + if ( cmgtag /= 'VADWND ' ) stop 8 do ii = 1, 7 if ( ireadsb (11) /= 0 ) stop 9 end do @@ -99,13 +99,13 @@ program intest9 ! Test some errwrt cases in ufbin3 errstr_len = 0 call ufbin3 ( 11, r8vals, (-1)*mxr8pm, mxr8lv, mxr8en, iret, jret, 'POB QOB UOB CAPE VENT' ) - if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 12 + if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 3rd ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 12 errstr_len = 0 call ufbin3 ( 11, r8vals, mxr8pm, (-1)*mxr8lv, mxr8en, iret, jret, 'POB QOB UOB CAPE VENT' ) - if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 4th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 13 + if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 4th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 13 errstr_len = 0 call ufbin3 ( 11, r8vals, mxr8pm, mxr8lv, (-1)*mxr8en, iret, jret, 'POB QOB UOB CAPE VENT' ) - if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 5th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 14 + if ( ( index( errstr(1:errstr_len), 'UFBIN3 - 5th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 14 print *, 'SUCCESS!' end program intest9 diff --git a/test/outtest1.F90 b/test/outtest1.F90 index 13cb4bfe..9c4e00e8 100644 --- a/test/outtest1.F90 +++ b/test/outtest1.F90 @@ -48,11 +48,11 @@ program outtest1 call openmb ( 11, 'FR004029', 2012031212 ) ! Confirm there's exactly one long character string in the subset definition. - if ( lcmgdf ( 11, 'FR004029' ) .ne. 1 ) stop 1 + if ( lcmgdf ( 11, 'FR004029' ) /= 1 ) stop 1 ! Get and check the parent of a Table B mnemonic. call gettagpr ( 11, 'MNTH', 1, tagpr, iertgp ) - if ( ( iertgp .ne. 0 ) .or. ( tagpr .ne. 'YYMMDD' ) ) stop 2 + if ( ( iertgp /= 0 ) .or. ( tagpr /= 'YYMMDD' ) ) stop 2 ! The output of the following calls will be checked below, after making additional calls to this same ! subroutine to verify reference values that will be modified with the 2-03 operator. @@ -98,11 +98,11 @@ program outtest1 do jj = 1, 5 call nemspecs ( 11, 'FLVLST', jj, nsc(jj), nrf(jj), nbt(jj), ierns(jj) ) end do - if ( ( iernsa .ne. 0 ) .or. ( iernsm .ne. 0 ) .or. ( nba .ne. 80 ) .or. ( nbm .ne. 17 ) .or. & - ( nsm .ne. 3 ) .or. ( ierns(1) .ne. 0 ) .or. ( nrf(1) .ne. -1024 ) .or. ( ierns(2) .ne. 0 ) .or. & - ( nrf(2) .ne. -1024 ) .or. ( nbt(2) .ne. 12 ) .or. ( ierns(3) .ne. 0 ) .or. ( nrf(3) .ne. -1000 ) & - .or. ( ierns(4) .ne. 0 ) .or. ( nrf(4) .ne. -1000 ) .or. ( ierns(5) .ne. 0 ) .or. & - ( nrf(5) .ne. -1024 ) .or. ( nbt(3) .ne. 16 ) .or. ( nbt(5) .ne. 16 ) ) stop 3 + if ( ( iernsa /= 0 ) .or. ( iernsm /= 0 ) .or. ( nba /= 80 ) .or. ( nbm /= 17 ) .or. & + ( nsm /= 3 ) .or. ( ierns(1) /= 0 ) .or. ( nrf(1) /= -1024 ) .or. ( ierns(2) /= 0 ) .or. & + ( nrf(2) /= -1024 ) .or. ( nbt(2) /= 12 ) .or. ( ierns(3) /= 0 ) .or. ( nrf(3) /= -1000 ) & + .or. ( ierns(4) /= 0 ) .or. ( nrf(4) /= -1000 ) .or. ( ierns(5) /= 0 ) .or. & + ( nrf(5) /= -1024 ) .or. ( nbt(3) /= 16 ) .or. ( nbt(5) /= 16 ) ) stop 3 ! Write a long character string into the output. acrn = 'TESTUPS008' @@ -170,12 +170,12 @@ program outtest1 ! Note that with ufbtab we can only look at the first 8 characters of each value. open ( unit = 11, file = 'out1.bufr', form ='unformatted') call ufbtab ( 11, r8acrn, 1, 3, nlv, 'ACRN') - if (nlv .ne. 3 ) stop 4 + if (nlv /= 3 ) stop 4 r8val = r8acrn(1,1) - if (c8val .ne. 'TESTUPS0') stop 5 + if (c8val /= 'TESTUPS0') stop 5 r8val = r8acrn(1,2) - if (c8val .ne. 'TESTAAL2') stop 6 + if (c8val /= 'TESTAAL2') stop 6 r8val = r8acrn(1,3) - if (c8val .ne. 'TESTSWA1') stop 7 + if (c8val /= 'TESTSWA1') stop 7 end program outtest1 diff --git a/test/outtest10.F90 b/test/outtest10.F90 index d42a0562..ba9aebff 100644 --- a/test/outtest10.F90 +++ b/test/outtest10.F90 @@ -54,19 +54,19 @@ program outtest10 open ( unit = 22, file = 'testfiles/OUT_10_infile2', iostat = iostat2 ) open ( unit = 23, file = 'testfiles/OUT_10_bufrtab', iostat = iostat3 ) open ( unit = 50, file = 'out10.bufr', form = 'unformatted', iostat = iostat4 ) - if ( ( iostat1 .ne. 0 ) .or. ( iostat2 .ne. 0 ) .or. ( iostat3 .ne. 0 ) .or. ( iostat4 .ne. 0 ) ) stop 1 + if ( ( iostat1 /= 0 ) .or. ( iostat2 /= 0 ) .or. ( iostat3 /= 0 ) .or. ( iostat4 /= 0 ) ) stop 1 ! Set an arbitrarily low maximum value for a global parameter. - if ( isetprm ( 'MXH4WLC', 1 ) .ne. 0 ) stop 2 + if ( isetprm ( 'MXH4WLC', 1 ) /= 0 ) stop 2 ! Get some information from infile1. call mesgbc ( 21, mesgtyp, icomp ) - if ( ( mesgtyp .ne. -11 ) .or. ( icomp .ne. -2 ) ) stop 3 + if ( ( mesgtyp /= -11 ) .or. ( icomp /= -2 ) ) stop 3 ! (Re)open infile1 since the call to mesgbc will have closed it. rewind ( 21 ) open ( unit = 21, file = 'testfiles/OUT_10_infile1', iostat = iostat1 ) - if ( iostat1 .ne. 0 ) stop 4 + if ( iostat1 /= 0 ) stop 4 ! Open infile2 and the output file to the library. call openbf ( 21, 'IN', 21 ) @@ -82,20 +82,20 @@ program outtest10 ! logic in cpyupd, and the last 5 will exercise logic in msgupd. The copy of subset 8 should fail because ! it is larger than the 120000 byte message limit that was passed into maxout. mgct = 0 - do while ( ireadmg ( 22, subset, jdate ) .eq. 0 ) + do while ( ireadmg ( 22, subset, jdate ) == 0 ) mgct = mgct + 1 errstr_len = 0 call openmb ( 50, subset, jdate ) - if ( mgct .le. 3 ) then + if ( mgct <= 3 ) then call copysb ( 22, 50, iret ) - if ( iret .ne. 0 ) stop 5 - if ( ( mod(mgct,2) .eq. 1 ) .and. & - index( errstr(1:errstr_len), 'CPYUPD - SUBSET HAS BYTE COUNT =' ) .eq. 0 ) stop 6 + if ( iret /= 0 ) stop 5 + if ( ( mod(mgct,2) == 1 ) .and. & + index( errstr(1:errstr_len), 'CPYUPD - SUBSET HAS BYTE COUNT =' ) == 0 ) stop 6 else call readsb ( 22, iret ) - if ( iret .ne. 0 ) stop 7 + if ( iret /= 0 ) stop 7 call ufbcpy ( 22, 50 ) - if ( mgct .eq. 4 ) then + if ( mgct == 4 ) then ! Store a long character string. wgoslid = 'OUTTEST10 DUMMY1' call hold4wlc ( 50, wgoslid, 'WGOSLID' ) @@ -106,13 +106,13 @@ program outtest10 ! was set to a value of 1. softv = 'X.Y.Z ' call hold4wlc ( 50, softv, 'SOFTV' ) - if ( index( errstr(1:errstr_len), 'HOLD4WLC - THE MAXIMUM NUMBER' ) .eq. 0 ) stop 8 + if ( index( errstr(1:errstr_len), 'HOLD4WLC - THE MAXIMUM NUMBER' ) == 0 ) stop 8 end if call writsb ( 50 ) - if ( ( mod(mgct,2) .eq. 1 ) .and. & - index( errstr(1:errstr_len), 'MSGUPD - SUBSET HAS BYTE COUNT =' ) .eq. 0 ) stop 9 - if ( ( mgct .eq. 8 ) .and. & - index( errstr(1:errstr_len), 'MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE' ) .eq. 0 ) stop 10 + if ( ( mod(mgct,2) == 1 ) .and. & + index( errstr(1:errstr_len), 'MSGUPD - SUBSET HAS BYTE COUNT =' ) == 0 ) stop 9 + if ( ( mgct == 8 ) .and. & + index( errstr(1:errstr_len), 'MSGUPD - SUBSET LONGER THAN ANY POSSIBLE MESSAGE' ) == 0 ) stop 10 end if end do diff --git a/test/outtest11.F90 b/test/outtest11.F90 index f1015426..939ed2e6 100644 --- a/test/outtest11.F90 +++ b/test/outtest11.F90 @@ -20,8 +20,8 @@ program outtest11 open ( unit = 11, file = 'testfiles/OUT_11_infile1', form = 'unformatted', iostat = ios1 ) open ( unit = 12, file = 'testfiles/OUT_11_infile2', form = 'unformatted', iostat = ios2 ) open ( unit = 50, file = 'out11.bufr', form = 'unformatted', iostat = ios3 ) - if ( any( (/ios1,ios2,ios3/) .ne. (/0,0,0/) ) ) stop 1 - if ( isetprm ( 'MXCSB', 50 ) .ne. 0 ) stop 2 + if ( any( (/ios1,ios2,ios3/) /= (/0,0,0/) ) ) stop 1 + if ( isetprm ( 'MXCSB', 50 ) /= 0 ) stop 2 call pkvs01 ( 'MTV', 40 ) ! Specify that output messages should be BUFR edition 4. @@ -37,7 +37,7 @@ program outtest11 call cmpmsg ( 'Y' ) ! Copy all of the data subsets from the first input file to the output file. - do while ( ireadns ( 11, cmgtag, imgdt ) .eq. 0 ) + do while ( ireadns ( 11, cmgtag, imgdt ) == 0 ) call openmb ( 50, cmgtag, imgdt ) call ufbcpy ( 11, 50 ) call writsb ( 50 ) @@ -55,7 +55,7 @@ program outtest11 call maxout ( 5000 ) ! Copy all of the data subsets from the second input file and append them to the output file. - do while ( ireadns ( 12, cmgtag, imgdt ) .eq. 0 ) + do while ( ireadns ( 12, cmgtag, imgdt ) == 0 ) call openmb ( 50, cmgtag, imgdt ) call ufbcpy ( 12, 50 ) call writsb ( 50 ) @@ -68,8 +68,8 @@ program outtest11 open ( unit = 13, file = 'testfiles/OUT_11_infile3', form = 'unformatted', iostat = ios1 ) open ( unit = 50, file = 'out11.bufr', form = 'unformatted', iostat = ios2 ) - if ( any( (/ios1,ios2/) .ne. (/0,0/) ) ) stop 3 - if ( isetprm ( 'MXCSB', 30 ) .ne. 0 ) stop 4 + if ( any( (/ios1,ios2/) /= (/0,0/) ) ) stop 3 + if ( isetprm ( 'MXCSB', 30 ) /= 0 ) stop 4 ! Specify that output messages should be BUFR edition 4. call pkvs01 ( 'BEN', 4 ) @@ -88,7 +88,7 @@ program outtest11 call maxout ( 11500 ) ! Copy all of the data subsets from the third input file to the output file. - do while ( ireadns ( 13, cmgtag, imgdt ) .eq. 0 ) + do while ( ireadns ( 13, cmgtag, imgdt ) == 0 ) call openmb ( 50, cmgtag, imgdt ) call ufbcpy ( 13, 50 ) call writsb ( 50 ) diff --git a/test/outtest2.F90 b/test/outtest2.F90 index cc5f12ee..e35a51dd 100644 --- a/test/outtest2.F90 +++ b/test/outtest2.F90 @@ -19,7 +19,7 @@ program outtest2 equivalence (rpid(1,1),cpid) - print *, 'Testing writing OUT_2 using OPENBF IO = APX and embedded tables' + print *, 'Testing writing OUT_2 using OPENBF IO = APX and embedded tables' #ifdef KIND_8 call setim8b ( .true. ) @@ -50,7 +50,7 @@ program outtest2 call openbf ( 11, 'APX', 12 ) ! Check for any abnormal internal return codes so far. - if ( igetsc ( 11 ) .ne. 0 ) stop 1 + if ( igetsc ( 11 ) /= 0 ) stop 1 ! Specify an originating center number to use in Section 1 of the output message, and then prepare to ! to write 2 subsets into the message using BUFR edition 4. @@ -61,8 +61,8 @@ program outtest2 ! of being written. Note that ufbtab will internally call rewnbf, since the logical unit in question is ! already open to the library. call ufbtab ( 11, r8utb, 3, 45000, nutb, 'CLATH CLONH SLHD1') - if ( ( nutb .ne. 41541 ) .or. ( nint(r8utb(1,1)*100000) .ne. 6108965 ) .or. ( nint(r8utb(1,2)*100000) .ne. 6106049 ) & - .or. ( nint(r8utb(2,3)*100000) .ne. 16179889 ) .or. ( nint(r8utb(3,3)*1000000) .ne. 338688 ) ) stop 2 + if ( ( nutb /= 41541 ) .or. ( nint(r8utb(1,1)*100000) /= 6108965 ) .or. ( nint(r8utb(1,2)*100000) /= 6106049 ) & + .or. ( nint(r8utb(2,3)*100000) /= 16179889 ) .or. ( nint(r8utb(3,3)*1000000) /= 338688 ) ) stop 2 ! First subset. @@ -70,7 +70,7 @@ program outtest2 ! Check some mnemonic specifications. call nemspecs ( 11, 'TMBRST', 1, nsc, nrf, nbt, ierns ) - if ( ( ierns .ne. 0 ) .or. ( nsc .ne. 3 ) .or. ( nbt .ne. 19 ) ) stop 3 + if ( ( ierns /= 0 ) .or. ( nsc /= 3 ) .or. ( nbt /= 19 ) ) stop 3 r8ymd(1,1) = 2012 r8ymd(2,1) = 10 @@ -109,18 +109,18 @@ program outtest2 call ufbint ( 11, rpid, 1, 1, nlv, 'RPID' ) ! Confirm the "missing" value is still the same value that was set previously via the call to setxmiss. - if ( nint(xmiss) .ne. nint(getbmiss()) ) stop 4 + if ( nint(xmiss) /= nint(getbmiss()) ) stop 4 ! Test cnved4 to cover im8b=.true. case call writsa ( 11, mxbfmg, mgbf, lmgbf ) call cnved4(mgbf,mxbfmg,mgbf2) - if ( iupbs01(mgbf2, 'BEN') .ne. 4 ) stop 5 + if ( iupbs01(mgbf2, 'BEN') /= 4 ) stop 5 ! Re-converting to BUFR ed. 4 should leave the message unchanged call cnved4(mgbf2,mxbfmg,mgbf) - if ( .not. all( mgbf(1:lmgbf) .eq. mgbf2(1:lmgbf) )) stop 6 + if ( .not. all( mgbf(1:lmgbf) == mgbf2(1:lmgbf) )) stop 6 ! Call pkftbv with some bogus values to ensure that the "missing" value is properly returned. - if ( nint(pkftbv(0,0)) .ne. nint(getbmiss()) ) stop 7 + if ( nint(pkftbv(0,0)) /= nint(getbmiss()) ) stop 7 ! Close the output file. call closbf ( 11 ) diff --git a/test/outtest3.F90 b/test/outtest3.F90 index 2407a9af..63bdc157 100644 --- a/test/outtest3.F90 +++ b/test/outtest3.F90 @@ -23,7 +23,7 @@ program outtest3 ! First message. ! Set some custom array sizes. - if ( ( isetprm ( 'NFILES', 2 ) .ne. 0 ) .or. ( isetprm ( 'MXMSGL', 8000 ) .ne. 0 ) ) stop 1 + if ( ( isetprm ( 'NFILES', 2 ) /= 0 ) .or. ( isetprm ( 'MXMSGL', 8000 ) /= 0 ) ) stop 1 ! Set some custom Section 1 values. call pkvs01 ( 'MTV', 18 ) @@ -35,7 +35,7 @@ program outtest3 call openbf ( 11, 'OUT', 12 ) ! Confirm the values from the previous isetprm settings. - if ( ( igetprm ( 'NFILES' ) .ne. 2 ) .or. ( igetprm ( 'MXMSGL' ) .ne. 8000 ) ) stop 2 + if ( ( igetprm ( 'NFILES' ) /= 2 ) .or. ( igetprm ( 'MXMSGL' ) /= 8000 ) ) stop 2 ! Write a standard message. call stdmsg ('Y') @@ -94,7 +94,7 @@ program outtest3 ! Second message. ! Set some new custom array sizes. - if ( ( isetprm ( 'NFILES', 5 ) .ne. 0 ) .or. ( isetprm ( 'MXMSGL', 12000 ) .ne. 0 ) ) stop 3 + if ( ( isetprm ( 'NFILES', 5 ) /= 0 ) .or. ( isetprm ( 'MXMSGL', 12000 ) /= 0 ) ) stop 3 ! Set some new custom Section 1 values. call pkvs01 ( 'BEN', 4 ) @@ -107,7 +107,7 @@ program outtest3 call openbf ( 11, 'APX', 12 ) ! Confirm the values from the previous isetprm settings. - if ( ( igetprm ( 'NFILES' ) .ne. 5 ) .or. ( igetprm ( 'MXMSGL' ) .ne. 12000 ) ) stop 4 + if ( ( igetprm ( 'NFILES' ) /= 5 ) .or. ( igetprm ( 'MXMSGL' ) /= 12000 ) ) stop 4 ! Write a standard message. call stdmsg ('Y') diff --git a/test/outtest4.F90 b/test/outtest4.F90 index bd15394c..736d9628 100644 --- a/test/outtest4.F90 +++ b/test/outtest4.F90 @@ -62,11 +62,11 @@ program outtest4 #endif ! Set some custom array sizes. - if ( ( isetprm ( 'NFILES', 6 ) .ne. 0 ) .or. ( isetprm ( 'MXMSGL', 400000 ) .ne. 0 ) .or. & - ( isetprm ( 'MAXSS', 250000 ) .ne. 0 ) .or. ( isetprm ( 'MAXMEM', 100000 ) .ne. 0 ) .or. & - ( isetprm ( 'MAXMSG', 100 ) .ne. 0 ) .or. ( isetprm ( 'MXDXTS', 5 ) .ne. 0 ) .or. & - ( isetprm ( 'MXCDV', 100 ) .ne. 0 ) .or. ( isetprm ( 'MXCSB', 100 ) .ne. 0 ) .or. & - ( isetprm ( 'MXLCC', 8 ) .ne. 0 ) ) stop 1 + if ( ( isetprm ( 'NFILES', 6 ) /= 0 ) .or. ( isetprm ( 'MXMSGL', 400000 ) /= 0 ) .or. & + ( isetprm ( 'MAXSS', 250000 ) /= 0 ) .or. ( isetprm ( 'MAXMEM', 100000 ) /= 0 ) .or. & + ( isetprm ( 'MAXMSG', 100 ) /= 0 ) .or. ( isetprm ( 'MXDXTS', 5 ) /= 0 ) .or. & + ( isetprm ( 'MXCDV', 100 ) /= 0 ) .or. ( isetprm ( 'MXCSB', 100 ) /= 0 ) .or. & + ( isetprm ( 'MXLCC', 8 ) /= 0 ) ) stop 1 ! Open the BUFR input and output files. @@ -78,18 +78,18 @@ program outtest4 call openbf ( 11, 'FIRST', 11 ) call openbf ( 11, 'QUIET', 2 ) call openbf ( 11, 'IN', 11 ) - if ( index( errstr(1:errstr_len), 'TABLE FROM INPUT BUFR FILE IN UNIT' ) .eq. 0 ) stop 2 + if ( index( errstr(1:errstr_len), 'TABLE FROM INPUT BUFR FILE IN UNIT' ) == 0 ) stop 2 call openbf ( 12, 'SEC3', 12 ) errstr_len = 0 call openbf ( 13, 'NODX', 11 ) - if ( index( errstr(1:errstr_len), 'INTERNAL ARRAYS ASSOC. W/ INPUT UNIT' ) .eq. 0 ) stop 3 + if ( index( errstr(1:errstr_len), 'INTERNAL ARRAYS ASSOC. W/ INPUT UNIT' ) == 0 ) stop 3 ! Test a branch in readdx, using 'NUL' and 'INUL' options so that we don't have to actually assign ! units 51 and 52 to files on the local system. errstr_len = 0 call openbf ( 51, 'NUL', 13 ) call openbf ( 52, 'INUL', 51 ) - if ( index( errstr(1:errstr_len), 'INTERNAL ARRAYS ASSOC. W/ OUTPUT UNIT' ) .eq. 0 ) stop 4 + if ( index( errstr(1:errstr_len), 'INTERNAL ARRAYS ASSOC. W/ OUTPUT UNIT' ) == 0 ) stop 4 call openbf ( 13, 'QUIET', -1 ) #ifndef KIND_8 @@ -98,7 +98,7 @@ program outtest4 call status ( 52, lun, il, im ) call restd_c ( lun, 65148, nctddesc, ctddesc ) if ( any( (/ nctddesc, ctddesc(1), ctddesc(5), ctddesc(10), ctddesc(11), ctddesc(13), ctddesc(14) /) & - .ne.(/ 14, 49419, 34307, 17152, 7937, 34317, 2757 /) ) ) stop 5 + /=(/ 14, 49419, 34307, 17152, 7937, 34317, 2757 /) ) ) stop 5 #endif ! Set the location of the master BUFR tables. @@ -109,9 +109,9 @@ program outtest4 call openbf ( 52, 'QUIET', 2 ) errstr_len = 0 call mtfnam ( 0, 15, 7, 2, 'TableB', stdfil, locfil ) - if ( ( index( errstr(1:errstr_len), 'Standard TableB:../tables/bufrtab.TableB_STD_0_15' ) .eq. 0 ) .or. & - ( index( errstr(1:errstr_len), 'Local TableB:../tables/bufrtab.TableB_LOC_0_7_2' ) .eq. 0 ) .or. & - ( index( errstr(1:errstr_len), 'not found, so using:' ) .eq. 0 ) ) stop 6 + if ( ( index( errstr(1:errstr_len), 'Standard TableB:../tables/bufrtab.TableB_STD_0_15' ) == 0 ) .or. & + ( index( errstr(1:errstr_len), 'Local TableB:../tables/bufrtab.TableB_LOC_0_7_2' ) == 0 ) .or. & + ( index( errstr(1:errstr_len), 'not found, so using:' ) == 0 ) ) stop 6 call openbf ( 52, 'QUIET', -1 ) #endif @@ -119,7 +119,7 @@ program outtest4 call maxout ( mxbfmg*4 ) ! Confirm the value from the previous maxout setting. - if ( igetmxby ( ) .ne. mxbfmg*4 ) stop 7 + if ( igetmxby ( ) /= mxbfmg*4 ) stop 7 ! The following call to STDMSG will ensure that subroutine STNDRD is called internally during the ! subsequent calls to WRITSB and CLOSMG. @@ -131,10 +131,10 @@ program outtest4 ! Process 1 message with 1 data subset from infile1. call readmg ( 11, cmgtag, imgdt, iermg ) - if ( iermg .ne. 0 ) stop 8 + if ( iermg /= 0 ) stop 8 call readsb ( 11, iersb ) - if ( iersb .ne. 0 ) stop 9 + if ( iersb /= 0 ) stop 9 call openmb ( 13, 'NC007000', 2020022514 ) @@ -150,7 +150,7 @@ program outtest4 ! Process 1 message with multiple data subsets from infile2. call readmg ( 12, cmgtag, imgdt, iermg ) - if ( iermg .ne. 0 ) stop 10 + if ( iermg /= 0 ) stop 10 ! Turn off output message standardization. call stdmsg ('N') @@ -159,10 +159,10 @@ program outtest4 call wrdxtb ( 12, 13 ) ! Copy values from the input message to the output message for all data subsets. - + nsub = 0 - do while ( ireadsb ( 12 ) .eq. 0 ) + do while ( ireadsb ( 12 ) == 0 ) nsub = nsub + 1 @@ -173,13 +173,13 @@ program outtest4 call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'DATETMLN' ) write ( unit = smid, fmt = '(A,I1.1)' ) 'STATION#', nsub - if ( nsub .eq. 1 ) then + if ( nsub == 1 ) then call openbf ( 12, 'QUIET', 1 ) errstr_len = 0 call readlc ( 12, dummystr, 'DUMMYSTR' ) - if ( index( errstr(1:errstr_len), 'NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' ) .eq. 0 ) stop 11 + if ( index( errstr(1:errstr_len), 'NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' ) == 0 ) stop 11 call openbf ( 12, 'QUIET', -1 ) - if ( icbfms( dummystr, 9 ) .eq. 0 ) smid = dummystr + if ( icbfms( dummystr, 9 ) == 0 ) smid = dummystr end if call ufbseq ( 12, r8arr1, mxval1, 1, nlv, 'IDLSIPTM' ) @@ -189,41 +189,41 @@ program outtest4 call ufbseq ( 12, r8arr1, mxval1, 1, nlv, 'CLINRVSD' ) call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'CLINRVSD' ) call ufbseq ( 12, r8arr2, mxval2, mxlvl, nlv2, 'TDWPRAOB' ) - if ( nsub .eq. 1 ) then + if ( nsub == 1 ) then ! Test some error branches in ufbint and ufbseq. call openbf ( 12, 'QUIET', 0 ) errstr_len = 0 call ufbint ( 13, r8arr1, mxval1, 1, nlv, 'DUMMYVAL' ) - if ( index( errstr(1:errstr_len), 'Note: Only the first occurrence of this WARNING' ) .eq. 0 ) stop 12 + if ( index( errstr(1:errstr_len), 'Note: Only the first occurrence of this WARNING' ) == 0 ) stop 12 errstr_len = 0 call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'DUMMYVAL' ) - if ( index( errstr(1:errstr_len), 'Note: Only the first occurrence of this WARNING' ) .eq. 0 ) stop 13 + if ( index( errstr(1:errstr_len), 'Note: Only the first occurrence of this WARNING' ) == 0 ) stop 13 call openbf ( 12, 'QUIET', 1 ) errstr_len = 0 call ufbint ( 13, r8arr1, mxval1, 1, nlv, 'DUMMYVAL' ) - if ( index( errstr(1:errstr_len), 'UFBINT - NO SPECIFIED VALUES WRITTEN OUT' ) .eq. 0 ) stop 14 + if ( index( errstr(1:errstr_len), 'UFBINT - NO SPECIFIED VALUES WRITTEN OUT' ) == 0 ) stop 14 errstr_len = 0 call ufbseq ( 13, r8arr1, mxval1, 1, nlv, 'DUMMYVAL' ) - if ( index( errstr(1:errstr_len), 'UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT' ) .eq. 0 ) stop 15 + if ( index( errstr(1:errstr_len), 'UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT' ) == 0 ) stop 15 call openbf ( 12, 'QUIET', -1 ) end if call drfini ( 13, nlv2, 1, '(TDWPRAOB)' ) call ufbseq ( 13, r8arr2, mxval2, nlv2, nlv, 'TDWPRAOB' ) call hold4wlc ( 13, smid, 'SMID' ) - if ( nsub .eq. 1 ) then + if ( nsub == 1 ) then call openbf ( 12, 'QUIET', 1 ) errstr_len = 0 call writlc ( 13, dummystr, 'DUMMYSTR' ) - if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING' ) .eq. 0 ) stop 16 + if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING' ) == 0 ) stop 16 call openbf ( 12, 'QUIET', -1 ) end if call writsa ( 13, mxbfmg, mgbf, lmgbf ) - if ( nsub .eq. 1 ) then + if ( nsub == 1 ) then call openbf ( 12, 'QUIET', 1 ) errstr_len = 0 call writlc ( 13, dummystr, 'DUMMYSTR' ) - if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE SUBSET' ) .eq. 0 ) stop 17 + if ( index( errstr(1:errstr_len), 'INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE SUBSET' ) == 0 ) stop 17 call openbf ( 12, 'QUIET', -1 ) end if @@ -232,16 +232,16 @@ program outtest4 errstr_len = 0 call openbf ( 13, 'QUIET', 2 ) call writsa ( -13, mxbfmg, mgbf, lmgbf ) - if ( index( errstr(1:errstr_len), 'MSGWRT: LUNIT =' ) .eq. 0 ) stop 18 + if ( index( errstr(1:errstr_len), 'MSGWRT: LUNIT =' ) == 0 ) stop 18 call openbf ( 13, 'QUIET', -1 ) ! Get Section 1 date. idate = igetdate(mgbf, mear, mmon, mday, mour) - if ( any((/idate,mear,mmon,mday,mour/).ne.(/20100111,20,10,1,11/)) ) stop 19 + if ( any((/idate,mear,mmon,mday,mour/)/=(/20100111,20,10,1,11/)) ) stop 19 ! Get the tank receipt time. call rtrcptb ( mgbf, mear, mmon, mday, mour, mmin, iret ) - if ( any((/iret,mear,mmon,mday,mour,mmin/).ne.(/0,2020,11,4,15,29/)) ) stop 20 + if ( any((/iret,mear,mmon,mday,mour,mmin/)/=(/0,2020,11,4,15,29/)) ) stop 20 ! Close the output file. call closbf ( 13 ) @@ -251,6 +251,6 @@ program outtest4 ilena = iupbs01(mgbf2, 'LENM') call atrcpt(mgbf, lmgbf, mgbf2) ilenb = iupbs01(mgbf2, 'LENM') - if (ilenb-ilena .ne. 6) stop 21 + if (ilenb-ilena /= 6) stop 21 end program outtest4 diff --git a/test/outtest5.F90 b/test/outtest5.F90 index f36c5e3f..2d4e9e65 100644 --- a/test/outtest5.F90 +++ b/test/outtest5.F90 @@ -56,7 +56,7 @@ program outtest5 ! Write out each data subset using both UFDUMP and UFBDMP. nsub = 0 - do while ( ireadns ( 11, cmgtag, imgdt ) .eq. 0 ) + do while ( ireadns ( 11, cmgtag, imgdt ) == 0 ) nsub = nsub + 1 write ( 13, fmt = '(///,A,I1,A)' ) '------------------------------ SUBSET #', nsub, '------------------------------' write ( 13, fmt = '(//,A)' ) '------------ UFDUMP ------------' diff --git a/test/outtest7.F90 b/test/outtest7.F90 index abe800d8..e2c02b71 100644 --- a/test/outtest7.F90 +++ b/test/outtest7.F90 @@ -55,7 +55,7 @@ program outtest7 ! Open the input files. call fortran_open ( 'testfiles/OUT_7_infile1', 21, 'unformatted', 'rewind', iostat1 ) call fortran_open ( 'testfiles/OUT_7_infile2', 22, 'unformatted', 'rewind', iostat2 ) - if ( ( iostat1 .ne. 0 ) .or. ( iostat2 .ne. 0 ) ) stop 1 + if ( ( iostat1 /= 0 ) .or. ( iostat2 /= 0 ) ) stop 1 ! Open the output file. open ( unit = 23, file = 'testfiles/OUT_7_bufrtab') @@ -65,35 +65,35 @@ program outtest7 ! Read the input files into internal memory arrays. call ufbmex ( 21, 23, 0, icnt1, imesg ) call ufbmex ( 22, 23, 1, icnt2, imesg ) - if ( ( icnt1 .ne. 1 ) .or. ( icnt2 .ne. 3 ) .or. & - ( imesg(1) .ne. 5 ) .or. ( imesg(2) .ne. 8 ) .or. ( imesg(3) .ne. 2 ) .or. ( imesg(4) .ne. 0 ) ) stop 2 + if ( ( icnt1 /= 1 ) .or. ( icnt2 /= 3 ) .or. & + ( imesg(1) /= 5 ) .or. ( imesg(2) /= 8 ) .or. ( imesg(3) /= 2 ) .or. ( imesg(4) /= 0 ) ) stop 2 ! Test some errwrt cases in ufbrms. errstr_len = 0 call ufbrms ( 4, 1, r8vals, -2, 5, nlv, 'SWDE A2CFDFS' ) - if ( ( index( errstr(1:errstr_len), 'UFBRMS - 4th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 3 + if ( ( index( errstr(1:errstr_len), 'UFBRMS - 4th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 3 errstr_len = 0 call ufbrms ( 4, 1, r8vals, 2, -5, nlv, 'SWDE A2CFDFS' ) - if ( ( index( errstr(1:errstr_len), 'UFBRMS - 5th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 4 + if ( ( index( errstr(1:errstr_len), 'UFBRMS - 5th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 4 ! Check some specified values within the 1st subset of the 4th message. call ufbrms ( 4, 1, r8vals, 2, 5, nlv, 'SWDE A2CFDFS' ) - if ( ( nlv .ne. 5 ) .or. & - ( nint(r8vals(1,1)*10000000) .ne. 325011000 ) .or. ( nint(r8vals(1,2)*10000000) .ne. 264548000 ) .or. & - ( nint(r8vals(1,3)*10000000) .ne. 419641000 ) .or. ( nint(r8vals(1,4)*10000000) .ne. 289883000 ) .or. & - ( nint(r8vals(1,5)*10000000) .ne. 117109000 ) .or. ( nint(r8vals(2,1)*10000) .ne. 6140 ) .or. & - ( nint(r8vals(2,2)*10000) .ne. 5909 ) .or. ( nint(r8vals(2,3)*10000) .ne. 7302 ) .or. & - ( nint(r8vals(2,4)*10000) .ne. 7413 ) .or. ( nint(r8vals(2,5)*10000) .ne. 4968 ) ) stop 5 + if ( ( nlv /= 5 ) .or. & + ( nint(r8vals(1,1)*10000000) /= 325011000 ) .or. ( nint(r8vals(1,2)*10000000) /= 264548000 ) .or. & + ( nint(r8vals(1,3)*10000000) /= 419641000 ) .or. ( nint(r8vals(1,4)*10000000) /= 289883000 ) .or. & + ( nint(r8vals(1,5)*10000000) /= 117109000 ) .or. ( nint(r8vals(2,1)*10000) /= 6140 ) .or. & + ( nint(r8vals(2,2)*10000) /= 5909 ) .or. ( nint(r8vals(2,3)*10000) /= 7302 ) .or. & + ( nint(r8vals(2,4)*10000) /= 7413 ) .or. ( nint(r8vals(2,5)*10000) /= 4968 ) ) stop 5 ! Check some specified values within the 633rd subset of the 2nd message. call ufbmms ( 2, 633, cmgtag, idate ) call ufbint ( 21, r8vals, 2, 5, nlv, 'CLATH CLONH' ) - if ( ( cmgtag .ne. 'NC008032' ) .or. ( idate .ne. 22053116 ) .or. ( nlv .ne. 1 ) .or. & - ( nint(r8vals(1,1)*100000) .ne. 4081139 ) .or. ( nint(r8vals(2,1)*100000) .ne. -7787666 ) ) stop 6 + if ( ( cmgtag /= 'NC008032' ) .or. ( idate /= 22053116 ) .or. ( nlv /= 1 ) .or. & + ( nint(r8vals(1,1)*100000) /= 4081139 ) .or. ( nint(r8vals(2,1)*100000) /= -7787666 ) ) stop 6 ! Copy the 3rd message to the output file. call rdmemm ( 3, cmgtag, idate, ier ) - if ( ( ier .ne. 0 ) .or. ( cmgtag .ne. 'NC002104' ) ) stop 7 + if ( ( ier /= 0 ) .or. ( cmgtag /= 'NC002104' ) ) stop 7 call cpymem ( 50 ) ! Stop using the internal memory arrays, and instead now re-open the 1st input file as a regular file and @@ -101,7 +101,7 @@ program outtest7 call closbf ( 21 ) call fortran_open ( 'testfiles/OUT_7_infile1', 21, 'unformatted', 'rewind', iostat1 ) call openbf ( 21, 'IN', 23 ) - if ( ireadmg ( 21, cmgtag, idate ) .ne. 0 ) stop 8 + if ( ireadmg ( 21, cmgtag, idate ) /= 0 ) stop 8 ! Open a new output message, then copy subsets #115, 288, and 530 from the 1st message to that output message. @@ -119,14 +119,14 @@ program outtest7 call copysb ( 21, -50, ier ) istart = istart + 1 end do - if ( ( icopysb ( 21, 50 ) ) .ne. 0 ) stop 9 + if ( ( icopysb ( 21, 50 ) ) /= 0 ) stop 9 istart = istart + 1 end do ! Close the input and output files. call fortran_close ( 21, iostat1 ) call fortran_close ( 22, iostat2 ) - if ( ( iostat1 .ne. 0 ) .or. ( iostat2 .ne. 0 ) ) stop 10 + if ( ( iostat1 /= 0 ) .or. ( iostat2 /= 0 ) ) stop 10 ! Close the output file. call closbf ( 50 ) diff --git a/test/outtest8.F90 b/test/outtest8.F90 index 3e55678d..e99159d0 100644 --- a/test/outtest8.F90 +++ b/test/outtest8.F90 @@ -49,7 +49,7 @@ program outtest8 call maxout ( 25000 ) ! Copy all of the data subsets into an output message. - do while ( ireadns ( 11, cmgtag, imgdt ) .eq. 0 ) + do while ( ireadns ( 11, cmgtag, imgdt ) == 0 ) call openmb ( 12, cmgtag, imgdt ) call ufbcpy ( 11, 12 ) call writsa ( 12, mxbfd4, ibfmg, lenbmg ) @@ -57,7 +57,7 @@ program outtest8 ! Get the completed output message. call writsa ( -12, mxbfd4, ibfmg, lenbmg ) - if ( lenbmg .eq. 0 ) stop 2 + if ( lenbmg == 0 ) stop 2 ! Open the output file. call cobfl_c ( filnam, filost ) @@ -68,7 +68,7 @@ program outtest8 ! For some reason the following code line squawks with a -Wconversion warning, so for now we'll just ! hardcode a workaround since lenbmg should have a value of 2237 when using 8-byte integers. ! nbyt = int(lenbmg,4) * 8 - if ( lenbmg .ne. 2237 ) stop 3 + if ( lenbmg /= 2237 ) stop 3 nbyt = 2237 * 8 #else nbyt = lenbmg * 4 @@ -82,7 +82,7 @@ program outtest8 iusno = iupbs01( ibfmg, 'USN' ) call pkbs1( 1, ibfmg, 'USN' ) iusnn = iupbs01( ibfmg, 'USN' ) - if ( any( (/imtvo,imtvn,iusno,iusnn/) .ne. (/36,39,0,1/) ) ) stop 4 + if ( any( (/imtvo,imtvn,iusno,iusnn/) /= (/36,39,0,1/) ) ) stop 4 ! Close the output file. call ccbfl_c() diff --git a/test/outtest9.F90 b/test/outtest9.F90 index 3856bab4..80804fec 100644 --- a/test/outtest9.F90 +++ b/test/outtest9.F90 @@ -33,7 +33,7 @@ end subroutine errwrt program outtest9 use Share_errstr_outtest9 - + implicit none integer ii, jj, imgdt, ier, mxbfmg, lmgbf @@ -65,9 +65,9 @@ program outtest9 ! Read the first BUFR message from each of the input files. call readmg ( 11, cmgtag, imgdt, ier ) - if ( ier .ne. 0 ) stop 1 + if ( ier /= 0 ) stop 1 call readmg ( 12, cmgtag, imgdt, ier ) - if ( ier .ne. 0 ) stop 2 + if ( ier /= 0 ) stop 2 ! Open a new BUFR message for output. call openmb ( 21, cmgtag, imgdt ) @@ -78,42 +78,42 @@ program outtest9 ! Read in the next corresponding subset from each file. call readsb (11, ier) - if ( ier .ne. 0 ) stop 3 + if ( ier /= 0 ) stop 3 call readsb (12, ier) - if ( ier .ne. 0 ) stop 4 + if ( ier /= 0 ) stop 4 ! Copy the first subset to the output message. call invmrg (11, 21) ! Merge REHU from the second subset into the output message. call ufbint (12, r8arr1, 4, 1, ier, 'REHU' ) - if ( ier .ne. 1 ) stop 5 + if ( ier /= 1 ) stop 5 call ufbint (21, r8arr1, 4, 1, ier, 'REHU' ) - if ( ier .ne. 1 ) stop 6 + if ( ier /= 1 ) stop 6 ! Merge the PWEATHER data from the second subset into the output message. call ufbint (11, r8arr2, 4, 2, ier, 'PRWE TPHR PSW1 PSW2' ) - if ( ier .ne. 1 ) stop 7 + if ( ier /= 1 ) stop 7 call ufbint (12, r8arr1, 4, 1, ier, 'PRWE TPHR PSW1 PSW2' ) - if ( ier .ne. 1 ) stop 8 + if ( ier /= 1 ) stop 8 do jj = 1, 4 r8arr2(jj,2) = r8arr1(jj,1) end do - if ( ii .eq. 1 ) then ! test some errwrt cases in ufbovr + if ( ii == 1 ) then ! test some errwrt cases in ufbovr call openbf (21, 'QUIET', 2 ) errstr_len = 0 call ufbovr (21, r8arr2, -4, 2, ier, 'PRWE TPHR PSW1 PSW2' ) - if ( ( index( errstr(1:errstr_len), 'UFBOVR - 3rd ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 9 + if ( ( index( errstr(1:errstr_len), 'UFBOVR - 3rd ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 9 errstr_len = 0 call ufbovr (21, r8arr2, 4, -2, ier, 'PRWE TPHR PSW1 PSW2' ) - if ( ( index( errstr(1:errstr_len), 'UFBOVR - 4th ARG. (INPUT) IS .LE. 0' ) .eq. 0 ) ) stop 10 + if ( ( index( errstr(1:errstr_len), 'UFBOVR - 4th ARG. (INPUT) IS .LE. 0' ) == 0 ) ) stop 10 call openbf (21, 'QUIET', 0 ) end if call ufbovr (21, r8arr2, 4, 2, ier, 'PRWE TPHR PSW1 PSW2' ) - if ( ier .ne. 2 ) stop 11 + if ( ier /= 2 ) stop 11 ! Write the subset into the output message. - if ( ii.lt.3 ) then + if ( ii<3 ) then call writsb (21) else call writsa (21, mxbfmg, mgbf, lmgbf) @@ -126,12 +126,12 @@ program outtest9 ! Check the invmrg output. errstr_len = 0 call mrginv - if ( ( index( errstr(1:errstr_len), 'NUMBER OF DRB EXPANSIONS = 3' ) .eq. 0 ) .or. & - ( index( errstr(1:errstr_len), 'NUMBER OF MERGES = 42' ) .eq. 0 ) ) stop 12 + if ( ( index( errstr(1:errstr_len), 'NUMBER OF DRB EXPANSIONS = 3' ) == 0 ) .or. & + ( index( errstr(1:errstr_len), 'NUMBER OF MERGES = 42' ) == 0 ) ) stop 12 ! Read the second data message from infile1, which includes a new preceding DX BUFR table. call readmg ( 11, cmgtag, imgdt, ier ) - if ( ier .ne. 0 ) stop 13 + if ( ier /= 0 ) stop 13 ! Copy the new DX BUFR table to the output file. call wrdxtb (11, 21) @@ -141,18 +141,18 @@ program outtest9 ! Read the third data message from infile1. call readmg ( 11, cmgtag, imgdt, ier ) - if ( ier .ne. 0 ) stop 14 + if ( ier /= 0 ) stop 14 ! Get a count of the number of data subsets in the message. jj = nmsub(11) - if ( jj .ne. 660 ) stop 15 + if ( jj /= 660 ) stop 15 ! Open a new BUFR message for output. call openmb ( 21, cmgtag, imgdt ) ! Copy the third data message subset-by-subset into the output file. - do ii = 1, jj - if ( icopysb (11, 21) .ne. 0 ) stop 16 + do ii = 1, jj + if ( icopysb (11, 21) /= 0 ) stop 16 end do ! Close the output file. diff --git a/test/test_bort.F90 b/test/test_bort.F90 index 317e6f5f..c4e597a6 100644 --- a/test/test_bort.F90 +++ b/test/test_bort.F90 @@ -65,49 +65,49 @@ program test_bort ! Read the command line arguments, a name of subroutine, and a test ! case number. call get_command_argument(1, sub_name, len, stat) - if (stat .ne. 0) stop 3 + if (stat /= 0) stop 3 call get_command_argument(2, test_case, len, stat) - if (stat .ne. 0) stop 4 + if (stat /= 0) stop 4 print *, 'Testing ', sub_name, ' case ', test_case ! Run the test for the subroutine and test case. - if (sub_name .eq. 'adn30') then - if (test_case .eq. '1') then + if (sub_name == 'adn30') then + if (test_case == '1') then char_30 = adn30(0, 9) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then char_30 = adn30(-1, 5) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then char_30 = adn30(65536, 5) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then char_30 = adn30(0, 3) endif - elseif (sub_name .eq. 'atrcpt') then - if (test_case .eq. '1') then + elseif (sub_name == 'atrcpt') then + if (test_case == '1') then filnam = 'testfiles/IN_11' call cobfl_c ( filnam, 'r' ) call crbmg_c ( bfmg, 200000, msgl, iret ) - if ( iret .ne. 0 ) stop 3 + if ( iret /= 0 ) stop 3 call ccbfl_c () call atrcpt ( ibfmg, 5000, ibfmg2 ) endif - elseif (sub_name .eq. 'bort') then - if (test_case .eq. '1') then + elseif (sub_name == 'bort') then + if (test_case == '1') then call bort('goodbye!') endif - elseif (sub_name .eq. 'bort2') then - if (test_case .eq. '1') then + elseif (sub_name == 'bort2') then + if (test_case == '1') then call bort2('goodbye!', 'goodbye again!') endif - elseif (sub_name .eq. 'bvers') then - if (test_case .eq. '1') then + elseif (sub_name == 'bvers') then + if (test_case == '1') then call bvers(char_short) endif - elseif (sub_name .eq. 'chekstab') then + elseif (sub_name == 'chekstab') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = '| YEAR | 004001 | YEAR |' write (12,'(A)') card card = '| YEAR | 0 | 0 | 12 | YEAR |-------------|' @@ -117,30 +117,30 @@ program test_bort call openbf(11, 'OUT', 12) call chekstab(1) endif - elseif (sub_name .eq. 'closmg') then - if (test_case .eq. '1') then + elseif (sub_name == 'closmg') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call closmg(11) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call openbf(12, 'FIRST', 11) open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call closmg(11) endif - elseif (sub_name .eq. 'cmpmsg') then - if (test_case .eq. '1') then + elseif (sub_name == 'cmpmsg') then + if (test_case == '1') then call cmpmsg('W') endif - elseif (sub_name .eq. 'cnved4') then + elseif (sub_name == 'cnved4') then open(unit = 31, file = '/dev/null') - if (test_case .eq. '1') then + if (test_case == '1') then call openbf(31, 'SEC3', 31) filnam = 'testfiles/IN_1' - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 12, file = 'testfiles/OUT_3_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(31, 'IN', 12) filnam = 'testfiles/OUT_3' endif @@ -148,350 +148,350 @@ program test_bort call crbmg_c(bfmg, 200000, msgl, iret) call readerme(ibfmg, 31, char_val_8, jdate, iret) call cnved4(ibfmg, 1, ibay) - elseif (sub_name .eq. 'codflg') then - if (test_case .eq. '1') then + elseif (sub_name == 'codflg') then + if (test_case == '1') then call codflg('W') endif - elseif (sub_name .eq. 'copybf') then - if (test_case .eq. '1') then + elseif (sub_name == 'copybf') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call copybf(11, 0) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'IN', 12) call copybf(11, 12) endif - elseif (sub_name .eq. 'copymg') then - if (test_case .eq. '1') then + elseif (sub_name == 'copymg') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call copymg(11, 0) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call copymg(12, 0) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call copymg(11, 0) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readmg(11, char_val_8, jdate, iret) open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'IN', 12) call copymg(11, 12) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readmg(11, char_val_8, jdate, iret) open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call copymg(11, 12) endif - elseif (sub_name .eq. 'copysb') then - if (test_case .eq. '1') then + elseif (sub_name == 'copysb') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call copysb(11, 0, ierr) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call copysb(12, 0, ierr) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 10) call copysb(11, 0, ierr) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 10) call readmg(11, char_val_8, jdate, iret) open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call copysb(11, 12, ierr) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 10) call readmg(11, char_val_8, jdate, iret) open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'IN', 10) call copysb(11, 12, ierr) - elseif (test_case .eq. '6') then + elseif (test_case == '6') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 10) call readmg(11, char_val_8, jdate, iret) open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 10) call copysb(11, 12, ierr) - elseif (test_case .eq. '7') then + elseif (test_case == '7') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 12) call readmg(11, char_val_8, jdate, iret) open(unit = 13, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 14, file = 'testfiles/IN_7_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(13, 'OUT', 14) call openmb(13, 'NC008023', 2021022312) call copysb(11, 13, ierr) endif - elseif (sub_name .eq. 'cpdxmm') then - if (test_case .eq. '1') then + elseif (sub_name == 'cpdxmm') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_6_infile1', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_6_infile2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (isetprm('MXDXTS',1) .ne. 0) stop 3 + if (ios /= 0) stop 3 + if (isetprm('MXDXTS',1) /= 0) stop 3 call ufbmem(11, 0, iret, iunit) call ufbmem(12, 1, iret, iunit) call ufbmns(18364, char_val_8, jdate) endif - elseif (sub_name .eq. 'cpymem') then + elseif (sub_name == 'cpymem') then open(unit = 11, file = 'testfiles/IN_6_infile1', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call ufbmem(11, 0, iret, iunit) - if (test_case .eq. '1') then + if (test_case == '1') then call cpymem(12) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call rdmemm(167, char_val_8, jdate, ierr) call cpymem(12) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call rdmemm(167, char_val_8, jdate, ierr) call openbf(12, 'IN', 11) call cpymem(12) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then call rdmemm(167, char_val_8, jdate, ierr) call openbf(12, 'OUT', 11) call openmg(12, 'NC004001', 2024020112) call cpymem(12) endif - elseif (sub_name .eq. 'datebf') then - if (test_case .eq. '1') then + elseif (sub_name == 'datebf') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call datebf(11, mear, mmon, mday, mour, idate) endif - elseif (sub_name .eq. 'datelen') then - if (test_case .eq. '1') then + elseif (sub_name == 'datelen') then + if (test_case == '1') then call datelen(11) endif - elseif (sub_name .eq. 'dumpbf') then - if (test_case .eq. '1') then + elseif (sub_name == 'dumpbf') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call dumpbf(11, jdate1, jdump1) endif - elseif (sub_name .eq. 'dxdump') then - if (test_case .eq. '1') then + elseif (sub_name == 'dxdump') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) call dxdump(11, 6) endif - elseif (sub_name .eq. 'elemdx') then + elseif (sub_name == 'elemdx') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) - if (test_case .eq. '1') then + if (test_case == '1') then card = '| RCPTIM | 2 | 0 | 16 | DEGREES KELVIN |-------------|' call elemdx(card,1) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = '| MXTM | 2 | 0 | 16 | |-------------|' call elemdx(card,1) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = '| MXTM | 2A | 0 | 16 | DEGREES KELVIN |-------------|' call elemdx(card,1) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then card = '| MXTM | 2 | -15@0 | 16 | DEGREES KELVIN |-------------|' call elemdx(card,1) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then card = '| MXTM | 2 | 0 | 1x | DEGREES KELVIN |-------------|' call elemdx(card,1) endif - elseif (sub_name .eq. 'getcfmng') then + elseif (sub_name == 'getcfmng') then open(unit = 11, file = 'testfiles/IN_4', form ='unformatted', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call getcfmng(11, 'GCLONG', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 11) call getcfmng(12, 'GCLONG', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call openbf(11, 'IN', 11) call getcfmng(11, 'GCLONG', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then call openbf(11, 'SEC3', 11) call readns(11, char_val_8, jdate, iret) call getcfmng(11, 'GCLONG', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then call openbf(11, 'SEC3', 11) call readns(11, char_val_8, jdate, iret) call codflg('Y') call getcfmng(11, 'GXLONG', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '6') then + elseif (test_case == '6') then call openbf(11, 'SEC3', 11) call readns(11, char_val_8, jdate, iret) call codflg('Y') call getcfmng(11, 'SSNY', 254, ' ', -1, char_30, len, iret) - elseif (test_case .eq. '7') then + elseif (test_case == '7') then call openbf(11, 'SEC3', 11) call readns(11, char_val_8, jdate, iret) call codflg('Y') call getcfmng(11, 'SAID', 254, 'GXES', 7, char_30, len, iret) - elseif (test_case .eq. '8') then + elseif (test_case == '8') then call openbf(11, 'SEC3', 11) call readns(11, char_val_8, jdate, iret) call codflg('Y') call getcfmng(11, 'SAID', 254, 'SSNX', 7, char_30, len, iret) endif - elseif (sub_name .eq. 'getntbe') then + elseif (sub_name == 'getntbe') then open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = ' DUMMY | ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call getntbe(11, iret, card, jret) endif - elseif (sub_name .eq. 'gettbh') then + elseif (sub_name == 'gettbh') then open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = 'Table B STD | 0 ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call gettbh(11, 12, 'B', imt, imtv, iogce, iltv) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = 'Table B STX | 0 | 38 ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call gettbh(11, 12, 'B', imt, imtv, iogce, iltv) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = 'Table B STD | 0 | 38 ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table B LOC | 0 | 7 ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call gettbh(11, 12, 'B', imt, imtv, iogce, iltv) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then card = 'Table B STD | 0 | 38 ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table B LOX | 0 | 7 | 1 ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call gettbh(11, 12, 'B', imt, imtv, iogce, iltv) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then card = 'Table B STD | 0 | 38 ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table B LOC | 1 | 7 | 1 ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call gettbh(11, 12, 'B', imt, imtv, iogce, iltv) endif - elseif (sub_name .eq. 'idn30') then - if (test_case .eq. '1') then + elseif (sub_name == 'idn30') then + if (test_case == '1') then idn30_val = idn30(adn30_val_5, 6) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then idn30_val = idn30(adn30_val_5, 2) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then idn30_val = idn30('-0042', 5) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then idn30_val = idn30('65536', 5) endif - elseif (sub_name .eq. 'ifbget') then - if (test_case .eq. '1') then + elseif (sub_name == 'ifbget') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call ifbget(11) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call ifbget(11) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 10) call ifbget(11) endif - elseif (sub_name .eq. 'igetntbi') then - if (test_case .eq. '1') then - if (isetprm('MAXTBB',15) .ne. 0) stop 3 + elseif (sub_name == 'igetntbi') then + if (test_case == '1') then + if (isetprm('MAXTBB',15) /= 0) stop 3 open(unit = 11, file = 'testfiles/IN_7', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_7_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 12) endif - elseif (sub_name .eq. 'igetrfel') then + elseif (sub_name == 'igetrfel') then filnam = 'testfiles/IN_4' call cobfl_c( filnam, 'r' ) open(unit = 31, file = '/dev/null') call openbf(31, 'SEC3', 31) call crbmg_c(bfmg, 200000, msgl, iret) - if (test_case .eq. '1') then + if (test_case == '1') then ! Change the last 2-37-000 operator in Section 3 to 2-35-000, so that the bitmap can't be located ! for any of the subsequent marker operators. ibit = 1016 call pkb(163, 8, ibfmg, ibit) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then ! Change the first 2-24-000 operator in Section 3 to 2-22-000, so that the "follow" operator can't ! be located for any of the subsequent marker operators. ibit = 888 call pkb(150, 8, ibfmg, ibit) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then ! Change the first 2-22-000 operator in Section 3 to 2-35-000, so that the previous referenced ! element can't be located for any of the subsequent marker operators. ibit = 312 @@ -500,105 +500,105 @@ program test_bort call mtinfo('../tables', 80, 81) call readerme(ibfmg, 31, char_val_8, jdate, iret) call readsb(31, iret) - elseif (sub_name .eq. 'igetsc') then - if (test_case .eq. '1') then + elseif (sub_name == 'igetsc') then + if (test_case == '1') then iret = igetsc(11) endif - elseif (sub_name .eq. 'igettdi') then - if (test_case .eq. '1') then + elseif (sub_name == 'igettdi') then + if (test_case == '1') then iret = igettdi(0) do u = 1, 257 iret = igettdi(1) enddo endif - elseif (sub_name .eq. 'inctab') then - if (test_case .eq. '1') then + elseif (sub_name == 'inctab') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/OUT_1', iostat = ios) - if (ios .ne. 0) stop 3 - if (isetprm('MAXJL',10) .ne. 0) stop 3 + if (ios /= 0) stop 3 + if (isetprm('MAXJL',10) /= 0) stop 3 call openbf(11, 'IN', 11) endif - elseif (sub_name .eq. 'ipkm') then - if (test_case .eq. '1') then + elseif (sub_name == 'ipkm') then + if (test_case == '1') then call ipkm(char_val_8, 6, 29) endif - elseif (sub_name .eq. 'isize') then - if (test_case .eq. '1') then + elseif (sub_name == 'isize') then + if (test_case == '1') then iret = isize(1000000) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then iret = isize(-10) endif - elseif (sub_name .eq. 'iupm') then - if (test_case .eq. '1') then + elseif (sub_name == 'iupm') then + if (test_case == '1') then iret = iupm(char_8, 100) endif - elseif (sub_name .eq. 'iupvs01') then - if (test_case .eq. '1') then + elseif (sub_name == 'iupvs01') then + if (test_case == '1') then call openbf(12, 'FIRST', 11) open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 iret = iupvs01(11, 'LENM') - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 10) iret = iupvs01(11, 'LENM') - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 10) iret = iupvs01(11, 'LENM') endif - elseif (sub_name .eq. 'jstnum') then - if (test_case .eq. '1') then + elseif (sub_name == 'jstnum') then + if (test_case == '1') then char_val_8 = ' ' call jstnum(char_val_8,char_1,iret) endif - elseif (sub_name .eq. 'lcmgdf') then + elseif (sub_name == 'lcmgdf') then open(unit = 11, file = 'testfiles/IN_4', form ='unformatted', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then iret = lcmgdf(11, 'NC021206') endif - elseif (sub_name .eq. 'lstjpb') then - if (test_case .eq. '1') then + elseif (sub_name == 'lstjpb') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readmg(11, char_val_8, jdate, iret) call lstjpb(-1, 1, 'DRP') - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readmg(11, char_val_8, jdate, iret) call lstjpb(10000, 1, 'DRP') endif - elseif (sub_name .eq. 'minimg') then - if (test_case .eq. '1') then - elseif (test_case .eq. '2') then + elseif (sub_name == 'minimg') then + if (test_case == '1') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUX', 11) endif call minimg(11, 16) - elseif (sub_name .eq. 'msgwrt') then + elseif (sub_name == 'msgwrt') then filnam = 'testfiles/IN_2' call cobfl_c( filnam, 'r' ) open(unit = 31, file = '/dev/null') call openbf(31, 'INUL', 31) call crbmg_c(bfmg, 200000, msgl, iret) - if (test_case .eq. '1') then + if (test_case == '1') then ibit = 64 call pkb(25, 24, ibfmg, ibit) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then ibit = 256 call pkb(25, 24, ibfmg, ibit) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then ! Make it look like there's a Section 2 in the message. ibit = 120 call pkb(1, 1, ibfmg, ibit) @@ -606,29 +606,29 @@ program test_bort call pkb(3, 24, ibfmg, ibit) endif call msgwrt(31, ibfmg, 19926) - elseif (sub_name .eq. 'mtfnam') then - if (test_case .eq. '1') then + elseif (sub_name == 'mtfnam') then + if (test_case == '1') then call mtinfo('../tables', 80, 81) call mtfnam(999, 15, 7, 1, 'TableB', char_85, char_120) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call mtinfo('.', 80, 81) call mtfnam(999, 15, 7, 1, 'TableB', char_85, char_120) endif - elseif (sub_name .eq. 'nemtba') then - if (test_case .eq. '1') then + elseif (sub_name == 'nemtba') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call nemtba(11, 'SPOCK', mtyp, msbt, inod) endif - elseif (sub_name .eq. 'nemtbax') then + elseif (sub_name == 'nemtbax') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then char_val_8 = 'NC337200' - elseif (test_case .eq. '2') then + elseif (test_case == '2') then char_val_8 = 'NC007300' endif card = '| ' // char_val_8 // ' | A54124 | MTYPE TESTING |' @@ -644,12 +644,12 @@ program test_bort open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) call openmg(11, char_val_8, 2024020112) - elseif (sub_name .eq. 'nemtbb') then + elseif (sub_name == 'nemtbb') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = '| NC007200 | A54124 | MTYPE 007-200 |' write (12,'(A)') card card = '| YEAR | 004001 | YEAR |' @@ -662,9 +662,9 @@ program test_bort open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) call nemtbb(1,-1,unit,iscl,iref,ibit) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = '| NC007200 | A54124 | MTYPE 007-200 |' write (12,'(A)') card card = '| STMID | 001025 | STORM IDENTIFIER |' @@ -676,9 +676,9 @@ program test_bort close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = '| NC007200 | A54124 | MTYPE 007-200 |' write (12,'(A)') card card = '| YEAR | 004001 | YEAR |' @@ -691,12 +691,12 @@ program test_bort open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) endif - elseif (sub_name .eq. 'nemtbd') then + elseif (sub_name == 'nemtbd') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = '| NC007200 | A54124 | MTYPE 007-200 |' write (12,'(A)') card card = '| YEAR | 004001 | YEAR |' @@ -710,323 +710,323 @@ program test_bort call openbf(11, 'OUT', 12) call nemtbd(1,-1,nseq,nems,irps,knts) endif - elseif (sub_name .eq. 'nenubd') then + elseif (sub_name == 'nenubd') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) - if (test_case .eq. '1') then + if (test_case == '1') then call nenubd('BPID ','001008',1) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call nenubd('BPID2 ','001005',1) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call nenubd('LALOLV ','301025',1) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then call nenubd('LALOLV2 ','301024',1) endif - elseif (sub_name .eq. 'nmsub') then - if (test_case .eq. '1') then + elseif (sub_name == 'nmsub') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 iret = nmsub(11) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_7_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) iret = nmsub(11) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) iret = nmsub(11) endif - elseif (sub_name .eq. 'nvnwin') then - if (test_case .eq. '1') then + elseif (sub_name == 'nvnwin') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readns(11, char_val_8, jdate, iret) call nvnwin(1717, 1, 25, 175, jdate1, 5) endif - elseif (sub_name .eq. 'openbf') then - if (test_case .eq. '1') then + elseif (sub_name == 'openbf') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'BBB', 11) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call openbf(11, 'IN', 11) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then do u = 1, 33 open(unit = u+10, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(u+10, 'IN', 11) end do endif - elseif (sub_name .eq. 'openmg') then + elseif (sub_name == 'openmg') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call openbf(11, 'IN', 11) call openmg(11, 'F5FCMESG', 2021022312) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call openmg(11, 'F5FCMESG', 2021022312) endif - elseif (sub_name .eq. 'openmb') then + elseif (sub_name == 'openmb') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call openbf(11, 'IN', 11) call openmb(11, 'F5FCMESG', 2021022312) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call openmb(11, 'F5FCMESG', 2021022312) endif - elseif (sub_name .eq. 'pad') then - if (test_case .eq. '1') then + elseif (sub_name == 'pad') then + if (test_case == '1') then ibit = 16 call pad(ibay, ibit, ierr, 27) endif - elseif (sub_name .eq. 'parstr') then - if (test_case .eq. '1') then + elseif (sub_name == 'parstr') then + if (test_case == '1') then call parstr(char_85, tags, 5, iret, ' ', .true.) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = 'MNEM1 MNEM2 MNEM3 MNEM4 MNEM5 MNEM6 ' call parstr(card, tags, 5, iret, ' ', .true.) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = 'MNEM1MNEM2 MNEM3 MNEM4 MNEM5 MNEM6 ' call parstr(card, tags, 5, iret, ' ', .true.) endif - elseif (sub_name .eq. 'parusr') then - if (test_case .eq. '6') then + elseif (sub_name == 'parusr') then + if (test_case == '6') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - else if (test_case .eq. '7') then + else if (test_case == '7') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) else open(unit = 11, file = 'testfiles/data/prepbufr', form = 'UNFORMATTED', iostat = ios) endif - if (ios .ne. 0) stop 3 - if (test_case .eq. '7') then + if (ios /= 0) stop 3 + if (test_case == '7') then open(unit = 12, file = 'testfiles/OUT_7_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call openmg(11, 'NC002104', 2024020112) call ufbint(11, real_2d, 1, 2, iret, 'RASCN>20') else call openbf(11, 'IN', 11) call readns(11, char_val_8, jdate, iret) - if (iret .ne. 0) stop 3 + if (iret /= 0) stop 3 endif - if (test_case .eq. '1') then + if (test_case == '1') then call parusr(char_85, 1, 1, 1) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = 'POB>0 QOB>0 TOB>0 VOB>0 UOB>0 XOB>0 YOB>0 ELV>0 TYP>0 T29>0 ITP>0 ' call parusr(card, 1, 11, 0) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = 'POB QOB TOB VOB UOB XOB YOB ELV TYP T29 ITP A1 A2 A3 B1 B2 B3 S1 S2 S3 E1 ' call parusr(card, 1, 21, 0) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then card = 'PRSLEVEL^0 ' call parusr(card, 1, 11, 0) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then card = 'POB QOB TOB VOB UOB XOB YOB ELV TYP T29 ITP ' call parusr(card, 1, 10, 0) - elseif (test_case .eq. '6') then + elseif (test_case == '6') then card = 'HGTSIG DCHSIG ' call parusr(card, 1, 2, 0) endif - elseif (sub_name .eq. 'parutg') then + elseif (sub_name == 'parutg') then open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 10, file = 'testfiles/OUT_7_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 10) call openmg(12, 'NC002104', 2024020112) - if (test_case .eq. '1') then + if (test_case == '1') then call ufbint(12, real_2d, 1, 2, iret, 'RATCN>20') - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call ufbint(12, real_2d, 1, 2, iret, 'RASCN>2t') - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call ufbint(12, real_2d, 1, 2, iret, 'UARLVB') endif - elseif (sub_name .eq. 'pkb') then - if (test_case .eq. '1') then + elseif (sub_name == 'pkb') then + if (test_case == '1') then call pkb(1, 65, ibay, ibit) endif - elseif (sub_name .eq. 'pkb8') then - if (test_case .eq. '1') then + elseif (sub_name == 'pkb8') then + if (test_case == '1') then call pkb8(1, -1, ibay, ibit) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call pkb8(1, 65, ibay, ibit) endif - elseif (sub_name .eq. 'pkbs1') then + elseif (sub_name == 'pkbs1') then filnam = 'testfiles/IN_2' call cobfl_c( filnam, 'r' ) call crbmg_c(bfmg, 200000, msgl, iret) - if (test_case .eq. '1') then + if (test_case == '1') then call pkbs1(88, ibfmg, 'DUMMY') endif - elseif (sub_name .eq. 'pkvs01') then - if (test_case .eq. '1') then - if (isetprm('MXS01V',1) .ne. 0) stop 3 + elseif (sub_name == 'pkvs01') then + if (test_case == '1') then + if (isetprm('MXS01V',1) /= 0) stop 3 call openbf(11, 'IN', 11) call pkvs01('OGCE', 88) call pkvs01('OGCE', 84) ! test the overwrite logic too call pkvs01('USN', 2) endif - elseif (sub_name .eq. 'posapx') then - if (test_case .eq. '1') then + elseif (sub_name == 'posapx') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call posapx(11) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call posapx(12) endif - elseif (sub_name .eq. 'rdmgsb') then + elseif (sub_name == 'rdmgsb') then open(unit = 11, file = 'testfiles/IN_3', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call rdmgsb(11, 3, 1) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call rdmgsb(11, 1, 3) endif - elseif (sub_name .eq. 'rdmtbb') then + elseif (sub_name == 'rdmtbb') then open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = 'Table B STD | 0 | 38 ' write (11,'(A)') card card = ' 0-01-001 | 0 | 0 | 7 | Numeric | WMOB ; ; WMO block number ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table B LOC | 0 | 7 | 1 ' write (12,'(A)') card card = ' 001001 | 0 | 2 | 12 | Code table | QCWS ; ; Wind speed quality mark ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call rdmtbb(11, 12, 1, imt, imtv, iogce, iltv, iret, & int_1d, char_4, char_12, char_4, char_24, char_8, char_4, char_120) endif - elseif (sub_name .eq. 'rdmtbd') then + elseif (sub_name == 'rdmtbd') then open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = 'Table D STD | 0 | 38 ' write (11,'(A)') card card = ' 3-01-058 | UNTFROLD ; ; Universal lightning event ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table D LOC | 0 | 7 | 1 ' write (12,'(A)') card card = ' 3-01-058 | LOWRESSEQ ; ; Low-resolution data sequence ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call rdmtbd(11, 12, 1, 5, imt, imtv, iogce, iltv, iret, & int_1d, char_8, char_4, char_120, int_1d_2, int_2d, char_120_2) endif - elseif (sub_name .eq. 'rdmtbf') then + elseif (sub_name == 'rdmtbf') then open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = 'Table F STD | 0 | 35 ' write (11,'(A)') card card = ' 0-02-002 | TIWM ; FLAG ' write (11,'(A)') card close (11) open(unit = 11, file = 'testfiles/test_bort_master_std', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 card = 'Table F LOC | 0 | 7 | 1 ' write (12,'(A)') card card = ' 002002 | NCDY3 ; CODE ' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_master_loc', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call rdmtbf(11, 12) endif - elseif (sub_name .eq. 'rdusdx') then + elseif (sub_name == 'rdusdx') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then card = '| MY-MNEM | | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = '| MYMNEM | 405001 | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = '| MYMNEM | 0H5001 | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then card = '| MYMNEM | 065001 | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then card = '| MYMNEM | 005256 | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '6') then + elseif (test_case == '6') then card = '| NC011004 | A63255 | |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) - elseif (test_case .eq. '7') then + elseif (test_case == '7') then card = '| MYMNEM |' write (12,'(A)') card close (12) open(unit = 12, file = 'testfiles/test_bort_DX', iostat = ios) call openbf(11, 'OUT', 12) endif - elseif (sub_name .eq. 'readerme') then - if (test_case .eq. '1') then + elseif (sub_name == 'readerme') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 12) call readerme(int_1d, 12, char_val_8, jdate, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call readerme(int_1d, 11, char_val_8, jdate, iret) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then filnam = 'testfiles/data/debufr_3' call cobfl_c( filnam, 'r' ) open(unit = 31, file = '/dev/null') @@ -1035,98 +1035,98 @@ program test_bort bfmg(1) = 'C' call readerme(ibfmg, 31, char_val_8, jdate, iret) endif - elseif (sub_name .eq. 'readlc') then - if (test_case .eq. '7') then + elseif (sub_name == 'readlc') then + if (test_case == '7') then open(unit = 11, file = 'testfiles/OUT_1', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call readns(11, char_val_8, jdate, iret) call readlc(11, char_1, 'ACRN') endif open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call openbf(11, 'IN', 11) call readlc(12, char_val_8, char_val_8) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 13, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(13, 'OUT', 12) call readlc(13, char_val_8, char_val_8) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call openbf(11, 'IN', 11) call readlc(11, char_val_8, char_val_8) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call readlc(11, char_val_8, 'YEAR MNTH') - elseif (test_case .eq. '5') then + elseif (test_case == '5') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call readlc(11, char_val_8, 'YEAR') - elseif (test_case .eq. '6') then + elseif (test_case == '6') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call readlc(11, char_1, 'BULTIM') endif - elseif (sub_name .eq. 'readmg') then - if (test_case .eq. '1') then + elseif (sub_name == 'readmg') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 12) call readmg(12, char_val_8, jdate, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call readmg(11, char_val_8, jdate, iret) endif - elseif (sub_name .eq. 'rdmems') then + elseif (sub_name == 'rdmems') then open(unit = 11, file = 'testfiles/IN_6_infile1', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call ufbmem(11, 0, iret, iunit) - if (test_case .eq. '1') then + if (test_case == '1') then call rdmems(11, jret) endif - elseif (sub_name .eq. 'readns') then - if (test_case .eq. '1') then + elseif (sub_name == 'readns') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 12) call readns(12, char_val_8, jdate, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call readns(11, char_val_8, jdate, iret) endif - elseif (sub_name .eq. 'readsb') then - if (test_case .eq. '1') then + elseif (sub_name == 'readsb') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call readsb(11, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 10) call readsb(11, iret) endif - elseif (sub_name .eq. 'reads3') then - if (test_case .eq. '1') then - if (isetprm('MXCNEM',1) .ne. 0) stop 3 + elseif (sub_name == 'reads3') then + if (test_case == '1') then + if (isetprm('MXCNEM',1) /= 0) stop 3 open(unit = 31, file = '/dev/null') call openbf(31, 'SEC3', 31) call mtinfo('../tables', 80, 81) @@ -1142,122 +1142,122 @@ program test_bort call pkb(14, 8, ibfmg, ibit) call readerme(ibfmg, 31, char_val_8, jdate, iret) endif - elseif (sub_name .eq. 'rewnbf') then + elseif (sub_name == 'rewnbf') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2_bufrtab', iostat = ios) - if (ios .ne. 0) stop 3 - if (test_case .eq. '1') then + if (ios /= 0) stop 3 + if (test_case == '1') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call rewnbf(11, 4) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call rewnbf(11, 0) call rewnbf(11, 0) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call rewnbf(11, 0) call rewnbf(11, 1) call rewnbf(11, 1) - elseif (test_case .eq. '4') then + elseif (test_case == '4') then call openbf(11, 'IN', 12) call readns(11, char_val_8, jdate, iret) call rewnbf(11, 1) - elseif (test_case .eq. '5') then + elseif (test_case == '5') then call openbf(11, 'FIRST', 12) call rewnbf(11, 0) endif - elseif (sub_name .eq. 'rtrcpt') then - if (test_case .eq. '1') then + elseif (sub_name == 'rtrcpt') then + if (test_case == '1') then open(unit = 11, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'IN', 11) call rtrcpt(11, iyr, imo, idy, ihr, imi, iret) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 open(unit = 12, file = 'testfiles/IN_2', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) call rtrcpt(11, iyr, imo, idy, ihr, imi, iret) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then open(unit = 12, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(12, 'OUT', 10) call rtrcpt(11, iyr, imo, idy, ihr, imi, iret) endif - elseif (sub_name .eq. 'seqsdx') then + elseif (sub_name == 'seqsdx') then open(unit = 11, file = 'testfiles/test_bort_OUT', form = 'UNFORMATTED', iostat = ios) - if (ios .ne. 0) stop 3 - if ((test_case .eq. '14') .or. (test_case .eq. '15')) then - if (isetprm('MAXCD',22) .ne. 0) stop 3 + if (ios /= 0) stop 3 + if ((test_case == '14') .or. (test_case == '15')) then + if (isetprm('MAXCD',22) /= 0) stop 3 open(unit = 12, file = 'testfiles/OUT_6_bufrtab', iostat = ios) else open(unit = 12, file = 'testfiles/OUT_2_bufrtab', iostat = ios) endif - if (ios .ne. 0) stop 3 + if (ios /= 0) stop 3 call openbf(11, 'OUT', 12) - if (test_case .eq. '1') then + if (test_case == '1') then card = '| DUMMYD | |' call seqsdx(card, 1) - elseif (test_case .eq. '2') then + elseif (test_case == '2') then card = '| DRPSTAK | |' call seqsdx(card, 1) - elseif (test_case .eq. '3') then + elseif (test_case == '3') then card = '| DRPSTAK | EPSILON) stop 40 @@ -77,12 +77,12 @@ program test_ufbcup call ufbint(12, hdr, 1, 1, iret, 'T29') if (abs(hdr(1, 1) - 512.0) > EPSILON) stop 45 call ufbint(12, hdr, 1, 1, iret, 'ITP') - if (ibfms(hdr(1, 1)) .ne. 1) stop 46 + if (ibfms(hdr(1, 1)) /= 1) stop 46 ! Read a replication. call ufbrep(12, hdr, 1, 1, iret, '{PLEVL}') - if (iret .ne. 1) stop 50 - if (hdr(1, 1) .ne. 0 .or. iret .ne. 1) stop 50 + if (iret /= 1) stop 50 + if (hdr(1, 1) /= 0 .or. iret /= 1) stop 50 ! Close the files. call closbf(12) diff --git a/test/test_ufbrw.F90 b/test/test_ufbrw.F90 index 8d0b9814..459f6395 100644 --- a/test/test_ufbrw.F90 +++ b/test/test_ufbrw.F90 @@ -7,13 +7,13 @@ ! ! Adding additional testing in ufbrw ! -! J Woollen 4/14/23 +! J Woollen 4/14/23 program test_ufbrw - character(255)file + character(255)file character(55) brr(56),line,str1,str2 - character(20) cond + character(20) cond character(8) subset real(8) arr(10,255) @@ -124,7 +124,7 @@ program test_ufbrw call openbf(20,'IN ',20) call openbf(50,'OUT',20) - + write(55,*);write(55,*)'read/write from unit 20' do while(ireadmg(20,subset,idate)==0) @@ -142,7 +142,7 @@ program test_ufbrw call closbf(50) open(50,file='ufbrw_bufr_out',form='unformatted') - call openbf(50,'IN',50) + call openbf(50,'IN',50) write(55,*);write(55,*)'read/write from unit 50' @@ -160,13 +160,13 @@ program test_ufbrw ! verify the testfile contents against output stored in brr array strings - do n=1,56 + do n=1,56 read(55,'(a55)',iostat=iret) line call strsuc(line ,str1,len1) call strsuc(brr(n),str2,len2) if(n<=55.and.iret==0.and.str1/=str2) then - print*,"str1:",str1 - print*,"str2:",str2 + print*,"str1:",str1 + print*,"str2:",str2 stop 98 elseif(n>55.and.iret==0) then stop 99 diff --git a/utils/binv.F90 b/utils/binv.F90 index 5cfc6812..c2e18fef 100644 --- a/utils/binv.F90 +++ b/utils/binv.F90 @@ -50,13 +50,13 @@ PROGRAM BINV ! --------------------------------------- CALL OPENBF(LUNBF,'IN',LUNBF) - DO WHILE(IREADMG(LUNBF,SUBSET,IDATE).EQ.0) + DO WHILE(IREADMG(LUNBF,SUBSET,IDATE)==0) ISUB = 0 DO I=1,NSUB - IF(SUBSET.EQ.SUB(I)) ISUB = I + IF(SUBSET==SUB(I)) ISUB = I ENDDO - IF(ISUB.EQ.0) THEN - IF(NSUB+1.GT.MAXSUB) CALL BORT('NSUB TOO BIG') + IF(ISUB==0) THEN + IF(NSUB+1>MAXSUB) CALL BORT('NSUB TOO BIG') SUB(NSUB+1) = SUBSET NSUB = NSUB+1 ISUB = NSUB @@ -76,7 +76,7 @@ PROGRAM BINV xmsg = ninv(1,j) xsub = ninv(2,j) print'(a8,2x,2(i10,4x),i11,4x,f8.2)',sub(j),(ninv(i,j),i=1,3),xsub/xmsg - IF(J.GT.1) THEN + IF(J>1) THEN NINV(1,1) = NINV(1,1)+NINV(1,J) NINV(2,1) = NINV(2,1)+NINV(2,J) NINV(3,1) = NINV(3,1)+NINV(3,J) diff --git a/utils/cmpbqm.F90 b/utils/cmpbqm.F90 index f930cc8e..20494d62 100644 --- a/utils/cmpbqm.F90 +++ b/utils/cmpbqm.F90 @@ -43,7 +43,7 @@ PROGRAM CMPBQM ! ------------------------ call get_command_argument(1,file); file=trim(adjustl(file)) - if (file == '') then + if (file == '') then print *, 'Usage: Usage: cmpbqm will print prep inventory by variable, report type, and qc mark' call exit(2) endif @@ -56,10 +56,10 @@ PROGRAM CMPBQM open(lubfr,file=file,form='unformatted') CALL OPENBF(LUBFR,'IN',LUBFR) CALL READMG(LUBFR,SUBSET,IDATE,IRET) - IF(IRET.NE.0) GOTO 900 + IF(IRET/=0) GOTO 900 WRITE(DATE,'(I8)') IDATE DO I=1,8 - IF(DATE(I:I).EQ.' ') DATE(I:I) = '0' + IF(DATE(I:I)==' ') DATE(I:I) = '0' ENDDO PRINT'(''DATA VALID AT '',A8)',DATE @@ -67,9 +67,9 @@ PROGRAM CMPBQM ! ---------------------------- 10 CALL READSB(LUBFR,IRET) - IF(IRET.NE.0) THEN + IF(IRET/=0) THEN CALL READMG(LUBFR,SUBSET,IDATE,IRET) - IF(IRET.NE.0) GOTO 100 + IF(IRET/=0) GOTO 100 CALL UFBCNT(LUBFR,IREC,ISUB) GOTO 10 ENDIF @@ -83,15 +83,15 @@ PROGRAM CMPBQM DO L=1,NLEV DO K=1,7 IQ = -1 - IF(K.EQ.5) OBS(5,L) = MAX(OBS(5,L),OBS(8,L)) - IF(OBS(K,L).LT.VMAX .AND. QMS(K,L).LT.VMAX) THEN + IF(K==5) OBS(5,L) = MAX(OBS(5,L),OBS(8,L)) + IF(OBS(K,L)=VMAX) THEN IQ = 16 - ELSEIF(OBS(K,L).GE.VMAX .AND. QMS(K,L).LT.VMAX) THEN + ELSEIF(OBS(K,L)>=VMAX .AND. QMS(K,L)=0) KNT(KX,K,IQ) = KNT(KX,K,IQ)+1 ENDDO ENDDO @@ -107,13 +107,13 @@ PROGRAM CMPBQM ITOT = 0; igood=0; ifail=0 DO IQ=0,17 ITOT = ITOT+KNT(KX,K,IQ) - if(iq.le.3) then + if(iq<=3) then igood=igood+KNT(KX,K,IQ) - elseif(iq.le.7) then + elseif(iq<=7) then ifail=ifail+KNT(KX,K,IQ) endif ENDDO - IF(ITOT.GT.0) PRINT 101,KX,ITOT,igood,ifail,(KNT(KX,K,IQ),IQ=8,17) + IF(ITOT>0) PRINT 101,KX,ITOT,igood,ifail,(KNT(KX,K,IQ),IQ=8,17) 101 FORMAT(I3,I6,2('|', I6),& 2('|', I6),& 1('|',6I6),& diff --git a/utils/debufr.F90 b/utils/debufr.F90 index 124017a9..21b0b617 100644 --- a/utils/debufr.F90 +++ b/utils/debufr.F90 @@ -132,16 +132,16 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps call crbmg_c ( bfmg, mxbf, nbyt, ierr ) - if ( ierr .ne. 0 ) then + if ( ierr /= 0 ) then - if ( ierr .eq. -1 ) then + if ( ierr == -1 ) then write ( 51, fmt = '( /, A, I7, A, I9, A )') 'Reached end of BUFR file; it contained a total of', nmsg, & ' messages and', nsubt, ' subsets' else write ( 51, fmt = '( /, A, I4 )' ) 'Error while reading BUFR file; the return code from CRBMG = ', ierr end if - if ( ( basic_f .eq. 'N' ) .and. ( opened .eq. 'Y' ) ) then + if ( ( basic_f == 'N' ) .and. ( opened == 'Y' ) ) then write (51, fmt = '( /, A, / )' ) 'Here is the DX table that was generated:' call dxdump ( lunit, 51 ) end if @@ -156,26 +156,26 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps return end if - if ( opened .eq. 'N' ) then + if ( opened == '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 + if ( ( isetprm ( 'MAXCD', mxds3 ) /= 0 ) .or. ( isetprm ( 'MXMSGL', mxbf ) /= 0 ) .or. & + ( isetprm ( 'MAXSS', 300000 ) /= 0 ) .or. ( isetprm ( 'NFILES', 2 ) /= 0 ) ) then print *, 'Error: Bad return from isetprm' return end if ! Process any dynamic allocation parameters that were passed in on the command line. - if ( prmstg_f(1:8) .ne. 'NULLPSTG' ) then + if ( prmstg_f(1:8) /= 'NULLPSTG' ) then call parstr ( prmstg_f, ptag, mxprms, nptag, ',', .false. ) - if ( nptag .gt. 0 ) then + if ( nptag > 0 ) then do ii = 1, nptag call parstr ( ptag(ii), pvtag, 2, npvtag, '=', .false. ) - if ( npvtag .eq. 2 ) then + if ( npvtag == 2 ) then call strsuc ( pvtag(1), cprmnm, lcprmnm ) call strnum ( pvtag(2), ipval, iersn ) - if ( ( lcprmnm .gt. 0 ) .and. ( iersn .ne. -1 ) ) then - if ( isetprm ( cprmnm(1:lcprmnm), ipval ) .ne. 0 ) then + if ( ( lcprmnm > 0 ) .and. ( iersn /= -1 ) ) then + if ( isetprm ( cprmnm(1:lcprmnm), ipval ) /= 0 ) then print *, 'Error: Bad return from isetprm for parameter: ', cprmnm(1:lcprmnm) return end if @@ -187,13 +187,13 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps ! Decide how to process the file. - if ( ( idxmsg ( ibfmg ) .eq. 1 ) .and. ( forcemt_f .eq. 'N' ) ) then + if ( ( idxmsg ( ibfmg ) == 1 ) .and. ( forcemt_f == 'N' ) ) then ! The first message in the file is a DX dictionary message, so assume there's an embedded table at the ! front of the file, and use this table to decode it. call openbf ( lunit, 'INUL', lunit ) - else if ( ( tblfil_f(1:8) .ne. 'NULLFILE' ) .and. ( forcemt_f .eq. 'N' ) ) then + else if ( ( tblfil_f(1:8) /= 'NULLFILE' ) .and. ( forcemt_f == 'N' ) ) then ! A DX dictionary tables file was specified on the command line, so use it to decode the BUFR file. @@ -203,7 +203,7 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps return end if open ( unit = 91, file = tblfil_f, iostat = ier ) - if ( ier .ne. 0 ) then + if ( ier /= 0 ) then print *, 'Error: Could not open file ', tblfil_f return endif @@ -219,10 +219,10 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps opened = 'Y' call mtinfo ( tbldir_f, 90, 91 ) - if ( cfms_f .eq. 'Y' ) call codflg ( 'Y' ) + if ( cfms_f == 'Y' ) call codflg ( 'Y' ) end if - if ( basic_f .eq. 'N' ) then + if ( basic_f == 'N' ) then ! Pass the message to the decoder. @@ -231,7 +231,7 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps ! If this is a DX dictionary message, then don't generate any output unless master tables are being used for decoding. - if ( ( idxmsg ( ibfmg ) .ne. 1 ) .or. ( usemt .eq. 'Y' ) ) then + if ( ( idxmsg ( ibfmg ) /= 1 ) .or. ( usemt == 'Y' ) ) then nmsg = nmsg + 1 @@ -250,18 +250,18 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps iogce = iupbs01 ( ibfmg, 'OGCE' ) igses = iupbs01 ( ibfmg, 'GSES' ) - if ( ( basic_f .eq. 'Y' ) .or. ( cfms_f .eq. 'N' ) ) then + if ( ( basic_f == 'Y' ) .or. ( cfms_f == '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 + if ( ierorgc == 0 ) then write ( 51, fmt= '( A, I5, 3A )' ) ' Originating center: ', iogce, ' (= ', cmorgc(1:lcmorgc), ')' else write ( 51, fmt= '( A, I5 )' ) ' Originating center: ', iogce end if call getcfmng ( lunit, 'GSES', igses, 'ORIGC', iogce, cmgses, lcmgses, iergses ) - if ( iergses .eq. 0 ) then + if ( iergses == 0 ) then write ( 51, fmt= '( A, I4, 3A )' ) ' Originating subcenter: ', igses, ' (= ', cmgses(1:lcmgses), ')' else write ( 51, fmt= '( A, I4 )' ) ' Originating subcenter: ', igses @@ -270,7 +270,7 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps write ( 51, fmt= '( A, I4 )' ) ' Update sequence numbr: ', iupbs01 ( ibfmg, 'USN' ) - if ( iupbs01 ( ibfmg, 'ISC2' ) .eq. 1 ) then + if ( iupbs01 ( ibfmg, 'ISC2' ) == 1 ) then write ( 51, fmt = '( A )') ' Section 2 present?: Yes' else write ( 51, fmt = '( A )') ' Section 2 present?: No' @@ -279,25 +279,25 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps mtyp = iupbs01 ( ibfmg, 'MTYP' ) msbt = iupbs01 ( ibfmg, 'MSBT' ) msbti = iupbs01 ( ibfmg, 'MSBTI' ) - if ( ( basic_f .eq. 'Y' ) .or. ( cfms_f .eq. 'N' ) ) then + if ( ( basic_f == 'Y' ) .or. ( cfms_f == '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 + if ( iermtyp == 0 ) then write ( 51, fmt= '( A, I4, 3A )' ) ' Data category: ', mtyp, ' (= ', cmmtyp(1:lcmmtyp), ')' else write ( 51, fmt= '( A, I4 )' ) ' Data category: ', mtyp end if call getcfmng ( lunit, 'TABLASL', msbt, 'TABLAT', mtyp, cmmsbt, lcmmsbt, iermsbt ) - if ( ( iermsbt .eq. 0 ) .and. ( iogce .eq. 7 ) ) then + if ( ( iermsbt == 0 ) .and. ( iogce == 7 ) ) then write ( 51, fmt= '( A, I4, 3A )' ) ' Local subcategory: ', msbt, ' (= ', cmmsbt(1:lcmmsbt), ')' else write ( 51, fmt= '( A, I4 )' ) ' Local subcategory: ', msbt end if call getcfmng ( lunit, 'TABLASS', msbti, 'TABLAT', mtyp, cmmsbti, lcmmsbti, iermsbti ) - if ( iermsbti .eq. 0 ) then + if ( iermsbti == 0 ) then write ( 51, fmt= '( A, I4, 3A )' ) ' Internatl subcategory: ', msbti, ' (= ', cmmsbti(1:lcmmsbti), ')' else write ( 51, fmt= '( A, I4 )' ) ' Internatl subcategory: ', msbti @@ -312,9 +312,9 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps 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 + if ( ( iogce == 7 ) .and. ( igses == 3 ) ) then call rtrcptb ( ibfmg, iryr, irmo, irdy, irhr, irmi, irtret ) - if ( irtret .eq. 0 ) then + if ( irtret == 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 @@ -329,13 +329,13 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps write ( 51, fmt= '( /, A, I4 )' ) ' Number of data subsets: ', nsub nsubt = nsubt + nsub - if ( iupbs3 ( ibfmg, 'IOBS' ) .eq. 1 ) then + if ( iupbs3 ( ibfmg, 'IOBS' ) == 1 ) then write ( 51, fmt = '( A )') ' Data are observed?: Yes' else write ( 51, fmt = '( A )') ' Data are observed?: No' end if - if ( iupbs3 ( ibfmg, 'ICMP' ) .eq. 1 ) then + if ( iupbs3 ( ibfmg, 'ICMP' ) == 1 ) then write ( 51, fmt = '( A )') ' Data are compressed?: Yes' else write ( 51, fmt = '( A )') ' Data are compressed?: No' @@ -347,13 +347,13 @@ subroutine fdebufr_c ( ofile, lenof, tbldir, lentd, tblfil, lentf, prmstg, lenps write ( 51, fmt = '( 5X, I4, A, A6)' ) jj, ": ", cds3 ( jj ) end do - if ( ( basic_f .eq. 'N' ) .and. ( ierme .ge. 0 ) ) then + if ( ( basic_f == 'N' ) .and. ( ierme >= 0 ) ) then ! Decode and output the data from Section 4. write ( 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 ) + do while ( ireadsb ( lunit ) == 0 ) call ufdump ( lunit, 51 ) end do end if diff --git a/utils/readbp.F90 b/utils/readbp.F90 index eebccb7c..d0bea509 100644 --- a/utils/readbp.F90 +++ b/utils/readbp.F90 @@ -138,7 +138,7 @@ PROGRAM READBP do while(ireadsb(lubfr)==0) call ufbcnt(lubfr,irec,isub) - IF(msg.ne.' ' .and. msg.ne.subset) exit + IF(msg/=' ' .and. msg/=subset) exit if(dump) then call ufdump(lubfr,6) @@ -154,23 +154,23 @@ PROGRAM READBP jrt = nint(hdr(6)) jtp = nint(hdr(7)) jkx = nint(hdr(8)) - IF(STA.NE.' ' .AND. STA.NE.SID(1:nsta)) cycle - IF(irt.ne.0 .and. irt.ne.jrt) cycle - IF(itp.ne.0 .and. itp.ne.jtp) cycle - IF(ikx.ne.0 .and. ikx.ne.jkx) cycle + IF(STA/=' ' .AND. STA/=SID(1:nsta)) cycle + IF(irt/=0 .and. irt/=jrt) cycle + IF(itp/=0 .and. itp/=jtp) cycle + IF(ikx/=0 .and. ikx/=jkx) cycle if(window) then - if(.not.(xob.ge.x1 .and. xob.le.x2))cycle - if(.not.(yob.ge.y1 .and. yob.le.y2))cycle + if(.not.(xob>=x1 .and. xob<=x2))cycle + if(.not.(yob>=y1 .and. yob<=y2))cycle endif CALL UFBINT(LUBFR,OBS,10,255,NLEV,OSTR) CALL UFBINT(LUBFR,QMS,10,255,NLEQ,QSTR) - IF(NLEV.NE.NLEQ) STOP 'NLEV<>NLEQ' + IF(NLEV/=NLEQ) STOP 'NLEV<>NLEQ' ! MOVE CAT 8 DATA TO PRINT RANGE ! ------------------------------ DO L=1,NLEV - IF(OBS(1,L).EQ.8) THEN + IF(OBS(1,L)==8) THEN OBS(2,L) = OBS(9,L) OBS(3,L) = OBS(10,L) ENDIF diff --git a/utils/readmp.F90 b/utils/readmp.F90 index 433a2cbb..ca0cd9fa 100644 --- a/utils/readmp.F90 +++ b/utils/readmp.F90 @@ -39,12 +39,12 @@ program readmp ! open the file to bufr and dump the subsets to standard outout one at a time call openbf(lunit,'IN',lunit) - do while(ireadmg(lunit,subset,idate).eq.0) - do while(ireadsb(lunit).eq.0) + do while(ireadmg(lunit,subset,idate)==0) + do while(ireadsb(lunit)==0) print*,'message date=',i4dy(idate) call ufdump(lunit,6) - if(go.ne.'q') read(5,'(a)') go - if(go.eq.'q') stop + if(go/='q') read(5,'(a)') go + if(go=='q') stop enddo enddo diff --git a/utils/sinv.F90.in b/utils/sinv.F90.in index 05c6017e..a3569b52 100644 --- a/utils/sinv.F90.in +++ b/utils/sinv.F90.in @@ -88,7 +88,7 @@ program sinv write(*,*) do i=0,1000 do j=0,1000 - if(isat(i,j).gt.0) then + if(isat(i,j)>0) then jsat=jsat+isat(i,j) call satcode(lunbf,i,ci,j,cj) write(*,'(i3.3,2x,a,2x,i10,2x,i3.3,6x,a)')i,ci,isat(i,j),j,trim(adjustl(cj))