diff --git a/src/drfini.f b/src/drfini.f index 66efd770..c5da6310 100644 --- a/src/drfini.f +++ b/src/drfini.f @@ -4,24 +4,23 @@ C> C> @author J. Woollen @date 2002-05-14 +C> Initialize replication factors for delayed replication sequences. +C> C> This subroutine explicitly initializes delayed replication factors C> and allocates a corresponding amount of space within internal arrays, C> thereby allowing the subsequent use of subroutine ufbseq() to write C> data into delayed replication sequences. C> -C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR -C> file -C> @param[in] MDRF -- integer(*): Array of delayed replication factors, -C> in one-to-one correspondence with the number -C> of occurrences of DRFTAG within the overall -C> subset definition, and explicitly defining -C> how much space (i.e. how many replications) -C> to allocate within each successive occurrence -C> @param[in] NDRF -- integer: Number of delayed replication factors -C> within MDRF -C> @param[in] DRFTAG -- character*(*): Table D sequence mnemonic, -C> bracketed by appropriate delayed replication -C> notation (e.g. {}, () OR <>) +C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file. +C> @param[in] MDRF - integer(*): Array of delayed replication factors, +C> in one-to-one correspondence with the number of occurrences of DRFTAG +C> within the overall subset definition, and explicitly defining how much +C> space (i.e. how many replications) to allocate within each successive +C> occurrence. +C> @param[in] NDRF - integer: Number of delayed replication factors +C> within MDRF. +C> @param[in] DRFTAG - character*(*): Table D sequence mnemonic, bracketed +C> by appropriate delayed replication notation (e.g. {}, () OR <>) C> C> Logical unit LUNIT should have already been opened for output C> operations (i.e. writing/encoding BUFR) via a previous call to @@ -72,7 +71,7 @@ RECURSIVE SUBROUTINE DRFINI(LUNIT,MDRF,NDRF,DRFTAG) CALL X84(LUNIT,MY_LUNIT,1) CALL X84(NDRF,MY_NDRF,1) - CALL X84(MDRF,MY_MDRF,MY_NDRF) + CALL X84(MDRF,MY_MDRF,MY_NDRF(1)) CALL DRFINI(MY_LUNIT,MY_MDRF,MY_NDRF,DRFTAG) IM8B=.TRUE. diff --git a/src/idn30.f b/src/idn30.f index c1fc1461..be2e05b3 100644 --- a/src/idn30.f +++ b/src/idn30.f @@ -1,11 +1,11 @@ C> @file C> @brief Convert an FXY value from a character string to the -C> WMO bit-wise represtation. +C> WMO bit-wise representation. C> C> @author J. Woollen @date 1994-01-06 C> Convert an FXY value from a character string to the -C> WMO bit-wise represtation. +C> WMO bit-wise representation. C> C> For an description of the WMO bit-wise representation of the FXY C> value, see ifxy(). diff --git a/src/igetrfel.f b/src/igetrfel.f index 140b94c2..a7c5484d 100644 --- a/src/igetrfel.f +++ b/src/igetrfel.f @@ -210,7 +210,7 @@ INTEGER FUNCTION IGETRFEL ( N, LUN ) . ( TAG(NODRFE)(1:8) .EQ. TAGNRV(II) ) .AND. . ( NODRFE .GE. ISNRV(II) ) .AND. . ( NODRFE .LE. IENRV(II) ) ) THEN - IRF(NODE) = NRV(II) + IRF(NODE) = INT(NRV(II)) RETURN END IF END DO diff --git a/src/iupm.f b/src/iupm.f index 75d74340..fbb33595 100644 --- a/src/iupm.f +++ b/src/iupm.f @@ -7,9 +7,9 @@ C> specified number of bits of a character string, starting C> with the first bit of the first byte of the string. C> -C> @param[in] CBAY -- character*(*): String -C> @param[in] NBITS -- integer: Number of bits from CBAY to be decoded -C> @returns iupm -- integer: Decoded value +C> @param[in] CBAY - character*(*): String +C> @param[in] NBITS - integer: Number of bits from CBAY to be decoded +C> @returns iupm - integer: Decoded value C> C> @author J. Woollen @date 1994-01-06 RECURSIVE FUNCTION IUPM(CBAY,NBITS) RESULT(IRET) @@ -39,6 +39,7 @@ RECURSIVE FUNCTION IUPM(CBAY,NBITS) RESULT(IRET) RETURN ENDIF + IRET = 0 IF(NBITS.GT.NBITW) GOTO 900 CINT = CBAY INT(1) = IREV(INT(1)) diff --git a/src/nemspecs.f b/src/nemspecs.f index 42006235..97086821 100644 --- a/src/nemspecs.f +++ b/src/nemspecs.f @@ -120,7 +120,7 @@ RECURSIVE SUBROUTINE NEMSPECS . ( TAGN(1:8) .EQ. TAGNRV(JJ) ) .AND. . ( NODE .GE. ISNRV(JJ) ) .AND. . ( NODE .LE. IENRV(JJ) ) ) THEN - NREF = NRV(JJ) + NREF = INT(NRV(JJ)) RETURN END IF END DO diff --git a/src/nevn.f b/src/nevn.f index 025341d4..41d1ad08 100644 --- a/src/nevn.f +++ b/src/nevn.f @@ -57,7 +57,7 @@ FUNCTION NEVN(NODE,LUN,INV1,INV2,I1,I2,I3,USR) INVN = INVWIN(NDRS,LUN,INV1,INV2) IF(INVN.EQ.0) GOTO 900 - NEVN = VAL(INVN,LUN) + NEVN = NINT(VAL(INVN,LUN)) IF(NEVN.GT.I3) GOTO 901 C SEARCH EACH STACK LEVEL FOR THE REQUESTED NODE AND COPY THE VALUE @@ -67,7 +67,7 @@ FUNCTION NEVN(NODE,LUN,INV1,INV2,I1,I2,I3,USR) DO L=1,NEVN N1 = N2 - N2 = N2 + VAL(N1,LUN) + N2 = N2 + NINT(VAL(N1,LUN)) DO N=N1,N2 IF(INV(N,LUN).EQ.NODE) USR(1,1,L) = VAL(N,LUN) ENDDO diff --git a/src/newwin.f b/src/newwin.f index f4399434..e8d5db19 100644 --- a/src/newwin.f +++ b/src/newwin.f @@ -1,7 +1,7 @@ C> @file C> @brief Computes the ending index of the window. C> -C> @author Woollen @date 1994-01-06 +C> @author J. Woollen @date 1994-01-06 C> Given an index within the internal jump/link table which C> points to the start of an "rpc" window (which is the iteration of an 8-bit @@ -17,7 +17,7 @@ C> @param[in] IWIN - integer: starting index of window iteration. C> @param[out] JWIN - integer: ending index of window iteration. C> -C> @author WOOLLEN @date 1994-01-06 +C> @author J. Woollen @date 1994-01-06 SUBROUTINE NEWWIN(LUN,IWIN,JWIN) USE MODA_USRINT @@ -40,7 +40,7 @@ SUBROUTINE NEWWIN(LUN,IWIN,JWIN) NODE = INV(IWIN,LUN) IF(LSTJPB(NODE,LUN,'RPC').NE.NODE) GOTO 900 - JWIN = IWIN+VAL(IWIN,LUN) + JWIN = IWIN+NINT(VAL(IWIN,LUN)) C EXITS C ----- diff --git a/src/nxtwin.f b/src/nxtwin.f index bb63b38b..0204fb1f 100644 --- a/src/nxtwin.f +++ b/src/nxtwin.f @@ -1,7 +1,7 @@ C> @file C> @brief Computes the start and end indices of the next window. C> -C> @author WOOLLEN @date 1994-01-06 +C> @author J. Woollen @date 1994-01-06 C> Given indices within the internal jump/link table which C> point to the start and end of an "rpc" window (which is an iteration of @@ -19,7 +19,7 @@ C> - on input, contains ending index of current window iteration. C> - on output, contains ending index of next window iteration. C> -C> @author WOOLLEN @date 1994-01-06 +C> @author J. Woollen @date 1994-01-06 SUBROUTINE NXTWIN(LUN,IWIN,JWIN) USE MODA_USRINT @@ -43,7 +43,7 @@ SUBROUTINE NXTWIN(LUN,IWIN,JWIN) IWIN = 0 ELSE IWIN = JWIN - JWIN = IWIN+VAL(IWIN,LUN) + JWIN = IWIN+NINT(VAL(IWIN,LUN)) ENDIF C EXITS diff --git a/src/parusr.f b/src/parusr.f index 6843abf8..1e54508c 100644 --- a/src/parusr.f +++ b/src/parusr.f @@ -86,7 +86,7 @@ SUBROUTINE PARUSR(STR,LUN,I1,IO) VAL = IVLS(I) IVLS(I) = IVLS(J) - IVLS(J) = VAL + IVLS(J) = NINT(VAL) ENDIF ENDDO ENDDO diff --git a/src/pkb8.f b/src/pkb8.f index 9167e4ad..02832283 100644 --- a/src/pkb8.f +++ b/src/pkb8.f @@ -43,12 +43,10 @@ subroutine pkb8(nval,nbits,ibay,ibit) if(nbits<0 ) call bort('bufrlib: pkb8 - nbits < zero !!!!!') if(nbits>64) call bort('bufrlib: pkb8 - nbits > 64 !!!!!') - if(nbitw==32) then - nval8=nval - nval4=nvals(2); call pkb(nval4,max(nbits-nbitw,0),ibay,ibit) - nval4=nvals(1); call pkb(nval4,min(nbits,nbitw ),ibay,ibit) - else - call pkb(nval,nbits,ibay,ibit) - endif + nval8=nval + nval4=nvals(2) + call pkb(nval4,max(nbits-nbitw,0),ibay,ibit) + nval4=nvals(1) + call pkb(nval4,min(nbits,nbitw ),ibay,ibit) end subroutine diff --git a/src/rdcmps.f b/src/rdcmps.f index a9bf5493..77dad8a4 100644 --- a/src/rdcmps.f +++ b/src/rdcmps.f @@ -91,7 +91,8 @@ SUBROUTINE RDCMPS(LUN) IVAL = LREF+NINC ENDIF IF(ITYP.EQ.1) THEN - NBMP=IVAL; CALL USRTPL(LUN,N,NBMP) + NBMP=INT(IVAL) + CALL USRTPL(LUN,N,NBMP) GOTO 1 ENDIF IF(IVAL.LT.LPS(NBIT)) VAL(N,LUN) = UPS(IVAL,NODE) diff --git a/src/ufbget.f b/src/ufbget.f index d1bc3391..54ccb4ab 100644 --- a/src/ufbget.f +++ b/src/ufbget.f @@ -109,7 +109,8 @@ RECURSIVE SUBROUTINE UFBGET(LUNIT,TAB,I1,IRET,STR) GOTO 20 ELSEIF(ITP(NODE).EQ.1) THEN CALL UPB8(IVAL,NBIT(N),MBIT(N),MBAY(1,LUN)) - NBMP=IVAL; CALL USRTPL(LUN,N,NBMP) + NBMP=INT(IVAL) + CALL USRTPL(LUN,N,NBMP) GOTO 10 ENDIF ENDDO diff --git a/src/ufbmex.f b/src/ufbmex.f index 512746b1..7f2eb84b 100644 --- a/src/ufbmex.f +++ b/src/ufbmex.f @@ -22,22 +22,18 @@ C> with actual filenames on the local system, typically via a Fortran C> "OPEN" statement. C> -C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR -C> file -C> @param[in] LUNDX -- integer: Fortran logical unit number -C> containing DX BUFR table information -C> associated with BUFR messages in LUNIT -C> @param[in] INEW -- integer: Processing option -C> - 0 = Initialize the internal arrays, then -C> read all BUFR messages from LUNIT into -C> internal arrays -C> - Otherwise, read all BUFR messages from LUNIT -C> and append them to the existing messages -C> within the internal arrays -C> @param[out] IRET -- integer: Number of BUFR messages that were -C> read from LUNIT and stored into internal arrays -C> @param[out] MESG -- integer(*): Types of BUFR messages that were -C> read from LUNIT and stored into internal arrays +C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file. +C> @param[in] LUNDX - integer: Fortran logical unit number containing DX +C> BUFR table information associated with BUFR messages in LUNIT. +C> @param[in] INEW - integer: Processing option +C> - 0 = Initialize the internal arrays, then read all BUFR messages +C> from LUNIT into internal arrays +C> - Otherwise, read all BUFR messages from LUNIT and append them to the +C> existing messages within the internal arrays +C> @param[out] IRET - integer: Number of BUFR messages that were read +C> from LUNIT and stored into internal arrays. +C> @param[out] MESG - integer(*): Types of BUFR messages that were read +C> from LUNIT and stored into internal arrays. C> C> @author J. Woollen @date 2012-01-26 RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) @@ -53,7 +49,8 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) CHARACTER*128 BORT_STR,ERRSTR - INTEGER MESG(*), IRET(*) + INTEGER MESG(*), IRET(*), LUNIT(*), LUNDX(*), INEW(*) + INTEGER MY_LUNIT(1), MY_LUNDX(1), MY_INEW(1) C----------------------------------------------------------------------- C----------------------------------------------------------------------- @@ -67,7 +64,7 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) CALL X84(LUNIT,MY_LUNIT,1) CALL X84(LUNDX,MY_LUNDX,1) CALL X84(INEW,MY_INEW,1) - IF (MY_INEW.EQ.0) THEN + IF (MY_INEW(1).EQ.0) THEN NMESG = 0 ELSE NMESG = MSGP(0) @@ -86,7 +83,7 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) CALL OPENBF(LUNIT,'IN',LUNDX) - IF(INEW.EQ.0) THEN + IF(INEW(1).EQ.0) THEN MSGP(0) = 0 MUNIT = 0 MLAST = 0 @@ -192,7 +189,7 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) CALL CLOSBF(LUNIT) ELSE IF(MUNIT.NE.0) CALL CLOSBF(LUNIT) - IF(MUNIT.EQ.0) MUNIT = LUNIT + IF(MUNIT.EQ.0) MUNIT = LUNIT(1) ENDIF C EXITS @@ -200,6 +197,6 @@ RECURSIVE SUBROUTINE UFBMEX(LUNIT,LUNDX,INEW,IRET,MESG) RETURN 900 WRITE(BORT_STR,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '// - . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT + . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') NMSG+1,LUNIT(1) CALL BORT(BORT_STR) END diff --git a/src/ufbtab.f b/src/ufbtab.f index 76ee8d2f..a2e7c64c 100644 --- a/src/ufbtab.f +++ b/src/ufbtab.f @@ -228,7 +228,8 @@ RECURSIVE SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR) NBIT = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPB8(IVAL,NBIT,MBIT,MBAY(1,LUN)) - NBMP=IVAL; CALL USRTPL(LUN,N,NBMP) + NBMP=INT(IVAL) + CALL USRTPL(LUN,N,NBMP) ENDIF DO I=1,NNOD IF(NODS(I).EQ.NODE) THEN diff --git a/src/ufbtam.f b/src/ufbtam.f index f75ef6d9..dd90d79e 100644 --- a/src/ufbtam.f +++ b/src/ufbtam.f @@ -154,7 +154,8 @@ RECURSIVE SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR) NBIT = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPB8(IVAL,NBIT,MBIT,MBAY(1,LUN)) - NBMP=IVAL; CALL USRTPL(LUN,N,NBMP) + NBMP=INT(IVAL) + CALL USRTPL(LUN,N,NBMP) ENDIF DO I=1,NNOD IF(NODS(I).EQ.NODE) THEN diff --git a/src/upb8.f b/src/upb8.f index d01dea44..77f6d7e2 100644 --- a/src/upb8.f +++ b/src/upb8.f @@ -37,16 +37,15 @@ subroutine upb8(nval,nbits,ibit,ibay) !---------------------------------------------------------------------- if(nbits<0 ) call bort('BUFRLIB: UPB8 - nbits < zero !!!!!') - if(nbits>64) nval=0 - if(nbits>64) return - - if(nbitw==32) then - jbit=ibit; nvals=0 - call upb(nvals(2),max(nbits-nbitw,0),ibay,jbit) - call upb(nvals(1),min(nbitw,nbits ),ibay,jbit) - nval=nval8 - else - call upbb(nval,nbits,ibit,ibay) + if(nbits>64) then + nval=0 + return endif + jbit=ibit + nvals=0 + call upb(nvals(2),max(nbits-nbitw,0),ibay,jbit) + call upb(nvals(1),min(nbitw,nbits ),ibay,jbit) + nval=nval8 + end subroutine diff --git a/src/usrtpl.f b/src/usrtpl.f index ad93e887..01529e27 100644 --- a/src/usrtpl.f +++ b/src/usrtpl.f @@ -8,7 +8,7 @@ C> such as when the node is either a Table A mnemonic or a delayed C> replication factor. C> -C> @param[in] LUN - integer: I/O stream index into internal memory arrays. +C> @param[in] LUN - integer: file ID. C> @param[in] INVN - integer: starting jump/link table index of the node C> to be expanded within the subset template. C> @param[in] NBMP - integer: number of times by which INVN is to be @@ -74,7 +74,7 @@ SUBROUTINE USRTPL(LUN,INVN,NBMP) DRS = TYP(NODI) .EQ. 'DRS' DRB = TYP(NODI) .EQ. 'DRB' DRX = DRP .OR. DRS .OR. DRB - IVAL = VAL(INVN,LUN) + IVAL = NINT(VAL(INVN,LUN)) JVAL = 2**IBT(NODI)-1 VAL(INVN,LUN) = IVAL+NBMP IF(DRB.AND.NBMP.NE.1) GOTO 901 diff --git a/src/writlc.f b/src/writlc.f index df21c719..75aaac96 100644 --- a/src/writlc.f +++ b/src/writlc.f @@ -113,7 +113,8 @@ RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR) N = N+1 NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN - CALL USRTPL(LUN,N,MATX(N,NCOL)) + NBMP=INT(MATX(N,NCOL)) + CALL USRTPL(LUN,N,NBMP) ELSEIF(CTAG.EQ.TAG(NODE)) THEN ITAGCT = ITAGCT + 1 IF(ITAGCT.EQ.IOID) THEN @@ -223,8 +224,4 @@ RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR) 904 WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '// . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') CTAG,TYP(NODE) CALL BORT(BORT_STR) -905 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '// - . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'// - . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN) - CALL BORT(BORT_STR) END diff --git a/src/wrtree.f b/src/wrtree.f index 755b5aa6..099b7e2f 100644 --- a/src/wrtree.f +++ b/src/wrtree.f @@ -5,10 +5,10 @@ C> Pack a BUFR data subset. C> -C> This subroutine converts user numbers in the val array into scaled integers -C> and packs them into bit strings in the ibit subset output buffer. +C> This subroutine converts user numbers from the val array into scaled +C> integers and packs them into bit strings in the ibay array. C> -C> @param[in] lun -- integer: i/o stream index into internal memory arrays +C> @param[in] lun - integer: file ID. C> C> @author J. Woollen @date 1994-01-06 @@ -34,7 +34,7 @@ SUBROUTINE WRTREE(LUN) DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN - IVAL(N) = VAL(N,LUN) + IVAL(N) = NINT(VAL(N,LUN)) ELSEIF(TYP(NODE).EQ.'NUM') THEN IF(IBFMS(VAL(N,LUN)).EQ.0) THEN IVAL(N) = IPKS(VAL(N,LUN),NODE) diff --git a/test/intest7.F90 b/test/intest7.F90 index 5a94040d..09879d15 100644 --- a/test/intest7.F90 +++ b/test/intest7.F90 @@ -38,13 +38,13 @@ program intest7 integer*4 isetprm, igetprm, ireadns, ibfms - integer imgdt, iret, jdate, nr8v, idx, nsub, num, kmsg, ksub + integer imgdt, iret, jdate, nr8v, idx, nsub, kmsg, ksub integer mxr8pm, mxr8lv parameter ( mxr8pm = 15 ) parameter ( mxr8lv = 5 ) - real*8 r8arr (mxr8pm, mxr8lv), r8val + real*8 r8arr (mxr8pm, mxr8lv), r8val(1,1) character cmgtag*8 @@ -136,13 +136,14 @@ program intest7 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 17 - ! Test ufbcnt for 8-byte mode. + + ! Test ufbcnt. call ufbcnt(11, kmsg, ksub) if ( kmsg.ne.29 .or. ksub.ne.88) stop 18 ! 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 ) .ne. 1 ) ) stop 19 + if ( ( nsub .ne. 402 ) .or. ( ibfms ( r8val(1,1) ) .ne. 1 ) ) stop 19 print *, 'SUCCESS!' end program intest7 diff --git a/test/outtest2.F90 b/test/outtest2.F90 index 66a83b97..81abe3f4 100644 --- a/test/outtest2.F90 +++ b/test/outtest2.F90 @@ -11,11 +11,11 @@ program outtest2 integer nsc, nrf, nbt, ierns, nlv real*8 r8ymd(3,1), r8ltl(2,1), r8oth(10,1) - real*8 rpid, pkftbv, xmiss, getbmiss + real*8 rpid(1,1), pkftbv, xmiss, getbmiss character libvrsn*8, cpid*8 - equivalence (rpid,cpid) + equivalence (rpid(1,1),cpid) print *, 'Testing writing OUT_2 using OPENBF IO = APX and embedded tables' diff --git a/test/test_bort.F90 b/test/test_bort.F90 index 94bc09be..0d55e53b 100644 --- a/test/test_bort.F90 +++ b/test/test_bort.F90 @@ -29,8 +29,9 @@ program test_bort character*5 adn30 integer ibay(1), ibit, subset, jdate integer mtyp, msbt, inod - character*28 unit - integer iscl, iref, nseq, nmsub, ierr +! character*28 unit +! integer iscl, iref, nseq + integer nmsub, ierr integer mear, mmon, mday, mour, idate integer iyr, imo, idy, ihr, imi integer jdate1(5), jdump1(5) diff --git a/test/test_misc.F90 b/test/test_misc.F90 index 2698a6c0..3d52b06d 100644 --- a/test/test_misc.F90 +++ b/test/test_misc.F90 @@ -6,15 +6,19 @@ ! Ed Hartnett 3/17/23 program test_misc implicit none + integer lun, il, im + integer ios + integer num, iret + +#ifdef KIND_4 character*5 char5 character*5 adn30 integer a, idn30 - integer lun, il, im - integer ios integer ierr, nemock - integer numbck, num, iret + integer numbck integer mtyp, msbt, inod integer igetprm +#endif print *, 'Testing misc subroutines.' diff --git a/utils/cmpbqm.F90 b/utils/cmpbqm.F90 index c1f3cfa2..5cdbeba1 100644 --- a/utils/cmpbqm.F90 +++ b/utils/cmpbqm.F90 @@ -78,14 +78,14 @@ PROGRAM CMPBQM CALL UFBINT(LUBFR,OBS,8,255,NLEV,OBSTR) CALL UFBINT(LUBFR,QMS,8,255,NLEV,QMSTR) - KX = HDR(5) + KX = NINT(HDR(5)) 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 - IQ = QMS(K,L) + IQ = NINT(QMS(K,L)) ELSEIF(OBS(K,L).LT.VMAX .AND. QMS(K,L).GE.VMAX) THEN IQ = 16 ELSEIF(OBS(K,L).GE.VMAX .AND. QMS(K,L).LT.VMAX) THEN diff --git a/utils/readbp.F90 b/utils/readbp.F90 index d59aa1e6..5bdb5e46 100644 --- a/utils/readbp.F90 +++ b/utils/readbp.F90 @@ -24,7 +24,7 @@ PROGRAM READBP character(8) :: sid,sta,subset,msg,cmc(17) character(3) :: vars(8) integer :: iostat - real(8) :: hdr(10),obs(10,255),qms(10,255),qmc(17) + real(8) :: hdr(10),obs(10,255),qms(10,255),qmc(17),xob,yob logical :: window,steam,level,dump,hedr,exist EQUIVALENCE (HDR(1),SID) @@ -37,7 +37,6 @@ PROGRAM READBP DATA VARS/'LVL','CAT','POB','SPH','TOB','ZOB','UOB','VOB'/ DATA CMC /'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F','*'/ - DATA BMISS /10d10/ DATA LUBFR /8 / DATA STA /' '/ data msg /' '/ @@ -45,11 +44,11 @@ PROGRAM READBP data irt /0/ data itp /0/ data ikx /0/ - DATA WINDOW /.FALSE./ - DATA STEAM /.FALSE./ - DATA LEVEL /.FALSE./ - DATA DUMP /.FALSE./ - DATA HEDR /.FALSE./ + data window /.false./ + data steam /.false./ + data level /.false./ + data dump /.false./ + data hedr /.false./ !----------------------------------------------------------------------- !----------------------------------------------------------------------- @@ -150,19 +149,19 @@ PROGRAM READBP ! -------------------------------------- CALL UFBINT(LUBFR,HDR,10, 1,IRET,HSTR) - XOB = HDR(2) - YOB = HDR(3) - jrt = hdr(6) - jtp = hdr(7) - jkx = hdr(8) + xob = hdr(2) + yob = hdr(3) + 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(WINDOW) THEN - IF(.NOT.(XOB.GE.X1 .AND. XOB.LE.X2))cycle - IF(.NOT.(YOB.GE.Y1 .AND. YOB.LE.Y2))cycle - ENDIF + if(window) then + if(.not.(xob.ge.x1 .and. xob.le.x2))cycle + if(.not.(yob.ge.y1 .and. yob.le.y2))cycle + endif CALL UFBINT(LUBFR,OBS,10,255,NLEV,OSTR) CALL UFBINT(LUBFR,QMS,10,255,NLEQ,QSTR) @@ -199,7 +198,7 @@ PROGRAM READBP do l=1,nlev do i=1,7 - iqm = qms(i,l) + iqm = nint(qms(i,l)) if(iqm<0)iqm=10e8 iqm = min(iqm,16) qms(i,l) = qmc(iqm+1) diff --git a/utils/sinv.f90.in b/utils/sinv.f90.in index b4bb8060..5c10b0a4 100644 --- a/utils/sinv.f90.in +++ b/utils/sinv.f90.in @@ -8,10 +8,10 @@ !> @return 0 for success, error message otherwise. !> !> @author J Woollen @date 2010 -PROGRAM SINV +program sinv - PARAMETER (MAXA=16000000) - PARAMETER (MAXS=1000) + parameter (maxa=16000000) + parameter (maxs=1000) CHARACTER(255) FILE,tbldir CHARACTER(240) cmtdir @@ -32,7 +32,7 @@ PROGRAM SINV said=0 ssid=0 - ! get filename argument + ! get filename argument NARG=IARGC() IF(NARG<1) THEN @@ -44,7 +44,7 @@ PROGRAM SINV inquire(file=file,exist=exist) if (.not.exist) call bort(trim(file)//' does not exist') - ! define master table directory + ! define master table directory call openbf(lunbf,'FIRST',lunbf) ! need to call openbf prior to calling mtinfo IF(NARG==2) THEN ! arg 2 would be a user defined table dir @@ -71,8 +71,8 @@ PROGRAM SINV ! make a table of sat ids and sat instruments do n=1,max(nret,nrex) - i = said(n) - j = siid(n) + i = nint(said(n)) + j = nint(siid(n)) if(i>maxs.or.i<0) i=0 if(j>maxs.or.j<0) j=0 isat(i,j) = isat(i,j)+1 @@ -95,7 +95,7 @@ PROGRAM SINV write(*,'(/23x,i10/)') jsat -end program SINV +end program sinv !> @file !> @brief Looks in the BUFR tables to get meaning strings for satellite platform and instrument codes !>