diff --git a/docs/dx_tables.md b/docs/dx_tables.md
index 9a11313c0..1de9e5b91 100644
--- a/docs/dx_tables.md
+++ b/docs/dx_tables.md
@@ -14,8 +14,6 @@ information must be supplied, such as the example shown below. Such
files must be syntactically correct and also complete, in the sense
that all necessary mnemonics must exist and be fully-defined.
-
-
## Mnemonics
A mnemonic is a
@@ -26,8 +24,6 @@ descriptive, alphanumeric name for a data value.
sequences composed of one or more Table B (or other Table D) mnemonics and which are themselves
normally direct constituents of a particular Table A mnemonic.
-
-
At the highest level, we have a Table A mnemonic which completely
describes a type of data subset (e.g. rawinsonde, wind profiler,
etc.). This Table A mnemonic is defined as a sequence of one or more
@@ -38,13 +34,6 @@ described as a sequence of one or more Table B mnemonics which
correspond to basic data values (e.g. pressure, temperature, humidity,
etc.).
-
-
-The entire sequence of data values that constitute a particular type
-of data subset is fully and unambiguously defined.
-
-
-
Mnemonics never themselves appear within actual BUFR messages. Their
only purpose is to make it easier for users to interact with the
software by providing descriptive names to represent individual data
@@ -70,8 +59,6 @@ more Table B (or other Table D) mnemonics.
mnemonics are defined in terms of their scale factor, reference value,
bit width, and units.
-
-
### Section 1
diff --git a/docs/master_tables.md b/docs/master_tables.md
index 5120944ed..40327df2b 100644
--- a/docs/master_tables.md
+++ b/docs/master_tables.md
@@ -13,8 +13,6 @@ different value of IO is specified, then only a
[DX BUFR tables](@ref dfbftab) file is normally required, and master
BUFR tables are not needed.
-
-
Whenever master BUFR tables are used, they are read in by the BUFRLIB
software as a corresponding set of four system files, from a directory
on the local filesystem as specified within a separate preceding call
@@ -66,8 +64,6 @@ stored within Section 1 of each new message to be decoded. For more
details about the above values, see the discussion on Section 1 within
the official [WMO Manual 306, Volume I.2](@ref manual).
-
-
Now that we've discussed the content and naming conventions for master
BUFR table files, let's turn our attention to the actual format of
these files:
diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt
index de9dbef27..f6e55c938 100644
--- a/src/CMakeLists.txt
+++ b/src/CMakeLists.txt
@@ -5,20 +5,20 @@ set(CMAKE_INCLUDE_CURRENT_DIR ON)
list(APPEND fortran_src
modules_vars.F90 modules_arrs.F90 blocks.F90 borts.F90 capit.f cktaba.f
- compress.F90 cnved4.f codflg.f conwin.f copydata.F90 dumpdata.F90 drfini.f drstpl.f dxtable.F90
+ compress.F90 cnved4.f codflg.f conwin.f copydata.F90 dumpdata.F90 drstpl.f dxtable.F90
errwrt.F90 fstag.f getabdb.f getcfmng.f getlens.f gettagpr.f
- gettagre.f getvalnb.f getwin.f hold4wlc.f ifbget.f fxy.F90 iokoper.f ipks.f isize.f
+ gettagre.f getwin.f hold4wlc.f ifbget.f fxy.F90 iokoper.f ipks.f isize.f
igetrfel.f igetsc.f imrkopr.f invcon.f invmrg.f invtag.f invwin.f
jstnum.f lcmgdf.f jumplink.F90 mastertable.F90 missing.F90 mesgbc.f mesgbf.f mrginv.f
nemdefs.f nemock.f nemspecs.f nemtab.f nemtba.f nemtbax.f nemtbb.f nemtbd.f nenubd.f nevn.f newwin.f
numtab.f numtbd.f nvnwin.f nwords.f nxtwin.f openbt.f
parstr.f parusr.f parutg.f ftbvs.F90 pktdd.f posapx.f rcstpl.f rdtree.f
- readwritemg.F90 readwritesb.F90 readlc.f rewnbf.f rsvfvm.f s013vals.F90 tankrcpt.F90 setvalnb.f
+ readwritemg.F90 readwritesb.F90 readwriteval.F90 rewnbf.f rsvfvm.f s013vals.F90 tankrcpt.F90
standard.F90 stntbi.f stntbia.f strbtm.f strcln.f string.f strnum.F90 strsuc.F90
- trybump.f ufbcnt.f ufbcup.f ufbevn.f ufbget.f ufbin3.f ufbint.f ufbinx.f
- memmsgs.F90 ufbovr.f ufbpos.f ufbqcd.f ufbqcp.f ufbrep.f ufbrp.f
- ufbrw.f ufbseq.f ufbsp.f ufbstp.f ufbtab.f ciencode.F90 cidecode.F90
- ups.f uptdd.f usrtpl.f writlc.f wrtree.f arallocf.F90 irev.F90 openclosebf.F90
+ trybump.f ufbcnt.f ufbcup.f ufbevn.f ufbget.f ufbin3.f ufbinx.f
+ memmsgs.F90 ufbovr.f ufbpos.f ufbqcd.f ufbqcp.f
+ ufbtab.f ciencode.F90 cidecode.F90
+ ups.f uptdd.f usrtpl.f wrtree.f arallocf.F90 irev.F90 openclosebf.F90
bufr_interface.F90 bufr_c2f_interface.F90 x4884.F90 bufrlib.F90)
list(APPEND c_src
diff --git a/src/drfini.f b/src/drfini.f
deleted file mode 100644
index 0d2da25fa..000000000
--- a/src/drfini.f
+++ /dev/null
@@ -1,107 +0,0 @@
-C> @file
-C> @brief Initialize replication factors for delayed replication
-C> sequences.
-C>
-C> @author J. Woollen @date 2002-05-14
-
-C> Explicitly initialize delayed replication factors
-C> and allocate 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 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
-C> subroutine openbf(), and a message for output should have already
-C> been opened via a previous call to one of the
-C> [message-writing subroutines].
-C>
-C> The use of this subroutine is only required when writing data
-C> into delayed replication sequences using ufbseq(), or for cases
-C> where ufbint() or ufbrep() are being used to write data into
-C> delayed replication sequences which occur more than once within
-C> an overall subset definition. In such cases, the use of this
-C> subroutine allows the application code to explicitly specify how
-C> many replications of the sequence are to be allocated to each
-C> occurrence of the delayed replication sequence within the overall
-C> subset definition, prior to storing all of the actual data values
-C> themselves via a single subsequent call to ufbint() or ufbrep().
-C> In contrast, the use of this subroutine is not required when
-C> ufbint() or ufbrep() are to be called to store data values
-C> for a delayed replication sequence which only occurs one time
-C> within an overall subset definition, because in that case the
-C> same type of initialization and space allocation functionality
-C> will be automatically handled internally within subroutine
-C> ufbint() or ufbrep().
-C>
-C> @author J. Woollen @date 2002-05-14
- RECURSIVE SUBROUTINE DRFINI(LUNIT,MDRF,NDRF,DRFTAG)
-
- use modv_vars, only: im8b
-
- use moda_usrint
- use moda_tables
-
- PARAMETER ( MXDRF = 2000 )
-
- CHARACTER*(*) DRFTAG
- CHARACTER*128 BORT_STR
- DIMENSION MDRF(*),LUNIT(*),NDRF(*)
- DIMENSION MY_MDRF(MXDRF),MY_LUNIT(1),MY_NDRF(1)
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIT,MY_LUNIT,1)
- CALL X84(NDRF,MY_NDRF,1)
- CALL X84(MDRF,MY_MDRF,MY_NDRF(1))
- CALL DRFINI(MY_LUNIT,MY_MDRF,MY_NDRF,DRFTAG)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IF(NDRF(1).GT.MXDRF) GOTO 900
-
- CALL STATUS(LUNIT,LUN,IL,IM)
-
-C COMFORM THE TEMPLATES TO THE DELAYED REPLICATION FACTORS
-C --------------------------------------------------------
-
- M = 0
- N = 0
-
-10 DO N=N+1,NVAL(LUN)
- NODE = INV(N,LUN)
- IF(ITP(NODE).EQ.1 .AND. TAG(NODE).EQ.DRFTAG) THEN
- M = M+1
- CALL USRTPL(LUN,N,MDRF(M))
- GOTO 10
- ENDIF
- ENDDO
-
-C EXITS
-C -----
-
- RETURN
- 900 WRITE(BORT_STR,'("BUFRLIB: DRFINI - THE NUMBER OF DELAYED '//
- . 'REPLICATION FACTORS (",I5,") EXCEEDS THE LIMIT (",I5,")")')
- . NDRF(1),MXDRF
- CALL BORT(BORT_STR)
- END
diff --git a/src/getvalnb.f b/src/getvalnb.f
deleted file mode 100644
index e4e0dcd4f..000000000
--- a/src/getvalnb.f
+++ /dev/null
@@ -1,104 +0,0 @@
-C> @file
-C> @brief Read one data value from a data subset.
-C>
-C> @author J. Ator @date 2012-09-12
-
-C> Read a data value corresponding to
-C> a specific occurrence of a mnemonic within a data subset, based on
-C> its position relative to a different mnemonic within the subset.
-C>
-C> The function first searches for a specific occurrence of a pivot
-C> mnemonic, counting from the beginning of the subset. From there,
-C> it then searches in either a forward or backward direction for a
-C> specific occurrence of a nearby mnemonic, and if found
-C> returns the data value from the corresponding location
-C> within the subset.
-C>
-C> @param[in] LUNIT -- integer: Fortran logical unit number for
-C> BUFR file
-C> @param[in] TAGPV -- character*(*): Pivot mnemonic; the subroutine
-C> will first search for the (NTAGPV)th occurrence
-C> of this mnemonic, counting from the beginning
-C> of the overall subset definition
-C> @param[in] NTAGPV -- integer: Ordinal occurrence of TAGPV to search for,
-C> counting from the beginning of the overall
-C> subset definition
-C> @param[in] TAGNB -- character*(*): Nearby mnemonic; assuming TAGPV is
-C> successfully found, the subroutine will then search
-C> nearby for the (NTAGNB)th occurrence of TAGNB and
-C> return the corresponding value
-C> @param[in] NTAGNB -- integer: Ordinal occurrence of TAGNB to search for,
-C> counting from the location of TAGPV within the
-C> overall subset definition. If NTAGNB is positive,
-C> the subroutine will search in a forward direction
-C> from the location of TAGPV; otherwise, if NTAGNB is
-C> negative, it will instead search in a backwards
-C> direction from the location of TAGPV.
-C> @returns getvalnb -- real*8: Value corresponding to (NTAGNB)th occurrence
-C> of TAGNB. If for any reason this value cannot be
-C> located, then the current placeholder value for
-C> "missing" data will be returned instead.
-C>
-C> The current placeholder value for "missing" data can be determined
-C> via a separate call to function getbmiss().
-C>
-C> Before calling this function, a BUFR data subset should already be
-C> open for reading via a previous call to one of the NCEPLIBS-bufr
-C> [subset-reading subroutines](@ref hierarchy).
-C>
-C> @author J. Ator @date 2012-09-12
- RECURSIVE FUNCTION GETVALNB
- . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB )
- . RESULT ( R8VAL )
-
- use modv_vars, only: im8b, bmiss
-
- use moda_usrint
- use moda_msgcwd
- use moda_tables
-
- CHARACTER*(*) TAGPV, TAGNB
-
- REAL*8 R8VAL
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C Check for I8 integers.
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIT,MY_LUNIT,1)
- CALL X84(NTAGPV,MY_NTAGPV,1)
- CALL X84(NTAGNB,MY_NTAGNB,1)
- R8VAL=GETVALNB(MY_LUNIT,TAGPV,MY_NTAGPV,TAGNB,MY_NTAGNB)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- R8VAL = BMISS
-
-C Get LUN from LUNIT.
-
- CALL STATUS (LUNIT, LUN, IL, IM )
- IF ( IL .GE. 0 ) RETURN
- IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN
-
-C Starting from the beginning of the subset, locate the (NTAGPV)th
-C occurrence of TAGPV.
-
- CALL FSTAG( LUN, TAGPV, NTAGPV, 1, NPV, IRET )
- IF ( IRET .NE. 0 ) RETURN
-
-C Now, starting from the (NTAGPV)th occurrence of TAGPV, search
-C forward or backward for the (NTAGNB)th occurrence of TAGNB.
-
- CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IRET )
- IF ( IRET .NE. 0 ) RETURN
-
- R8VAL = VAL(NNB,LUN)
-
- RETURN
- END
diff --git a/src/readlc.f b/src/readlc.f
deleted file mode 100644
index 907c39dad..000000000
--- a/src/readlc.f
+++ /dev/null
@@ -1,198 +0,0 @@
-C> @file
-C> @brief Read a long character string (greater than 8 bytes) from
-C> a data subset.
-C>
-C> @authors J. Woollen J. Ator @date 2003-11-04
-
-C> Read a long character string (greater than 8 bytes)
-C> from a data subset.
-C>
-C> The data subset should have already been read into internal arrays
-C> via a previous call to one of the
-C> [subset-reading subroutines](@ref hierarchy).
-C>
-C> If there is more than one occurrence of STR within the data subset
-C> definition, then each occurrence can be retrieved via a separate call
-C> to this subroutine, and by appending the ordinal number of the
-C> occurrence to STR in each case.
-C>
-C> For example, if there are 5
-C> occurrences of mnemonic LSTID within a given data subset definition,
-C> then 5 separate calls should be made to this subroutine, once each
-C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
-C> 'LSTID#5'.
-C>
-C> Omitting the ordinal number always defaults to the first occurrence
-C> of a particular string, so a user could just specify 'LSTID'
-C> instead of 'LSTID#1'.
-C>
-C> @remarks
-C> - Character strings which are 8 bytes or less in length can be read
-C> using the real*8 USR array within a call to one of the NCEPLIBS-bufr
-C> [values-reading subroutines](@ref hierarchy) and then converting the
-C> corresponding real*8 value to character format within the
-C> application program.
-C> - If STR is not found within the data subset definition, then CHR is
-C> returned with all bits set to 1, which is the standard WMO BUFR value
-C> for "missing" data. Any CHR value returned by this subroutine can be
-C> checked for equivalence to this "missing" value via a call to
-C> function icbfms().
-C>
-C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
-C> @param[out] CHR - character*(*): Value corresponding to STR.
-C> @param[in] STR - character*(*): Table B mnemonic of long character.
-C> string to be retrieved, possibly supplemented with an ordinal
-C> occurrence notation.
-C>
-C> @authors J. Woollen J. Ator @date 2003-11-04
-
- RECURSIVE SUBROUTINE READLC(LUNIT,CHR,STR)
-
- use modv_vars, only: im8b
-
- use moda_usrint
- use moda_usrbit
- use moda_unptyp
- use moda_bitbuf
- use moda_tables
- use moda_rlccmn
-
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) CHR,STR
- CHARACTER*128 BORT_STR,ERRSTR
- CHARACTER*10 CTAG
- CHARACTER*14 TGS(10)
-
- DATA MAXTG /10/
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIT,MY_LUNIT,1)
- CALL READLC(MY_LUNIT,CHR,STR)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- CHR = ' '
- LCHR=LEN(CHR)
-
-C CHECK THE FILE STATUS
-C ---------------------
-
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IL.GT.0) GOTO 901
- IF(IM.EQ.0) GOTO 902
-
-C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
-C ------------------------------------------------------------------
-
- CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
- IF(NTG.GT.1) GOTO 903
-
-C Check if a specific occurrence of the input string was requested;
-C if not, then the default is to return the first occurrence.
-
- CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID)
- IF(KON.EQ.6) THEN
- IOID=NINT(ROID)
- IF(IOID.LE.0) IOID = 1
- CTAG = ' '
- II = 1
- DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#'))
- CTAG(II:II)=TGS(1)(II:II)
- II = II + 1
- ENDDO
- ELSE
- IOID = 1
- CTAG = TGS(1)(1:10)
- ENDIF
-
-C LOCATE AND DECODE THE LONG CHARACTER STRING
-C -------------------------------------------
-
- IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN
-
-C The message is uncompressed
-
- ITAGCT = 0
- DO N=1,NVAL(LUN)
- NOD = INV(N,LUN)
- IF(CTAG.EQ.TAG(NOD)) THEN
- ITAGCT = ITAGCT + 1
- IF(ITAGCT.EQ.IOID) THEN
- IF(ITP(NOD).NE.3) GOTO 904
- NCHR = NBIT(N)/8
- IF(NCHR.GT.LCHR) GOTO 905
- KBIT = MBIT(N)
- CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT,.TRUE.)
- GOTO 100
- ENDIF
- ENDIF
- ENDDO
- ELSE
-
-C The message is compressed
-
- IF(NRST.GT.0) THEN
- ITAGCT = 0
- DO II=1,NRST
- IF(CTAG.EQ.CRTAG(II)) THEN
- ITAGCT = ITAGCT + 1
- IF(ITAGCT.EQ.IOID) THEN
- NCHR = IRNCH(II)
- IF(NCHR.GT.LCHR) GOTO 905
- KBIT = IRBIT(II)
- CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT,.TRUE.)
- GOTO 100
- ENDIF
- ENDIF
- ENDDO
- ENDIF
- ENDIF
-
-C If we made it here, then we couldn't find the requested string.
-
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
- ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) //
- . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' //
- . ' STRING FOR CHARACTER DATA ELEMENT'
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- DO II=1,LCHR
- CALL IPKM(CHR(II:II),1,255)
- ENDDO
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
- . ' BE OPEN FOR INPUT')
-901 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
- . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
-902 CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
- . 'BUFR FILE, NONE ARE')
-903 WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
- . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
- . 'I3,")")') STR,NTG
- CALL BORT(BORT_STR)
-904 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
- . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD)
- CALL BORT(BORT_STR)
-905 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
- . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
- . 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LCHR
- CALL BORT(BORT_STR)
- END
diff --git a/src/readwriteval.F90 b/src/readwriteval.F90
new file mode 100644
index 000000000..0b06d4b64
--- /dev/null
+++ b/src/readwriteval.F90
@@ -0,0 +1,1936 @@
+!> @file
+!> @brief Read or write data values within a BUFR data subset.
+!>
+!> @authors J. Woollen, J. Ator @date 1994-01-06
+
+!> Write a data value corresponding to
+!> a specific occurrence of a mnemonic within a data subset, based on
+!> its position relative to a different mnemonic within the subset.
+!>
+!> The subroutine first searches for a specific occurrence of a pivot
+!> mnemonic, counting from the beginning of the subset. From there,
+!> it then searches in either a forward or backward direction for a
+!> specific occurrence of a nearby mnemonic, and if found
+!> stores the specified data value in the corresponding location
+!> within the subset.
+!>
+!> Before calling this subroutine, a BUFR message should already be
+!> opened and initialized for output via a previous call to one of the
+!> NCEPLIBS-bufr [message-writing subroutines](@ref hierarchy).
+!>
+!> @param lunit - Fortran logical unit number for BUFR file
+!> @param tagpv - Pivot mnemonic; the subroutine will first search for the (ntagpv)th occurrence of this mnemonic, counting
+!> from the beginning of the overall subset definition
+!> @param ntagpv - Ordinal occurrence of tagpv to search for, counting from the beginning of the overall subset definition
+!> @param tagnb - Nearby mnemonic; assuming tagpv is successfully found, the subroutine will then search nearby for the
+!> (ntagnb)th occurrence of tagnb and store r8val as the corresponding value
+!> @param ntagnb - Ordinal occurrence of tagnb to search for, counting from the location of tagpv within the overall subset
+!> definition
+!> - If ntagnb is positive, the subroutine will search in a forward direction from the location of tagpv
+!> - If ntagnb is negative, the subroutine will search in a backwards direction from the location of tagpv
+!> @param r8val - Value to be stored corresponding to (ntagnb)th occurrence of tagnb within the subset
+!> @param iret - return code:
+!> - 0 = r8val was successfully stored
+!> - -1 = the (ntagnb)th occurence of mnemonic tagnb could not be found, or some other error occurred
+!>
+!> @author J. Ator @date 2016-07-29
+recursive subroutine setvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb, r8val, iret )
+
+ use modv_vars, only: im8b
+
+ use moda_usrint
+ use moda_msgcwd
+ use moda_tables
+
+ implicit none
+
+ integer, intent(in) :: lunit, ntagpv, ntagnb
+ integer, intent(out) :: iret
+ integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft
+
+ character*(*), intent(in) :: tagpv, tagnb
+
+ real*8, intent(in) :: r8val
+
+ ! Check for I8 integers.
+ if(im8b) then
+ im8b=.false.
+ call x84 ( lunit, my_lunit, 1 )
+ call x84 ( ntagpv, my_ntagpv, 1 )
+ call x84 ( ntagnb, my_ntagnb, 1 )
+ call setvalnb ( my_lunit, tagpv, my_ntagpv, tagnb, my_ntagnb, r8val, iret )
+ call x48 ( iret, iret, 1 )
+ im8b=.true.
+ return
+ endif
+
+ iret = -1
+
+ ! Get lun from lunit.
+ call status (lunit, lun, il, im )
+ if ( il .le. 0 ) return
+ if ( inode(lun) .ne. 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
+
+ ! 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
+
+ iret = 0
+ val(nnb,lun) = r8val
+
+ return
+end subroutine setvalnb
+
+!> Read a data value corresponding to
+!> a specific occurrence of a mnemonic within a data subset, based on
+!> its position relative to a different mnemonic within the subset.
+!>
+!> The function first searches for a specific occurrence of a pivot
+!> mnemonic, counting from the beginning of the subset. From there,
+!> it then searches in either a forward or backward direction for a
+!> specific occurrence of a nearby mnemonic, and if found
+!> returns the data value from the corresponding location
+!> within the subset.
+!>
+!> @param lunit - Fortran logical unit number for BUFR file
+!> @param tagpv - Pivot mnemonic; the subroutine will first search for the (ntagpv)th occurrence of this mnemonic, counting
+!> from the beginning of the overall subset definition
+!> @param ntagpv - Ordinal occurrence of tagpv to search for, counting from the beginning of the overall subset definition
+!> @param tagnb - Nearby mnemonic; assuming tagpv is successfully found, the subroutine will then search nearby for the
+!> (ntagnb)th occurrence of tagnb and return the corresponding value
+!> @param ntagnb - Ordinal occurrence of tagnb to search for, counting from the location of tagpv within the overall subset
+!> definition
+!> - If ntagnb is positive, the subroutine will search in a forward direction from the location of tagpv
+!> - If ntagnb is negative, the subroutine will search in a backwards direction from the location of tagpv
+!> @returns getvalnb - Value corresponding to (ntagnb)th occurrence of tagnb
+!> - If for any reason this value cannot be located, then the current placeholder value for "missing" data will be returned
+!> instead
+!>
+!> The current placeholder value for "missing" data can be determined
+!> via a separate call to function getbmiss().
+!>
+!> Before calling this function, a BUFR data subset should already be
+!> open for reading via a previous call to one of the NCEPLIBS-bufr
+!> [subset-reading subroutines](@ref hierarchy).
+!>
+!> @author J. Ator @date 2012-09-12
+recursive real*8 function getvalnb ( lunit, tagpv, ntagpv, tagnb, ntagnb ) result ( r8val )
+
+ use modv_vars, only: im8b, bmiss
+
+ use moda_usrint
+ use moda_msgcwd
+ use moda_tables
+
+ implicit none
+
+ integer, intent(in) :: lunit, ntagpv, ntagnb
+ integer my_lunit, my_ntagpv, my_ntagnb, lun, il, im, npv, nnb, ierft
+
+ character*(*), intent(in) :: tagpv, tagnb
+
+ ! Check for I8 integers.
+ if(im8b) then
+ im8b=.false.
+ call x84(lunit,my_lunit,1)
+ call x84(ntagpv,my_ntagpv,1)
+ call x84(ntagnb,my_ntagnb,1)
+ r8val=getvalnb(my_lunit,tagpv,my_ntagpv,tagnb,my_ntagnb)
+ im8b=.true.
+ return
+ endif
+
+ r8val = bmiss
+
+ ! Get lun from lunit.
+ call status (lunit, lun, il, im )
+ if ( il .ge. 0 ) return
+ if ( inode(lun) .ne. 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
+
+ ! 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
+
+ r8val = val(nnb,lun)
+
+ return
+end function getvalnb
+
+!> Write a long character string (greater than 8 bytes) to a data subset.
+!>
+!> The data subset should have already been written into a BUFR message before
+!> calling this subroutine to write a long character string into the subset.
+!>
+!> If there is more than one occurrence of str within the data subset
+!> definition, then each occurrence can be written via a separate call
+!> to this subroutine, and by appending the ordinal number of the
+!> occurrence to STR in each case. For example, if there are 5
+!> occurrences of mnemonic LSTID within a given data subset definition,
+!> then 5 separate calls should be made to this subroutine, once each
+!> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
+!> 'LSTID#5'. However, the first notation is superfluous, because
+!> omitting the ordinal number always defaults to the first occurrence
+!> of a particular string, so a user could just specify 'LSTID'
+!> instead of 'LSTID#1'.
+!>
+!> Character strings which are 8 bytes or less in length can be
+!> written by converting the string into a real*8 value within the
+!> application program, and then using the real*8 usr array within a
+!> call to one of the NCEPLIBS-bufr
+!> [values-writing subroutines](@ref hierarchy)
+!> prior to calling one of the
+!> [subset-writing subroutines](@ref hierarchy)
+!> for the data subset.
+!>
+!> @param lunit - Fortran logical unit number for BUFR file
+!> @param chr - Value corresponding to str
+!> @param str - Table B mnemonic of long character string to be written, possibly supplemented with an ordinal
+!> occurrence notation
+!>
+!> @author J. Woollen @author J. Ator @date 2003-11-04
+recursive subroutine writlc(lunit,chr,str)
+
+ use modv_vars, only: im8b, mxlcc
+
+ use moda_usrint
+ use moda_msgcwd
+ use moda_bitbuf
+ use moda_tables
+ use moda_comprs
+
+ implicit none
+
+ integer, intent(in) :: lunit
+ integer my_lunit, maxtg, iprt, lun, il, im, ntg, nnod, kon, ii, n, node, ioid, ival, mbit, nbit, nbmp, nchr, nbyt, nsubs, &
+ itagct, len0, len1, len2, len3, l4, l5, mbyte, iupbs3
+
+ character*(*), intent(in) :: chr, str
+ character*128 bort_str, errstr
+ character*10 ctag
+ character*14 tgs(10)
+
+ real roid
+
+ common /quiet/ iprt
+
+ data maxtg /10/
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunit,my_lunit,1)
+ call writlc(my_lunit,chr,str)
+ im8b=.true.
+ return
+ endiF
+
+ ! 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')
+
+ ! Check for tags (mnemonics) in input string (there can only be one)
+ call parstr(str,tgs,maxtg,ntg,' ',.true.)
+ if(ntg.gt.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)
+ endif
+
+ ! 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
+ ioid=nint(roid)
+ if(ioid.le.0) ioid = 1
+ ctag = ' '
+ ii = 1
+ do while((ii.le.10).and.(tgs(1)(ii:ii).ne.'#'))
+ ctag(ii:ii)=tgs(1)(ii:ii)
+ ii = ii + 1
+ enddo
+ else
+ ioid = 1
+ ctag = tgs(1)(1:10)
+ endif
+
+ if(iupbs3(mbay(1,lun),'ICMP').gt.0) then
+ ! The message is compressed
+ n = 1
+ itagct = 0
+ call usrtpl(lun,n,n)
+ do while (n+1.le.nval(lun))
+ n = n+1
+ node = inv(n,lun)
+ if(itp(node).eq.1) then
+ nbmp=int(matx(n,ncol))
+ call usrtpl(lun,n,nbmp)
+ elseif(ctag.eq.tag(node)) then
+ itagct = itagct + 1
+ if(itagct.eq.ioid) then
+ if(itp(node).ne.3) then
+ write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
+ ctag,typ(node)
+ call bort(bort_str)
+ endif
+ catx(n,ncol)=' '
+ ! The following statement enforces a limit of mxlcc characters per long character string when writing
+ ! compressed messages. This limit keeps the array catx to a reasonable dimensioned size.
+ nchr=min(mxlcc,ibt(node)/8)
+ catx(n,ncol)=chr(1:nchr)
+ call usrtpl(lun,1,1)
+ return
+ endif
+ endif
+ enddo
+ else
+ ! The message is not compressed. Locate the beginning of the data (Section 4) in the message.
+ call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
+ mbyte = len0 + len1 + len2 + len3 + 4
+ nsubs = 1
+ ! Find the most recently written subset in the message.
+ do while(nsubs.lt.nsub(lun))
+ ibit = mbyte*8
+ call upb(nbyt,16,mbay(1,lun),ibit)
+ mbyte = mbyte + nbyt
+ nsubs = nsubs + 1
+ enddo
+ if(nsubs.ne.nsub(lun)) then
+ if(iprt.ge.0) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag // &
+ ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
+ call errwrt(errstr)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ return
+ endif
+ ! Locate and write the long character string within this subset.
+ itagct = 0
+ mbit = mbyte*8 + 16
+ nbit = 0
+ n = 1
+ call usrtpl(lun,n,n)
+ do while (n+1.le.nval(lun))
+ n = n+1
+ node = inv(n,lun)
+ mbit = mbit+nbit
+ nbit = ibt(node)
+ if(itp(node).eq.1) then
+ call upbb(ival,nbit,mbit,mbay(1,lun))
+ call usrtpl(lun,n,ival)
+ elseif(ctag.eq.tag(node)) then
+ itagct = itagct + 1
+ if(itagct.eq.ioid) then
+ if(itp(node).ne.3) then
+ write(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') &
+ ctag,typ(node)
+ call bort(bort_str)
+ endif
+ nchr = nbit/8
+ ibit = mbit
+ do ii=1,nchr
+ call pkc(' ',1,mbay(1,lun),ibit)
+ enddo
+ call pkc(chr,nchr,mbay(1,lun),mbit)
+ call usrtpl(lun,1,1)
+ return
+ endif
+ endif
+ enddo
+ endif
+
+ ! If we made it here, then we couldn't find the requested string.
+ if(iprt.ge.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'
+ call errwrt(errstr)
+ errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
+ call errwrt(errstr)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+
+ return
+end subroutine writlc
+
+!> Read a long character string (greater than 8 bytes) from a data subset.
+!>
+!> The data subset should have already been read into internal arrays
+!> via a previous call to one of the
+!> [subset-reading subroutines](@ref hierarchy).
+!>
+!> If there is more than one occurrence of str within the data subset
+!> definition, then each occurrence can be retrieved via a separate call
+!> to this subroutine, and by appending the ordinal number of the
+!> occurrence to str in each case.
+!>
+!> For example, if there are 5
+!> occurrences of mnemonic LSTID within a given data subset definition,
+!> then 5 separate calls should be made to this subroutine, once each
+!> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
+!> 'LSTID#5'.
+!>
+!> Omitting the ordinal number always defaults to the first occurrence
+!> of a particular string, so a user could just specify 'LSTID'
+!> instead of 'LSTID#1'.
+!>
+!> @remarks
+!> - Character strings which are 8 bytes or less in length can be read
+!> using the real*8 usr array within a call to one of the NCEPLIBS-bufr
+!> [values-reading subroutines](@ref hierarchy) and then converting the
+!> corresponding real*8 value to character format within the
+!> application program.
+!> - If str is not found within the data subset definition, then chr is
+!> returned with all bits set to 1, which is the standard WMO BUFR value
+!> for "missing" data. Any chr value returned by this subroutine can be
+!> checked for equivalence to this "missing" value via a call to
+!> function icbfms().
+!>
+!> @param lunit - Fortran logical unit number for BUFR file
+!> @param chr - Value corresponding to STR
+!> @param str - Table B mnemonic of long character string to be retrieved, possibly supplemented with
+!> an ordinal occurrence notation
+!>
+!> @authors J. Woollen J. Ator @date 2003-11-04
+recursive subroutine readlc(lunit,chr,str)
+
+ use modv_vars, only: im8b
+
+ use moda_usrint
+ use moda_usrbit
+ use moda_unptyp
+ use moda_bitbuf
+ use moda_tables
+ use moda_rlccmn
+
+ implicit none
+
+ integer, intent(in) :: lunit
+ integer my_lunit, maxtg, iprt, lchr, lun, il, im, ntg, nnod, kon, ii, n, nod, ioid, itagct, nchr, kbit
+
+ character*(*), intent(in) :: str
+ character*(*), intent(out) :: chr
+
+ character*128 bort_str, errstr
+ character*10 ctag
+ character*14 tgs(10)
+
+ real roid
+
+ common /quiet/ iprt
+
+ data maxtg /10/
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunit,my_lunit,1)
+ call readlc(my_lunit,chr,str)
+ im8b=.true.
+ return
+ endif
+
+ chr = ' '
+ lchr=len(chr)
+
+ ! 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')
+
+ ! Check for tags (mnemonics) in input string (there can only be one)
+ call parstr(str,tgs,maxtg,ntg,' ',.true.)
+ if(ntg.gt.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)
+ endif
+
+ ! 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
+ ioid=nint(roid)
+ if(ioid.le.0) ioid = 1
+ ctag = ' '
+ ii = 1
+ do while((ii.le.10).and.(tgs(1)(ii:ii).ne.'#'))
+ ctag(ii:ii)=tgs(1)(ii:ii)
+ ii = ii + 1
+ enddo
+ else
+ ioid = 1
+ ctag = tgs(1)(1:10)
+ endif
+
+ ! Locate and decode the long character string
+ if(msgunp(lun).eq.0.or.msgunp(lun).eq.1) then
+ ! The message is not compressed
+ itagct = 0
+ do n=1,nval(lun)
+ nod = inv(n,lun)
+ if(ctag.eq.tag(nod)) then
+ itagct = itagct + 1
+ if(itagct.eq.ioid) then
+ if(itp(nod).ne.3) 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
+ 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)
+ endif
+ kbit = mbit(n)
+ call upc(chr,nchr,mbay(1,lun),kbit,.true.)
+ return
+ endif
+ endif
+ enddo
+ else
+ ! The message is compressed
+ if(nrst.gt.0) then
+ itagct = 0
+ do ii=1,nrst
+ if(ctag.eq.crtag(ii)) then
+ itagct = itagct + 1
+ if(itagct.eq.ioid) then
+ nchr = irnch(ii)
+ if(nchr.gt.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)
+ endif
+ kbit = irbit(ii)
+ call upc(chr,nchr,mbay(1,lun),kbit,.true.)
+ return
+ endif
+ endif
+ enddo
+ endif
+ endif
+
+ ! If we made it here, then we couldn't find the requested string.
+ if(iprt.ge.0) then
+ call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
+ errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) // &
+ ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING STRING FOR CHARACTER DATA ELEMENT'
+ call errwrt(errstr)
+ call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
+ call errwrt(' ')
+ endif
+ do ii=1,lchr
+ call ipkm(chr(ii:ii),1,255)
+ enddo
+
+ return
+end subroutine readlc
+
+!> Read or write one or more data values from or to
+!> the BUFR data subset that is currently open within the NCEPLIBS-bufr
+!> internal arrays.
+!>
+!> The direction of the data transfer is determined by the context of abs(lunin):
+!> - If abs(lunin) points to a file that was previously opened for
+!> input using subroutine openbf(), then data values are read from
+!> the current data subset.
+!> - If abs(lunin) points to a file that was previously opened for
+!> output using subroutine openbf(), then data values are written to
+!> the current data subset.
+!>
+!> This subroutine is specifically designed for use with Table B
+!> mnemonics which are part of a delayed-replication sequence, or for
+!> which there is no replication at all. See also subroutines ufbrep(),
+!> ufbseq() and ufbstp(), which can also be used to read/write one or
+!> more data values from/to a data subset but are designed for
+!> different use cases. A more detailed discussion of
+!> these different use cases, including examples, is available in
+!> [DX BUFR Tables](@ref ufbsubs).
+!>
+!> It is the user's responsibility to ensure that usr is dimensioned
+!> sufficiently large enough to accommodate the number of data values
+!> that are to be read from or written to the data subset. Note also
+!> that usr is an array of real*8 values; therefore, any data that are
+!> to be written out as character (i.e. CCITT IA5) values in
+!> BUFR must be converted from character into real*8 format within the
+!> application program before calling this subroutine. Conversely,
+!> when this subroutine is being used to read character values from a
+!> data subset, the value that is returned will be in real*8 format
+!> and must be converted back into character format by the application
+!> program before it can be used as such. Alternatively, there are
+!> different subroutines such as readlc() and writlc() which can be
+!> used to read/write character data directly from/to a data subset
+!> without the need to convert from/to real*8 format as an intermediate
+!> step.
+!>
+!> Numeric (i.e. non-character) data values within usr are always in
+!> the exact units specified for the corresponding mnemonic within the
+!> relevant DX or master BUFR table, without any scale or reference
+!> values applied. Specifically, this means that, when writing
+!> data values into an output subset, the user only needs to store each
+!> respective value into usr using the units specified within the table,
+!> and the NCEPLIBS-bufr software will take care of any necessary scaling or
+!> referencing of the value before it is actually encoded into BUFR.
+!> Conversely, when reading data values from an input subset, the
+!> values returned in usr are already de-scaled and de-referenced and,
+!> thus, are already in the exact units that were defined for the
+!> corresponding mnemonics within the table.
+!>
+!> "Missing" values in usr are always denoted by a unique
+!> placeholder value. This placeholder value is initially set
+!> to a default value of 10E10_8, but it can be reset to
+!> any substitute value of the user's choice via a separate
+!> call to subroutine setbmiss(). In any case, and whenever this
+!> subroutine is used to read data values from an input subset, any
+!> returned value in usr can be easily checked for equivalence to the
+!> current placeholder value via a call to function ibfms(), and a
+!> positive result means that the value for the corresponding mnemonic
+!> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
+!> original data subset. Conversely, whenever this subroutine
+!> is used to write data values to an output subset, the current
+!> placeholder value can be obtained via a separate call to function
+!> getbmiss(), and the resulting value can then be stored into the
+!> usr array whereever the user desires a BUFR "missing" value (i.e.
+!> all bits set to 1) to be encoded for the corresponding mnemonic
+!> within the output subset.
+!>
+!> @remarks
+!> - If lunin < 0, and if abs(lunin) points to a file that is open
+!> for output (writing BUFR), then the subroutine will treat the file
+!> pointed to by abs(lunin) as though it was open for input (reading
+!> BUFR). This is a special capability for use by some applications
+!> that need to read certain values back out from a BUFR file during
+!> the same time that it is in the process of being written to.
+!> - If abs(lunin) points to a file that is open for input (reading
+!> BUFR), str may contain a Table D mnemonic that is replicated using
+!> either 8-bit or 16-bit delayed replication (as noted using
+!> replication indicators {} or (), respectively, within the
+!> assocated DX BUFR table), and the corresponding location in usr
+!> will contain the total number of replications of that mnemonic
+!> within the data subset. Note that, when using this option, the
+!> applicable replication indicators must be included in str
+!> along with the mnemonic itself, as shown in an example in the
+!> discussion of [DX BUFR Tables](@ref ufbsubs).
+!>
+!> @param lunin - Absolute value is Fortran logical unit number for BUFR file
+!> @param usr - Data values
+!> - If abs(lunin) was opened for input, then usr is output from this subroutine and
+!> contains data values that were read from the current data subset
+!> - If abs(lunin) was opened for output, then usr is input to this subroutine and
+!> contains data values that are to be written to the current data subset
+!> @param i1 - First dimension of usr as allocated within the calling program
+!> @param i2 - Second dimension of usr
+!> - If abs(lunin) was opened for input, then i2 must be set equal to the second dimension
+!> of usr as allocated within the calling program
+!> - If abs(lunin) was opened for output, then i2 must be set equal to the number of replications
+!> of str that are to be written to the data subset
+!> @param iret - Number of replications of str that were read/written from/to the data subset
+!> @param str - String of blank-separated Table B mnemonics in one-to-one correspondence with the number of data values
+!> that will be read/written from/to the data subset within the first dimension of usr (see [DX BUFR Tables](@ref dfbftab)
+!> for further information about Table B mnemonics)
+!>
+!> @author J. Woollen @date 1994-01-06
+recursive subroutine ufbint(lunin,usr,i1,i2,iret,str)
+
+ use modv_vars, only: im8b, bmiss
+
+ use moda_usrint
+ use moda_msgcwd
+
+ implicit none
+
+ character*(*), intent(in) :: str
+ character*128 bort_str1, bort_str2, errstr
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ integer, intent(in) :: lunin, i1, i2
+ integer, intent(out) :: iret
+ integer iprt, nnod, ncon, nods, nodc, ivls, kons, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j
+
+ common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
+ common /quiet/ iprt
+
+ data ifirst1 /0/, ifirst2 /0/
+
+ save ifirst1, ifirst2
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunin,my_lunin,1)
+ call x84(i1,my_i1,1)
+ call x84(i2,my_i2,1)
+ call ufbint(my_lunin,usr,my_i1,my_i2,iret,str)
+ call x48(iret,iret,1)
+ im8b=.true.
+ return
+ endif
+
+ iret = 0
+
+ ! 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 ' // &
+ 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
+
+ io = min(max(0,il),1)
+ if(lunit.ne.lunin) io = 0
+
+ if(i1.le.0) then
+ if(iprt.ge.0) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ 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
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ if(iprt.eq.0 .and. io.eq.1) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
+ 'BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst1 = 1
+ endif
+ return
+ endif
+
+ ! Parse or recall the input string
+ call string(str,lun,i1,io)
+
+ ! Initialize usr array preceeding an input operation
+ if(io.eq.0) then
+ do j=1,i2
+ do i=1,I1
+ usr(i,j) = bmiss
+ enddo
+ enddo
+ endif
+
+ ! Call the mnemonic reader/writer
+ 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
+ call trybump(lun,usr,i1,i2,io,iret)
+ if(iret.ne.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
+ iret = 0
+ endif
+
+ if(iret.eq.0) then
+ if(io.eq.0) then
+ if(iprt.ge.1) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ else
+ if(iprt.eq.-1) ifirst2 = 1
+ if(ifirst2.eq.0 .or. iprt.ge.1) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
+ if(iprt.eq.0) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call ' // &
+ 'to a BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst2 = 1
+ endif
+ endif
+ endif
+
+ return
+end subroutine ufbint
+
+!> Read or write one or more data values from or to
+!> the BUFR data subset that is currently open within the NCEPLIBS-bufr
+!> internal arrays.
+!>
+!> The direction of the data transfer is determined by the context of abs(lunin):
+!> - If abs(lunin) points to a file that was previously opened for
+!> input using subroutine openbf(), then data values are read from
+!> the current data subset.
+!> - If abs(lunin) points to a file that was previously opened for
+!> output using subroutine openbf(), then data values are written to
+!> the current data subset.
+!>
+!> This subroutine is specifically designed for use with Table B
+!> mnemonics which are part of a fixed (i.e. non-delayed) replication
+!> sequence, or for mnemonics which are replicated by being directly
+!> listed more than once within an overall subset definition.
+!> See also subroutines ufbint(),
+!> ufbseq() and ufbstp(), which can also be used to read/write one or
+!> more data values from/to a data subset but are designed for
+!> different use cases. A more detailed discussion of
+!> these different use cases, including examples, is available in
+!> [DX BUFR Tables](@ref ufbsubs).
+!>
+!> It is the user's responsibility to ensure that usr is dimensioned
+!> sufficiently large enough to accommodate the number of data values
+!> that are to be read from or written to the data subset. Note also
+!> that usr is an array of real*8 values; therefore, any data that are
+!> to be written out as character (i.e. CCITT IA5) values in
+!> BUFR must be converted from character into real*8 format within the
+!> application program before calling this subroutine. Conversely,
+!> when this subroutine is being used to read character values from a
+!> data subset, the value that is returned will be in real*8 format
+!> and must be converted back into character format by the application
+!> program before it can be used as such. Alternatively, there are
+!> different subroutines such as readlc() and writlc() which can be
+!> used to read/write character data directly from/to a data subset
+!> without the need to convert from/to real*8 format as an intermediate
+!> step.
+!>
+!> Numeric (i.e. non-character) data values within usr are always in
+!> the exact units specified for the corresponding mnemonic within the
+!> relevant DX or master BUFR table, without any scale or reference
+!> values applied. Specifically, this means that, when writing
+!> data values into an output subset, the user only needs to store each
+!> respective value into usr using the units specified within the table,
+!> and the NCEPLIBS-bufr software will take care of any necessary scaling or
+!> referencing of the value before it is actually encoded into BUFR.
+!> Conversely, when reading data values from an input subset, the
+!> values returned in usr are already de-scaled and de-referenced and,
+!> thus, are already in the exact units that were defined for the
+!> corresponding mnemonics within the table.
+!>
+!> "Missing" values in usr are always denoted by a unique
+!> placeholder value. This placeholder value is initially set
+!> to a default value of 10E10_8, but it can be reset to
+!> any substitute value of the user's choice via a separate
+!> call to subroutine setbmiss(). In any case, and whenever this
+!> subroutine is used to read data values from an input subset, any
+!> returned value in usr can be easily checked for equivalence to the
+!> current placeholder value via a call to function ibfms(), and a
+!> positive result means that the value for the corresponding mnemonic
+!> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
+!> original data subset. Conversely, whenever this subroutine
+!> is used to write data values to an output subset, the current
+!> placeholder value can be obtained via a separate call to function
+!> getbmiss(), and the resulting value can then be stored into the
+!> usr array whereever the user desires a BUFR "missing" value (i.e.
+!> all bits set to 1) to be encoded for the corresponding mnemonic
+!> within the output subset.
+!>
+!> @remarks
+!> - If lunin < 0, and if abs(lunin) points to a file that is open
+!> for output (writing BUFR), then the subroutine will treat the file
+!> pointed to by abs(lunin) as though it was open for input (reading
+!> BUFR). This is a special capability for use by some applications
+!> that need to read certain values back out from a BUFR file during
+!> the same time that it is in the process of being written to.
+!>
+!> @param lunin - Absolute value is Fortran logical unit number for BUFR file
+!> @param usr - Data values
+!> - If abs(lunin) was opened for input, then usr is output from this subroutine and
+!> contains data values that were read from the current data subset
+!> - If abs(lunin) was opened for output, then usr is input to this subroutine and
+!> contains data values that are to be written to the current data subset
+!> @param i1 - First dimension of usr as allocated within the calling program
+!> @param i2 - Second dimension of usr
+!> - If abs(lunin) was opened for input, then i2 must be set equal to the second dimension
+!> of usr as allocated within the calling program
+!> - If abs(lunin) was opened for output, then i2 must be set equal to the number of replications
+!> of str that are to be written to the data subset
+!> @param iret - Number of replications of str that were read/written from/to the data subset
+!> @param str - String of blank-separated Table B mnemonics in one-to-one correspondence with the number of data values
+!> that will be read/written from/to the data subset within the first dimension of usr (see [DX BUFR Tables](@ref dfbftab)
+!> for further information about Table B mnemonics)
+!>
+!> @author J. Woollen @date 1994-01-06
+recursive subroutine ufbrep(lunin,usr,i1,i2,iret,str)
+
+ use modv_vars, only: im8b, bmiss
+
+ use moda_usrint
+ use moda_msgcwd
+
+ implicit none
+
+ character*(*), intent(in) :: str
+ character*128 bort_str1, bort_str2, errstr
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ integer, intent(in) :: lunin, i1, i2
+ integer, intent(out) :: iret
+ integer iprt, iac, ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, ia2, i, j
+
+ common /quiet/ iprt
+ common /acmode/ iac
+
+ data ifirst1 /0/
+
+ save ifirst1
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunin,my_lunin,1)
+ call x84(i1,my_i1,1)
+ call x84(i2,my_i2,1)
+ call ufbrep(my_lunin,usr,my_i1,my_i2,iret,str)
+ call x48(iret,iret,1)
+ im8b=.true.
+ return
+ endif
+
+ iret = 0
+
+ ! 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 ' // &
+ 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
+
+ io = min(max(0,il),1)
+ if(lunit.ne.lunin) io = 0
+
+ if(i1.le.0) then
+ if(iprt.ge.0) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ 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
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ if(iprt.eq.0 .and. io.eq.1) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
+ 'BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst1 = 1
+ endif
+ return
+ endif
+
+ ! Initialize usr array preceeding an input operation
+ if(io.eq.0) then
+ do j=1,i2
+ do i=1,I1
+ usr(i,j) = bmiss
+ enddo
+ enddo
+ endif
+
+ ! Parse or recall the input string
+ ia2 = iac
+ iac = 1
+ call string(str,lun,i1,io)
+
+ ! Call the mnemonic reader/writer
+ call ufbrp(lun,usr,i1,i2,io,iret)
+ iac = ia2
+
+ if(io.eq.1 .and. iret.lt.i2) then
+ write(bort_str1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS: ",A)') str
+ write(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '// &
+ 'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - INCOMPLETE WRITE")') iret,i2
+ call bort2(bort_str1,bort_str2)
+ endif
+
+ if(iret.eq.0 .and. io.eq.0 .and. iprt.ge.1) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+
+ return
+end subroutine ufbrep
+
+!> Read or write one or more data values from or to
+!> the BUFR data subset that is currently open within the NCEPLIBS-bufr
+!> internal arrays.
+!>
+!> The direction of the data transfer is determined by the context of abs(lunin):
+!> - If abs(lunin) points to a file that was previously opened for
+!> input using subroutine openbf(), then data values are read from
+!> the current data subset.
+!> - If abs(lunin) points to a file that was previously opened for
+!> output using subroutine openbf(), then data values are written to
+!> the current data subset.
+!>
+!> This subroutine is specifically designed for use with Table B
+!> mnemonics which are part of a fixed (i.e. non-delayed) replication
+!> sequence, or for mnemonics which are replicated by being directly
+!> listed more than once within an overall subset definition.
+!> It is very similar to subroutine ufbrep(), but it differs in how it
+!> processes the input mnemonic string str. For more details, see
+!> the discussion and example use case in [DX BUFR Tables](@ref ufbsubs).
+!> See also subroutines ufbint() and ufbseq(), which can also be used
+!> to read/write one or more data values from/to a data subset but are
+!> also designed for different use cases as noted in
+!> [DX BUFR Tables](@ref ufbsubs).
+!>
+!> It is the user's responsibility to ensure that usr is dimensioned
+!> sufficiently large enough to accommodate the number of data values
+!> that are to be read from or written to the data subset. Note also
+!> that usr is an array of real*8 values; therefore, any data that are
+!> to be written out as character (i.e. CCITT IA5) values in
+!> BUFR must be converted from character into real*8 format within the
+!> application program before calling this subroutine. Conversely,
+!> when this subroutine is being used to read character values from a
+!> data subset, the value that is returned will be in real*8 format
+!> and must be converted back into character format by the application
+!> program before it can be used as such. Alternatively, there are
+!> different subroutines such as readlc() and writlc() which can be
+!> used to read/write character data directly from/to a data subset
+!> without the need to convert from/to real*8 format as an intermediate
+!> step.
+!>
+!> Numeric (i.e. non-character) data values within usr are always in
+!> the exact units specified for the corresponding mnemonic within the
+!> relevant DX or master BUFR table, without any scale or reference
+!> values applied. Specifically, this means that, when writing
+!> data values into an output subset, the user only needs to store each
+!> respective value into usr using the units specified within the table,
+!> and the NCEPLIBS-bufr software will take care of any necessary scaling or
+!> referencing of the value before it is actually encoded into BUFR.
+!> Conversely, when reading data values from an input subset, the
+!> values returned in usr are already de-scaled and de-referenced and,
+!> thus, are already in the exact units that were defined for the
+!> corresponding mnemonics within the table.
+!>
+!> "Missing" values in usr are always denoted by a unique
+!> placeholder value. This placeholder value is initially set
+!> to a default value of 10E10_8, but it can be reset to
+!> any substitute value of the user's choice via a separate
+!> call to subroutine setbmiss(). In any case, and whenever this
+!> subroutine is used to read data values from an input subset, any
+!> returned value in usr can be easily checked for equivalence to the
+!> current placeholder value via a call to function ibfms(), and a
+!> positive result means that the value for the corresponding mnemonic
+!> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
+!> original data subset. Conversely, whenever this subroutine
+!> is used to write data values to an output subset, the current
+!> placeholder value can be obtained via a separate call to function
+!> getbmiss(), and the resulting value can then be stored into the
+!> usr array whereever the user desires a BUFR "missing" value (i.e.
+!> all bits set to 1) to be encoded for the corresponding mnemonic
+!> within the output subset.
+!>
+!> @remarks
+!> - If lunin < 0, and if abs(lunin) points to a file that is open
+!> for output (writing BUFR), then the subroutine will treat the file
+!> pointed to by abs(lunin) as though it was open for input (reading
+!> BUFR). This is a special capability for use by some applications
+!> that need to read certain values back out from a BUFR file during
+!> the same time that it is in the process of being written to.
+!>
+!> @param lunin - Absolute value is Fortran logical unit number for BUFR file
+!> @param usr - Data values
+!> - If abs(lunin) was opened for input, then usr is output from this subroutine and
+!> contains data values that were read from the current data subset
+!> - If abs(lunin) was opened for output, then usr is input to this subroutine and
+!> contains data values that are to be written to the current data subset
+!> @param i1 - First dimension of usr as allocated within the calling program
+!> @param i2 - Second dimension of usr
+!> - If abs(lunin) was opened for input, then i2 must be set equal to the second dimension
+!> of usr as allocated within the calling program
+!> - If abs(lunin) was opened for output, then i2 must be set equal to the number of replications
+!> of str that are to be written to the data subset
+!> @param iret - Number of replications of str that were read/written from/to the data subset
+!> @param str - String of blank-separated Table B mnemonics in one-to-one correspondence with the number of data values
+!> that will be read/written from/to the data subset within the first dimension of usr (see [DX BUFR Tables](@ref dfbftab)
+!> for further information about Table B mnemonics)
+!>
+!> @author J. Woollen @date 1994-01-06
+recursive subroutine ufbstp(lunin,usr,i1,i2,iret,str)
+
+ use modv_vars, only: im8b, bmiss
+
+ use moda_usrint
+ use moda_msgcwd
+
+ implicit none
+
+ character*(*), intent(in) :: str
+ character*128 bort_str1, bort_str2, errstr
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ integer, intent(in) :: lunin, i1, i2
+ integer, intent(out) :: iret
+ integer iprt, ifirst1, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j
+
+ common /quiet/ iprt
+
+ data ifirst1 /0/
+
+ save ifirst1
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunin,my_lunin,1)
+ call x84(i1,my_i1,1)
+ call x84(i2,my_i2,1)
+ call ufbstp(my_lunin,usr,my_i1,my_i2,iret,str)
+ call x48(iret,iret,1)
+ im8b=.true.
+ return
+ endif
+
+ iret = 0
+
+ ! 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 ' // &
+ 'WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
+
+ io = min(max(0,il),1)
+ if(lunit.ne.lunin) io = 0
+
+ if(i1.le.0) then
+ if(iprt.ge.0) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ 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
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ if(iprt.eq.0 .and. io.eq.1) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
+ 'BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst1 = 1
+ endif
+ return
+ endif
+
+ ! Initialize usr array preceeding an input operation
+ if(io.eq.0) then
+ do j=1,i2
+ do i=1,I1
+ usr(i,j) = bmiss
+ enddo
+ enddo
+ endif
+
+ ! Parse or recall the input string
+ call string(str,lun,i1,io)
+
+ ! Call the mnemonic reader/writer
+ call ufbsp(lun,usr,i1,i2,io,iret)
+
+ if(io.eq.1 .and. iret.ne.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
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+
+ return
+end subroutine ufbstp
+
+!> Read or write an entire sequence of data values
+!> from or to the BUFR data subset that is currently open within the
+!> NCEPLIBS_bufr internal arrays.
+!>
+!> The direction of the data transfer is determined by the context of abs(lunin):
+!> - If abs(lunin) points to a file that was previously opened for
+!> input using subroutine openbf(), then data values are read from
+!> the current data subset.
+!> - If abs(lunin) points to a file that was previously opened for
+!> output using subroutine openbf(), then data values are written to
+!> the current data subset.
+!>
+!> This subroutine is specifically designed for use with a single
+!> Table A or Table D mnemonic. In the latter case, the mnemonic
+!> may be replicated within the overall subset definition, and in
+!> which case the subroutine will return all data values within all
+!> replications of the sequence defined by the mnemonic. But in
+!> either case, the mnemonic itself may contain, within its own
+!> sequence definition, any number of data values defined by Table B
+!> mnemonics and/or subsequences of data values defined by other
+!> Table D mnemonics, and any such subsequences may themselves be
+!> replicated using any manner of fixed or delayed replication.
+!> See [DX BUFR Tables](@ref ufbsubs) for more details including
+!> an example use case, and see also subroutines ufbint(), ufbrep()
+!> and ufbstp() which are also used to read/write one or more data
+!> values from/to a data subset but cannot themselves be directly
+!> used with Table A or Table D mnemonics.
+!>
+!> It is the user's responsibility to ensure that usr is dimensioned
+!> sufficiently large enough to accommodate the number of data values
+!> that are to be read from or written to the data subset. Note also
+!> that usr is an array of real*8 values; therefore, any data that are
+!> to be written out as character (i.e. CCITT IA5) values in
+!> BUFR must be converted from character into real*8 format within the
+!> application program before calling this subroutine. Conversely,
+!> when this subroutine is being used to read character values from a
+!> data subset, the value that is returned will be in real*8 format
+!> and must be converted back into character format by the application
+!> program before it can be used as such. Alternatively, there are
+!> different subroutines such as readlc() and writlc() which can be
+!> used to read/write character data directly from/to a data subset
+!> without the need to convert from/to real*8 format as an intermediate
+!> step.
+!>
+!> Numeric (i.e. non-character) data values within usr are always in
+!> the exact units specified for the corresponding mnemonic within the
+!> relevant DX or master BUFR table, without any scale or reference
+!> values applied. Specifically, this means that, when writing
+!> data values into an output subset, the user only needs to store each
+!> respective value into usr using the units specified within the table,
+!> and the NCEPLIBS-bufr software will take care of any necessary scaling or
+!> referencing of the value before it is actually encoded into BUFR.
+!> Conversely, when reading data values from an input subset, the
+!> values returned in usr are already de-scaled and de-referenced and,
+!> thus, are already in the exact units that were defined for the
+!> corresponding mnemonics within the table.
+!>
+!> "Missing" values in usr are always denoted by a unique
+!> placeholder value. This placeholder value is initially set
+!> to a default value of 10E10_8, but it can be reset to
+!> any substitute value of the user's choice via a separate
+!> call to subroutine setbmiss(). In any case, and whenever this
+!> subroutine is used to read data values from an input subset, any
+!> returned value in usr can be easily checked for equivalence to the
+!> current placeholder value via a call to function ibfms(), and a
+!> positive result means that the value for the corresponding mnemonic
+!> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
+!> original data subset. Conversely, whenever this subroutine
+!> is used to write data values to an output subset, the current
+!> placeholder value can be obtained via a separate call to function
+!> getbmiss(), and the resulting value can then be stored into the
+!> usr array whereever the user desires a BUFR "missing" value (i.e.
+!> all bits set to 1) to be encoded for the corresponding mnemonic
+!> within the output subset.
+!>
+!> @remarks
+!> - If lunin < 0, and if abs(lunin) points to a file that is open
+!> for output (writing BUFR), then the subroutine will treat the file
+!> pointed to by abs(lunin) as though it was open for input (reading
+!> BUFR). This is a special capability for use by some applications
+!> that need to read certain values back out from a BUFR file during
+!> the same time that it is in the process of being written to.
+!> - If abs(lunin) points to a file that is open for output
+!> (writing BUFR), and if the data values to be written are part of
+!> a sequence replicated using delayed replication, then a call to
+!> subroutine drfini() must be made prior to calling this subroutine,
+!> in order to pre-allocate the necessary internal array space for
+!> the number of replications of the sequence.
+!>
+!> @param lunin - Absolute value is Fortran logical unit number for BUFR file
+!> @param usr - Data values
+!> - If abs(lunin) was opened for input, then usr is output from this subroutine and
+!> contains data values that were read from the current data subset
+!> - If abs(lunin) was opened for output, then usr is input to this subroutine and
+!> contains data values that are to be written to the current data subset
+!> @param i1 - First dimension of usr as allocated within the calling program
+!> @param i2 - Second dimension of usr
+!> - If abs(lunin) was opened for input, then i2 must be set equal to the second dimension
+!> of usr as allocated within the calling program
+!> - If abs(lunin) was opened for output, then i2 must be set equal to the number of replications
+!> of str that are to be written to the data subset
+!> @param iret - Number of replications of str that were read/written from/to the data subset
+!> @param str - String consisting of a single Table A or Table D mnemonic whose sequence definition is
+!> in one-to-one correspondence with the number of data values that will be read/written from/to the
+!> data subset within the first dimension of usr (see [DX BUFR Tables](@ref dfbftab)
+!> for further information about Table A and Table D mnemonics)
+!>
+!> @author J. Woollen @date 2000-09-19
+recursive subroutine ufbseq(lunin,usr,i1,i2,iret,str)
+
+ use modv_vars, only: im8b, bmiss
+
+ use moda_usrint
+ use moda_msgcwd
+ use moda_tables
+
+ implicit none
+
+ integer, intent(in) :: lunin, i1, i2
+ integer, intent(out) :: iret
+ integer, parameter :: mtag = 10
+ integer iprt, ifirst1, ifirst2, my_lunin, my_i1, my_i2, lunit, lun, il, im, io, i, j, ntag, node, nods, ins1, ins2, insx, &
+ nseq, isq, ityp, invwin, invtag
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ character*(*), intent(in) :: str
+ character*156 bort_str
+ character*128 errstr
+ character*10 tags(mtag)
+
+ common /quiet/ iprt
+
+ data ifirst1 /0/, ifirst2 /0/
+
+ save ifirst1, ifirst2
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunin,my_lunin,1)
+ call x84(i1,my_i1,1)
+ call x84(i2,my_i2,1)
+ call ufbseq(my_lunin,usr,my_i1,my_i2,iret,str)
+ call x48(iret,iret,1)
+ im8b=.true.
+ return
+ endif
+
+ iret = 0
+
+ ! 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')
+
+ io = min(max(0,il),1)
+ if(lunit.ne.lunin) io = 0
+
+ if(i1.le.0) then
+ if(iprt.ge.0) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ 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
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ if(iprt.eq.0 .and. io.eq.1) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
+ 'BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst1 = 1
+ endif
+ return
+ endif
+
+ ! Check for valid sequence and sequence length arguments
+ call parstr(str,tags,mtag,ntag,' ',.true.)
+ if(ntag.lt.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
+ 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 '// &
+ 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
+
+ ! Initialize usr array preceeding an input operation
+ if(io.eq.0) then
+ do j=1,i2
+ do i=1,I1
+ usr(i,j) = bmiss
+ enddo
+ enddo
+ endif
+
+ ! 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
+ 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
+ ins1 = ins1+1
+ enddo
+ ins2 = invtag(node,lun,ins1+1,nval(lun))
+ if(ins2.eq.0) ins2 = 10E5
+ nods = node
+ do while(link(nods).eq.0 .and. jmpb(nods).gt.0)
+ nods = jmpb(nods)
+ enddo
+ if(link(nods).eq.0) then
+ insx = nval(lun)
+ elseif(link(nods).gt.0) then
+ insx = invwin(link(nods),lun,ins1+1,nval(lun))-1
+ endif
+ ins2 = min(ins2,insx)
+ elseif(typ(node).eq.'SUB') then
+ ins1 = 1
+ ins2 = nval(lun)
+ else
+ write(bort_str,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '// &
+ 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') tags(1),typ(node)
+ call bort(bort_str)
+ endif
+ nseq = 0
+ do isq=ins1,ins2
+ ityp = itp(inv(isq,lun))
+ if(ityp.gt.1) nseq = nseq+1
+ enddo
+ if(nseq.gt.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)
+ endif
+ ! 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
+ ins1 = ins1+1
+ cycle
+ elseif(io.eq.0 .and. iret+1.gt.i2) then
+ if(iprt.ge.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'
+ call errwrt(errstr)
+ call errwrt('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
+ call errwrt(' ')
+ endif
+ exit outer
+ endif
+ elseif(ins1.eq.0) then
+ if(io.eq.1 .and. iret.lt.i2) then
+ write(bort_str,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN (",I5,") .LT. NO. REQUESTED (",I5,") - '// &
+ 'INCOMPLETE WRITE (INPUT MNEMONIC IS ",A,")")') iret,i2,tags(1)
+ call bort(bort_str)
+ endif
+ else
+ write(bort_str,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. ZERO, HERE IT IS",I4," - INPUT MNEMONIC '// &
+ 'IS ",A)') ins1,tags(1)
+ call bort(bort_str)
+ endif
+ if(ins1.eq.0 .or. iret.eq.i2) exit outer
+ iret = iret+1
+ ins1 = ins1+1
+ ! Read/write user values
+ j = ins1
+ do i=1,nseq
+ do while(itp(inv(j,lun)).lt.2)
+ j = j+1
+ enddo
+ if(io.eq.0) usr(i,iret) = val(j,lun)
+ if(io.eq.1) val(j,lun) = usr(i,iret)
+ j = j+1
+ enddo
+ enddo inner
+ endif
+ enddo outer
+
+ if(iret.eq.0) then
+ if(io.eq.0) then
+ if(iprt.ge.1) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ endif
+ else
+ if(iprt.eq.-1) ifirst2 = 1
+ if(ifirst2.eq.0 .or. iprt.ge.1) then
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ errstr = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
+ call errwrt(errstr)
+ call errwrt(str)
+ call errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
+ if(iprt.eq.0) then
+ errstr = 'Note: Only the first occurrence of this WARNING message is printed, there may be more. To output ' // &
+ 'all such messages,'
+ call errwrt(errstr)
+ errstr = 'modify your application program to add "CALL OPENBF(0,''QUIET'',1)" prior to the first call to a ' // &
+ 'BUFRLIB routine.'
+ call errwrt(errstr)
+ endif
+ call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
+ call errwrt(' ')
+ ifirst2 = 1
+ endif
+ endif
+ endif
+
+ return
+end subroutine ufbseq
+
+!> Explicitly initialize delayed replication factors
+!> and allocate a corresponding amount of space within internal arrays,
+!> thereby allowing the subsequent use of subroutine ufbseq() to write
+!> data into delayed replication sequences.
+!>
+!> @param lunit - Fortran logical unit number for BUFR file
+!> @param mdrf - Array of delayed replication factors, in one-to-one correspondence with the number of occurrences
+!> of drftag within the overall subset definition, and explicitly defining how much space (i.e. how many replications)
+!> to allocate within each successive occurrence
+!> @param ndrf - Number of delayed replication factors within mdrf
+!> @param drftag - Table D sequence mnemonic, bracketed by appropriate delayed replication notation (e.g. {}, () OR <>)
+!>
+!> Logical unit lunit should have already been opened for output
+!> operations (i.e. writing/encoding BUFR) via a previous call to
+!> subroutine openbf(), and a message for output should have already
+!> been opened via a previous call to one of the
+!> [message-writing subroutines].
+!>
+!> The use of this subroutine is only required when writing data
+!> into delayed replication sequences using ufbseq(), or for cases
+!> where ufbint() or ufbrep() are being used to write data into
+!> delayed replication sequences which occur more than once within
+!> an overall subset definition. In such cases, the use of this
+!> subroutine allows the application code to explicitly specify how
+!> many replications of the sequence are to be allocated to each
+!> occurrence of the delayed replication sequence within the overall
+!> subset definition, prior to storing all of the actual data values
+!> themselves via a single subsequent call to ufbint() or ufbrep().
+!> In contrast, the use of this subroutine is not required when
+!> ufbint() or ufbrep() are to be called to store data values
+!> for a delayed replication sequence which only occurs one time
+!> within an overall subset definition, because in that case the
+!> same type of initialization and space allocation functionality
+!> will be automatically handled internally within subroutine
+!> ufbint() or ufbrep().
+!>
+!> @author J. Woollen @date 2002-05-14
+recursive subroutine drfini(lunit,mdrf,ndrf,drftag)
+
+ use modv_vars, only: im8b
+
+ use moda_usrint
+ use moda_tables
+
+ implicit none
+
+ character*(*), intent(in) :: drftag
+
+ integer, intent(in) :: mdrf(*), lunit, ndrf
+ integer, parameter :: mxdrf = 2000
+ integer my_mdrf(mxdrf), my_lunit, my_ndrf, mdrf4, ii, lun, il, im, m, n, node
+
+ ! Check for I8 integers
+ if(im8b) then
+ im8b=.false.
+ call x84(lunit,my_lunit,1)
+ do ii = 1, ndrf
+ call x84(mdrf(ii),mdrf4,1)
+ my_mdrf(ii) = mdrf4
+ enddo
+ call x84(ndrf,my_ndrf,1)
+ call drfini(my_lunit,my_mdrf,my_ndrf,drftag)
+ im8b=.true.
+ return
+ endif
+
+ call status(lunit,lun,il,im)
+ ! Conform the template to the delayed replication factors
+ m = 0
+ n = 0
+ do n = n+1, nval(lun)
+ node = inv(n,lun)
+ if(itp(node).eq.1 .and. tag(node).eq.drftag) then
+ m = m+1
+ call usrtpl(lun,n,mdrf(m))
+ endif
+ enddo
+
+ return
+end subroutine drfini
+
+!> Write or read specified values to or from
+!> the current BUFR data subset within internal arrays, with the
+!> direction of the data transfer determined by the context of io.
+!>
+!> The data values correspond to internal arrays representing parsed
+!> strings of mnemonics which are part of a delayed-replication
+!> sequence, or for which there is no replication at all.
+!>
+!> This subroutine should never be directly called by an application
+!> program; instead, an application program should directly call ufbint()
+!> which will internally call this subroutine.
+!>
+!> @param lun - File ID
+!> @param usr - Data values
+!> @param i1 - Length of first dimension of usr
+!> @param i2 - Length of second dimension of usr
+!> @param io - Status indicator for BUFR file associated with lun:
+!> - 0 input file
+!> - 1 output file
+!> @param iret - Number of "levels" of data values read from or written to data subset
+!> - -1 none of the mnemonics in the string passed to ufbint() were found in the data subset template
+!>
+!> @author J. Woollen @date 1994-01-06
+subroutine ufbrw(lun,usr,i1,i2,io,iret)
+
+ use modv_vars, only: bmiss
+
+ use moda_usrint
+ use moda_tables
+ use moda_msgcwd
+
+ implicit none
+
+ integer, intent(in) :: lun, i1, i2, io
+ integer, intent(out) :: iret
+ integer iprt, nnod, ncon, nods, nodc, ivls, kons, inc1, inc2, ins1, ins2, invn, i, j, invwin, ibfms, lstjpb
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ character*128 errstr
+ character*10 tagstr, subset
+
+ common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
+ common /quiet/ iprt
+
+ subset=tag(inode(lun))
+ iret = 0
+
+ ! Loop over condition windows
+ inc1 = 1
+ inc2 = 1
+ outer: do while (.true.)
+ call conwin(lun,inc1,inc2)
+ if(nnod.eq.0) then
+ iret = i2
+ return
+ elseif(inc1.eq.0) then
+ return
+ else
+ do j=1,nnod
+ if(nods(j).gt.0) then
+ ins2 = inc1
+ call getwin(nods(j),lun,ins1,ins2)
+ if(ins1.eq.0) return
+ do while (.true.)
+ ! Loop over store nodes
+ iret = iret+1
+ if(iprt.ge.2) then
+ call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
+ call errwrt('UFBRW LEV TAG IO INS1 INVN INS2 '//SUBSET)
+ call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
+ do i=1,nnod
+ 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)
+ 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
+ do i=1,nnod
+ if(nods(i).gt.0) then
+ if(ibfms(usr(i,iret)).eq.0) then
+ invn = invwin(nods(i),lun,ins1,ins2)
+ if(invn.eq.0) then
+ call drstpl(nods(i),lun,ins1,ins2,invn)
+ if(invn.eq.0) then
+ iret = 0
+ return
+ endif
+ call newwin(lun,inc1,inc2)
+ val(invn,lun) = usr(i,iret)
+ elseif(lstjpb(nods(i),lun,'RPS').eq.0) then
+ val(invn,lun) = usr(i,iret)
+ elseif(ibfms(val(invn,lun)).ne.0) then
+ val(invn,lun) = usr(i,iret)
+ else
+ call drstpl(nods(i),lun,ins1,ins2,invn)
+ if(invn.eq.0) then
+ iret = 0
+ return
+ ENDIF
+ call newwin(lun,inc1,inc2)
+ val(invn,lun) = usr(i,iret)
+ endif
+ endif
+ endif
+ enddo
+ endif
+ ! Read user values
+ if(io.eq.0 .and. iret.le.i2) then
+ do i=1,nnod
+ usr(i,iret) = bmiss
+ if(nods(i).gt.0) then
+ invn = invwin(nods(i),lun,ins1,ins2)
+ if(invn.gt.0) usr(i,iret) = val(invn,lun)
+ endif
+ enddo
+ endif
+ ! Decide what to do next
+ if(io.eq.1.and.iret.eq.i2) return
+ call nxtwin(lun,ins1,ins2)
+ if(ins1.gt.0 .and. ins1.lt.inc2) cycle
+ if(ncon.gt.0) cycle outer
+ return
+ enddo
+ endif
+ enddo
+ iret = -1
+ return
+ endif
+ enddo outer
+
+ return
+end subroutine ufbrw
+
+!> Write or read specified data values to or
+!> from the current BUFR data subset within internal arrays, with the
+!> direction of the data transfer determined by the context of io.
+!>
+!> The data values correspond to internal arrays representing parsed
+!> strings of mnemonics which are either part of a fixed (i.e. non-delayed)
+!> replication sequence, or for mnememonics which are replicated by being
+!> directly listed more than once within an overall subset definition.
+!>
+!> This subroutine should never be directly called by an application
+!> program; instead, an application program should directly call ufbrep()
+!> which will internally call this subroutine.
+!>
+!> @param lun - File ID
+!> @param usr - Data values
+!> @param i1 - Length of first dimension of usr
+!> @param i2 - Length of second dimension of usr
+!> @param io - Status indicator for BUFR file associated with lun:
+!> - 0 input file
+!> - 1 output file
+!> @param iret - Number of "levels" of data values read from or written to data subset
+!>
+!> @author J. Woollen @date 1994-01-06
+subroutine ufbrp(lun,usr,i1,i2,io,iret)
+
+ use moda_usrint
+
+ implicit none
+
+ integer, intent(in) :: lun, i1, i2, io
+ integer, intent(out) :: iret
+ integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, i, nz, invtag
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
+
+ iret = 0
+ ins1 = 0
+ ins2 = 0
+
+ ! Find first non-zero node in string
+ do nz=1,nnod
+ if(nods(nz).gt.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
+ ins1 = invtag(nods(nz),lun,ins1+1,nval(lun))
+ if(ins1.eq.0) return
+ ins2 = invtag(nods(nz),lun,ins1+1,nval(lun))
+ if(ins2.eq.0) ins2 = nval(lun)
+ iret = iret+1
+ ! Read user values
+ if(io.eq.0 .and. iret.le.i2) then
+ do i=1,nnod
+ if(nods(i).gt.0) then
+ invn = invtag(nods(i),lun,ins1,ins2)
+ if(invn.gt.0) usr(i,iret) = val(invn,lun)
+ endif
+ enddo
+ endif
+ ! Write user values
+ if(io.eq.1 .and. iret.le.i2) then
+ do i=1,nnod
+ if(nods(i).gt.0) then
+ invn = invtag(nods(i),lun,ins1,ins2)
+ if(invn.gt.0) val(invn,lun) = usr(i,iret)
+ endif
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+
+ return
+end subroutine ufbrp
+
+!> Write or read specified values to or
+!> from the current BUFR data subset within internal arrays, with the
+!> direction of the data transfer determined by the context of io.
+!>
+!> The data values correspond to internal arrays representing parsed
+!> strings of mnemonics which are either part of a fixed (i.e. non-delayed)
+!> replication sequence, or for mnememonics which are replicated by being
+!> directly listed more than once within an overall subset definition.
+!>
+!> This subroutine should never be directly called by an application
+!> program; instead, an application program should directly call ufbstp()
+!> which will internally call this subroutine.
+!>
+!> This subroutine is similar to subroutine ufbrp(), but it is designed
+!> for different use cases. For a more detailed explanation of how
+!> subroutine ufbstp() differs from subroutine ufbrep(), and therefore
+!> how this subroutine differs from subroutine ufbrp(), see the
+!> discussion in [DX BUFR Tables](@ref ufbsubs).
+!>
+!> @param lun - File ID
+!> @param usr - Data values
+!> @param i1 - Length of first dimension of usr
+!> @param i2 - Length of second dimension of usr
+!> @param io - Status indicator for BUFR file associated with lun:
+!> - 0 input file
+!> - 1 output file
+!> @param iret - Number of "levels" of data values read from or written to data subset
+!>
+!> @author J. Woollen @date 1999-11-18
+subroutine ufbsp(lun,usr,i1,i2,io,iret)
+
+ use moda_usrint
+
+ implicit none
+
+ integer, intent(in) :: lun, i1, i2, io
+ integer, intent(out) :: iret
+ integer nnod, ncon, nods, nodc, ivls, kons, ins1, ins2, invn, invm, i, invtag
+
+ real*8, intent(inout) :: usr(i1,i2)
+
+ common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
+
+ iret = 0
+ ins1 = 0
+ ins2 = 0
+
+ do while (.true.)
+ ! Frame a section of the buffer - return when no frame
+ if(ins1+1.gt.nval(lun)) return
+ ins1 = invtag(nods(1),lun,ins1+1,nval(lun))
+ if(ins1.eq.0) return
+ ins2 = invtag(nods(1),lun,ins1+1,nval(lun))
+ if(ins2.eq.0) ins2 = nval(lun)
+ iret = iret+1
+ ! Read user values
+ if(io.eq.0 .and. iret.le.i2) then
+ invm = ins1
+ do i=1,nnod
+ if(nods(i).gt.0) then
+ invn = invtag(nods(i),lun,invm,ins2)
+ if(invn.gt.0) usr(i,iret) = val(invn,lun)
+ invm = max(invn,invm)
+ endif
+ enddo
+ endif
+ ! Write user values
+ if(io.eq.1 .and. iret.le.i2) then
+ invm = ins1
+ do i=1,nnod
+ if(nods(i).gt.0) then
+ invn = invtag(nods(i),lun,invm,ins2)
+ if(invn.gt.0) val(invn,lun) = usr(i,iret)
+ invm = max(invn,invm)
+ endif
+ enddo
+ endif
+ enddo
+
+ return
+end subroutine ufbsp
diff --git a/src/setvalnb.f b/src/setvalnb.f
deleted file mode 100644
index 941711568..000000000
--- a/src/setvalnb.f
+++ /dev/null
@@ -1,106 +0,0 @@
-C> @file
-C> @brief Write one data value to a data subset.
-C>
-C> @author J. Ator @date 2016-07-29
-
-C> Write a data value corresponding to
-C> a specific occurrence of a mnemonic within a data subset, based on
-C> its position relative to a different mnemonic within the subset.
-C>
-C> The subroutine first searches for a specific occurrence of a pivot
-C> mnemonic, counting from the beginning of the subset. From there,
-C> it then searches in either a forward or backward direction for a
-C> specific occurrence of a nearby mnemonic, and if found
-C> stores the specified data value in the corresponding location
-C> within the subset.
-C>
-C> Before calling this subroutine, a BUFR message should already be
-C> opened and initialized for output via a previous call to one of the
-C> NCEPLIBS-bufr [message-writing subroutines](@ref hierarchy).
-C>
-C> @param[in] LUNIT -- integer: Fortran logical unit number for
-C> BUFR file
-C> @param[in] TAGPV -- character*(*): Pivot mnemonic; the subroutine
-C> will first search for the (NTAGPV)th occurrence
-C> of this mnemonic, counting from the beginning
-C> of the overall subset definition
-C> @param[in] NTAGPV -- integer: Ordinal occurrence of TAGPV to search for,
-C> counting from the beginning of the overall
-C> subset definition
-C> @param[in] TAGNB -- character*(*): Nearby mnemonic; assuming TAGPV is
-C> successfully found, the subroutine will then search
-C> nearby for the (NTAGNB)th occurrence of TAGNB and
-C> store R8VAL as the corresponding value
-C> @param[in] NTAGNB -- integer: Ordinal occurrence of TAGNB to search for,
-C> counting from the location of TAGPV within the
-C> overall subset definition. If NTAGNB is positive,
-C> the subroutine will search in a forward direction
-C> from the location of TAGPV; otherwise, if NTAGNB is
-C> negative, it will instead search in a backwards
-C> direction from the location of TAGPV.
-C> @param[in] R8VAL -- real*8: Value to be stored corresponding to
-C> (NTAGNB)th occurrence of TAGNB within the subset
-C> @param[out] IRET -- integer: return code
-C> - 0 = R8VAL was successfully stored
-C> - -1 = the (NTAGNB)th occurence of mnemonic TAGNB
-C> could not be found, or some other error
-C> occurred
-C>
-C> @author J. Ator @date 2016-07-29
- RECURSIVE SUBROUTINE SETVALNB
- . ( LUNIT, TAGPV, NTAGPV, TAGNB, NTAGNB, R8VAL, IRET )
-
- use modv_vars, only: im8b
-
- use moda_usrint
- use moda_msgcwd
- use moda_tables
-
- CHARACTER*(*) TAGPV, TAGNB
-
- REAL*8 R8VAL
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C Check for I8 integers.
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84 ( LUNIT, MY_LUNIT, 1 )
- CALL X84 ( NTAGPV, MY_NTAGPV, 1 )
- CALL X84 ( NTAGNB, MY_NTAGNB, 1 )
- CALL SETVALNB ( MY_LUNIT, TAGPV, MY_NTAGPV, TAGNB, MY_NTAGNB,
- . R8VAL, IRET )
- CALL X48 ( IRET, IRET, 1 )
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IRET = -1
-
-C Get LUN from LUNIT.
-
- CALL STATUS (LUNIT, LUN, IL, IM )
- IF ( IL .LE. 0 ) RETURN
- IF ( INODE(LUN) .NE. INV(1,LUN) ) RETURN
-
-C Starting from the beginning of the subset, locate the (NTAGPV)th
-C occurrence of TAGPV.
-
- CALL FSTAG( LUN, TAGPV, NTAGPV, 1, NPV, IERFT )
- IF ( IERFT .NE. 0 ) RETURN
-
-C Now, starting from the (NTAGPV)th occurrence of TAGPV, search
-C forward or backward for the (NTAGNB)th occurrence of TAGNB.
-
- CALL FSTAG( LUN, TAGNB, NTAGNB, NPV, NNB, IERFT )
- IF ( IERFT .NE. 0 ) RETURN
-
- IRET = 0
- VAL(NNB,LUN) = R8VAL
-
- RETURN
- END
diff --git a/src/ufbint.f b/src/ufbint.f
deleted file mode 100644
index 7764db18c..000000000
--- a/src/ufbint.f
+++ /dev/null
@@ -1,290 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1994-01-06
-
-C> Read or write one or more data values from or to
-C> the BUFR data subset that is currently open within the NCEPLIBS-bufr
-C> internal arrays. The direction of the data transfer is determined
-C> by the context of ABS(LUNIN):
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> input using subroutine openbf(), then data values are read from
-C> the current data subset.
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> output using subroutine openbf(), then data values are written to
-C> the current data subset.
-C>
-C> This subroutine is specifically designed for use with Table B
-C> mnemonics which are part of a delayed-replication sequence, or for
-C> which there is no replication at all. See also subroutines ufbrep(),
-C> ufbseq() and ufbstp(), which can also be used to read/write one or
-C> more data values from/to a data subset but are designed for
-C> different use cases. A more detailed discussion of
-C> these different use cases, including examples, is available in
-C> [DX BUFR Tables](@ref ufbsubs).
-C>
-C> It is the user's responsibility to ensure that USR is dimensioned
-C> sufficiently large enough to accommodate the number of data values
-C> that are to be read from or written to the data subset. Note also
-C> that USR is an array of real*8 values; therefore, any data that are
-C> to be written out as character (i.e. CCITT IA5) values in
-C> BUFR must be converted from character into real*8 format within the
-C> application program before calling this subroutine. Conversely,
-C> when this subroutine is being used to read character values from a
-C> data subset, the value that is returned will be in real*8 format
-C> and must be converted back into character format by the application
-C> program before it can be used as such. Alternatively, there are
-C> different subroutines such as readlc() and writlc() which can be
-C> used to read/write character data directly from/to a data subset
-C> without the need to convert from/to real*8 format as an intermediate
-C> step.
-C>
-C> Numeric (i.e. non-character) data values within USR are always in
-C> the exact units specified for the corresponding mnemonic within the
-C> relevant DX or master BUFR table, without any scale or reference
-C> values applied. Specifically, this means that, when writing
-C> data values into an output subset, the user only needs to store each
-C> respective value into USR using the units specified within the table,
-C> and the NCEPLIBS-bufr software will take care of any necessary scaling or
-C> referencing of the value before it is actually encoded into BUFR.
-C> Conversely, when reading data values from an input subset, the
-C> values returned in USR are already de-scaled and de-referenced and,
-C> thus, are already in the exact units that were defined for the
-C> corresponding mnemonics within the table.
-C>
-C> "Missing" values in USR are always denoted by a unique
-C> placeholder value. This placeholder value is initially set
-C> to a default value of 10E10_8, but it can be reset to
-C> any substitute value of the user's choice via a separate
-C> call to subroutine setbmiss(). In any case, and whenever this
-C> subroutine is used to read data values from an input subset, any
-C> returned value in USR can be easily checked for equivalence to the
-C> current placeholder value via a call to function ibfms(), and a
-C> positive result means that the value for the corresponding mnemonic
-C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
-C> original data subset. Conversely, whenever this subroutine
-C> is used to write data values to an output subset, the current
-C> placeholder value can be obtained via a separate call to function
-C> getbmiss(), and the resulting value can then be stored into the
-C> USR array whereever the user desires a BUFR "missing" value (i.e.
-C> all bits set to 1) to be encoded for the corresponding mnemonic
-C> within the output subset.
-C>
-C> @remarks
-C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
-C> for output (writing BUFR), then the subroutine will treat the file
-C> pointed to by ABS(LUNIN) as though it was open for input (reading
-C> BUFR). This is a special capability for use by some applications
-C> that need to read certain values back out from a BUFR file during
-C> the same time that it is in the process of being written to.
-C> - If ABS(LUNIN) points to a file that is open for input (reading
-C> BUFR), STR may contain a Table D mnemonic that is replicated using
-C> either 8-bit or 16-bit delayed replication (as noted using
-C> replication indicators {} or (), respectively, within the
-C> assocated DX BUFR table), and the corresponding location in USR
-C> will contain the total number of replications of that mnemonic
-C> within the data subset. Note that, when using this option, the
-C> applicable replication indicators must be included in STR
-C> along with the mnemonic itself, as shown in an example in the
-C> discussion of [DX BUFR Tables](@ref ufbsubs).
-C>
-C> @param[in] LUNIN - integer: Absolute value is Fortran logical
-C> unit number for BUFR file.
-C> @param[in,out] USR - real*8(*,*): Data values
-C> - If ABS(LUNIN) was opened for input, then USR is output from this subroutine and
-C> contains data values that were read from the current data subset.
-C> - If ABS(LUNIN) was opened for output, then USR is input to this subroutine and
-C> contains data values that are to be written to the current data subset.
-C> @param[in] I1 - integer: First dimension of USR as allocated
-C> within the calling program.
-C> @param[in] I2 - integer:
-C> - If ABS(LUNIN) was opened for input, then I2
-C> must be set equal to the second dimension
-C> of USR as allocated within the calling program
-C> - If ABS(LUNIN) was opened for output, then I2
-C> must be set equal to the number of replications
-C> of STR that are to be written to the data subset
-C> @param[out] IRET - integer: Number of replications of STR that were
-C> read/written from/to the data subset
-C> @param[in] STR - character*(*): String of blank-separated
-C> Table B mnemonics in one-to-one correspondence with the number of data
-C> values that will be read/written from/to the data
-C> subset within the first dimension of USR (see
-C> [DX BUFR Tables](@ref dfbftab) for further
-C> information about Table B mnemonics)
-C>
-C> @author J. Woollen @date 1994-01-06
-
- RECURSIVE SUBROUTINE UFBINT(LUNIN,USR,I1,I2,IRET,STR)
-
- use modv_vars, only: im8b, bmiss
-
- use moda_usrint
- use moda_msgcwd
-
- COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) STR
- CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR
- REAL*8 USR(I1,I2)
-
- DATA IFIRST1/0/,IFIRST2/0/
-
- SAVE IFIRST1, IFIRST2
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIN,MY_LUNIN,1)
- CALL X84(I1,MY_I1,1)
- CALL X84(I2,MY_I2,1)
- CALL UFBINT(MY_LUNIN,USR,MY_I1,MY_I2,IRET,STR)
- CALL X48(IRET,IRET,1)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IRET = 0
-
-C CHECK THE FILE STATUS AND I-NODE
-C --------------------------------
-
- LUNIT = ABS(LUNIN)
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IM.EQ.0) GOTO 901
- IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902
-
- IO = MIN(MAX(0,IL),1)
- IF(LUNIT.NE.LUNIN) IO = 0
-
- IF(I1.LE.0) THEN
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 100
- ELSEIF(I2.LE.0) THEN
- IF(IPRT.EQ.-1) IFIRST1 = 1
- IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST1 = 1
- ENDIF
- GOTO 100
- ENDIF
-
-C PARSE OR RECALL THE INPUT STRING
-C --------------------------------
-
- CALL STRING(STR,LUN,I1,IO)
-
-C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
-C --------------------------------------------------
-
- IF(IO.EQ.0) THEN
- DO J=1,I2
- DO I=1,I1
- USR(I,J) = BMISS
- ENDDO
- ENDDO
- ENDIF
-
-C CALL THE MNEMONIC READER/WRITER
-C -------------------------------
-
- CALL UFBRW(LUN,USR,I1,I2,IO,IRET)
-
-C IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN
-C ---------------------------------------------------------------------
-
- IF(IO.EQ.1 .AND. IRET.NE.I2 .AND. IRET.GE.0) THEN
- CALL TRYBUMP(LUN,USR,I1,I2,IO,IRET)
- IF(IRET.NE.I2) GOTO 903
- ELSEIF(IRET.EQ.-1) THEN
- IRET = 0
- ENDIF
-
- IF(IRET.EQ.0) THEN
- IF(IO.EQ.0) THEN
- IF(IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- ELSE
- IF(IPRT.EQ.-1) IFIRST2 = 1
- IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)')
- IF(IPRT.EQ.0) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST2 = 1
- ENDIF
- ENDIF
- ENDIF
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE'//
- . ' OPEN')
-901 CALL BORT('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR '//
- . 'FILE, NONE ARE')
-902 CALL BORT('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR '//
- . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
- . 'SUBSET ARRAY')
-903 WRITE(BORT_STR1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS'//
- . ': ",A)') STR
- WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
- . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
- . ' - INCOMPLETE WRITE")') IRET,I2
- CALL BORT2(BORT_STR1,BORT_STR2)
- END
diff --git a/src/ufbrep.f b/src/ufbrep.f
deleted file mode 100644
index c40812deb..000000000
--- a/src/ufbrep.f
+++ /dev/null
@@ -1,257 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1994-01-06
-
-C> Read or write one or more data values from or to
-C> the BUFR data subset that is currently open within the NCEPLIBS-bufr
-C> internal arrays. The direction of the data transfer is determined
-C> by the context of ABS(LUNIN):
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> input using subroutine openbf(), then data values are read from
-C> the current data subset.
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> output using subroutine openbf(), then data values are written to
-C> the current data subset.
-C>
-C> This subroutine is specifically designed for use with Table B
-C> mnemonics which are part of a fixed (i.e. non-delayed) replication
-C> sequence, or for mnemonics which are replicated by being directly
-C> listed more than once within an overall subset definition.
-C> See also subroutines ufbint(),
-C> ufbseq() and ufbstp(), which can also be used to read/write one or
-C> more data values from/to a data subset but are designed for
-C> different use cases. A more detailed discussion of
-C> these different use cases, including examples, is available in
-C> [DX BUFR Tables](@ref ufbsubs).
-C>
-C> It is the user's responsibility to ensure that USR is dimensioned
-C> sufficiently large enough to accommodate the number of data values
-C> that are to be read from or written to the data subset. Note also
-C> that USR is an array of real*8 values; therefore, any data that are
-C> to be written out as character (i.e. CCITT IA5) values in
-C> BUFR must be converted from character into real*8 format within the
-C> application program before calling this subroutine. Conversely,
-C> when this subroutine is being used to read character values from a
-C> data subset, the value that is returned will be in real*8 format
-C> and must be converted back into character format by the application
-C> program before it can be used as such. Alternatively, there are
-C> different subroutines such as readlc() and writlc() which can be
-C> used to read/write character data directly from/to a data subset
-C> without the need to convert from/to real*8 format as an intermediate
-C> step.
-C>
-C> Numeric (i.e. non-character) data values within USR are always in
-C> the exact units specified for the corresponding mnemonic within the
-C> relevant DX or master BUFR table, without any scale or reference
-C> values applied. Specifically, this means that, when writing
-C> data values into an output subset, the user only needs to store each
-C> respective value into USR using the units specified within the table,
-C> and the NCEPLIBS-bufr software will take care of any necessary scaling or
-C> referencing of the value before it is actually encoded into BUFR.
-C> Conversely, when reading data values from an input subset, the
-C> values returned in USR are already de-scaled and de-referenced and,
-C> thus, are already in the exact units that were defined for the
-C> corresponding mnemonics within the table.
-C>
-C> "Missing" values in USR are always denoted by a unique
-C> placeholder value. This placeholder value is initially set
-C> to a default value of 10E10_8, but it can be reset to
-C> any substitute value of the user's choice via a separate
-C> call to subroutine setbmiss(). In any case, and whenever this
-C> subroutine is used to read data values from an input subset, any
-C> returned value in USR can be easily checked for equivalence to the
-C> current placeholder value via a call to function ibfms(), and a
-C> positive result means that the value for the corresponding mnemonic
-C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
-C> original data subset. Conversely, whenever this subroutine
-C> is used to write data values to an output subset, the current
-C> placeholder value can be obtained via a separate call to function
-C> getbmiss(), and the resulting value can then be stored into the
-C> USR array whereever the user desires a BUFR "missing" value (i.e.
-C> all bits set to 1) to be encoded for the corresponding mnemonic
-C> within the output subset.
-C>
-C> @remarks
-C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
-C> for output (writing BUFR), then the subroutine will treat the file
-C> pointed to by ABS(LUNIN) as though it was open for input (reading
-C> BUFR). This is a special capability for use by some applications
-C> that need to read certain values back out from a BUFR file during
-C> the same time that it is in the process of being written to.
-C>
-C> @param[in] LUNIN - integer: Absolute value is Fortran logical
-C> unit number for BUFR file.
-C> @param[in,out] USR - real*8(*,*): Data values
-C> - If ABS(LUNIN) was opened for input, then
-C> USR is output from this subroutine and
-C> contains data values that were read
-C> from the current data subset.
-C> - If ABS(LUNIN) was opened for output, then
-C> USR is input to this subroutine and
-C> contains data values that are to be
-C> written to the current data subset.
-C> @param[in] I1 - integer: First dimension of USR as allocated
-C> within the calling program.
-C> @param[in] I2 - integer:
-C> - If ABS(LUNIN) was opened for input, then I2
-C> must be set equal to the second dimension
-C> of USR as allocated within the calling program
-C> - If ABS(LUNIN) was opened for output, then I2
-C> must be set equal to the number of replications
-C> of STR that are to be written to the data subset
-C> @param[out] IRET - integer: Number of replications of STR that were
-C> read/written from/to the data subset.
-C> @param[in] STR - character*(*): String of blank-separated
-C> Table B mnemonics in one-to-one correspondence with the number of data
-C> values that will be read/written from/to the data
-C> subset within the first dimension of USR (see
-C> [DX BUFR Tables](@ref dfbftab) for further
-C> information about Table B mnemonics).
-C>
-C> @author J. Woollen @date 1994-01-06
- RECURSIVE SUBROUTINE UFBREP(LUNIN,USR,I1,I2,IRET,STR)
-
- use modv_vars, only: im8b, bmiss
-
- use moda_usrint
- use moda_msgcwd
-
- COMMON /ACMODE/ IAC
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) STR
- CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR
- REAL*8 USR(I1,I2)
-
- DATA IFIRST1/0/
-
- SAVE IFIRST1
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIN,MY_LUNIN,1)
- CALL X84(I1,MY_I1,1)
- CALL X84(I2,MY_I2,1)
- CALL UFBREP(MY_LUNIN,USR,MY_I1,MY_I2,IRET,STR)
- CALL X48(IRET,IRET,1)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IRET = 0
-
-C CHECK THE FILE STATUS AND I-NODE
-C --------------------------------
-
- LUNIT = ABS(LUNIN)
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IM.EQ.0) GOTO 901
- IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902
-
- IO = MIN(MAX(0,IL),1)
- IF(LUNIN.NE.LUNIT) IO = 0
-
- IF(I1.LE.0) THEN
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBREP - 3rd ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 100
- ELSEIF(I2.LE.0) THEN
- IF(IPRT.EQ.-1) IFIRST1 = 1
- IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBREP - 4th ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST1 = 1
- ENDIF
- GOTO 100
- ENDIF
-
-C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
-C --------------------------------------------------
-
- IF(IO.EQ.0) THEN
- DO J=1,I2
- DO I=1,I1
- USR(I,J) = BMISS
- ENDDO
- ENDDO
- ENDIF
-
-C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
-C ----------------------------------------------------
-
- IA2 = IAC
- IAC = 1
- CALL STRING(STR,LUN,I1,IO)
-
-C CALL THE MNEMONIC READER/WRITER
-C -------------------------------
-
- CALL UFBRP(LUN,USR,I1,I2,IO,IRET)
- IAC = IA2
-
- IF(IO.EQ.1 .AND. IRET.LT.I2) GOTO 903
-
- IF(IRET.EQ.0) THEN
- IF(IO.EQ.0) THEN
- IF(IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBREP - NO SPECIFIED VALUES READ IN, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- ENDIF
- ENDIF
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: UFBREP - BUFR FILE IS CLOSED, IT MUST BE'//
- . ' OPEN')
-901 CALL BORT('BUFRLIB: UFBREP - A MESSAGE MUST BE OPEN IN BUFR '//
- . 'FILE, NONE ARE')
-902 CALL BORT('BUFRLIB: UFBREP - LOCATION OF INTERNAL TABLE FOR '//
- . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
- . 'SUBSET ARRAY')
-903 WRITE(BORT_STR1,'("BUFRLIB: UFBREP - MNEMONIC STRING READ IN IS'//
- . ': ",A)') STR
- WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
- . 'WRITTEN (",I3,") LESS THAN THE NUMBER REQUESTED (",I3,") - '//
- . 'INCOMPLETE WRITE")') IRET,I2
- CALL BORT2(BORT_STR1,BORT_STR2)
- END
diff --git a/src/ufbrp.f b/src/ufbrp.f
deleted file mode 100644
index 0075dd65c..000000000
--- a/src/ufbrp.f
+++ /dev/null
@@ -1,98 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1994-01-06
-
-C> Write or read specified data values to or
-C> from the current BUFR data subset within internal arrays, with the
-C> direction of the data transfer determined by the context of IO.
-C> The data values correspond to internal arrays representing parsed
-C> strings of mnemonics which are either part of a fixed (i.e. non-delayed)
-C> replication sequence, or for mnememonics which are replicated by being
-C> directly listed more than once within an overall subset definition.
-C>
-C> This subroutine should never be directly called by an application
-C> program; instead, an application program should directly call ufbrep()
-C> which will internally call this subroutine.
-C>
-C> @param[in] LUN - integer: file ID.
-C> @param[inout] USR - real*8(*,*): Data values
-C> @param[in] I1 - integer: length of first dimension of USR.
-C> @param[in] I2 - integer: length of second dimension of USR.
-C> @param[in] IO - integer: status indicator for BUFR file associated
-C> with LUN:
-C> - 0 input file
-C> - 1 output file
-C> @param[out] IRET - integer: number of "levels" of data values read
-C> from or written to data subset
-C>
-C> @author J. Woollen @date 1994-01-06
- SUBROUTINE UFBRP(LUN,USR,I1,I2,IO,IRET)
-
- use moda_usrint
-
- COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
-
- REAL*8 USR(I1,I2)
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
- IRET = 0
- INS1 = 0
- INS2 = 0
-
-C FIND FIRST NON-ZERO NODE IN STRING
-C ----------------------------------
-
- DO NZ=1,NNOD
- IF(NODS(NZ).GT.0) GOTO 1
- ENDDO
- GOTO 100
-
-C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
-C ----------------------------------------------------
-
-1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100
- IF(IO.EQ.1 .AND. IRET.EQ.I2) GOTO 100
- INS1 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN))
- IF(INS1.EQ.0) GOTO 100
-
- INS2 = INVTAG(NODS(NZ),LUN,INS1+1,NVAL(LUN))
- IF(INS2.EQ.0) INS2 = NVAL(LUN)
- IRET = IRET+1
-
-C READ USER VALUES
-C ----------------
-
- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- INVN = INVTAG(NODS(I),LUN,INS1,INS2)
- IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
- ENDIF
- ENDDO
- ENDIF
-
-C WRITE USER VALUES
-C -----------------
-
- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- INVN = INVTAG(NODS(I),LUN,INS1,INS2)
- IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET)
- ENDIF
- ENDDO
- ENDIF
-
-C GO FOR NEXT FRAME
-C -----------------
-
- GOTO 1
-
-C EXIT
-C ----
-
-100 RETURN
- END
diff --git a/src/ufbrw.f b/src/ufbrw.f
deleted file mode 100644
index 8bff75223..000000000
--- a/src/ufbrw.f
+++ /dev/null
@@ -1,156 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1994-01-06
-
-C> Write or read specified values to or from
-C> the current BUFR data subset within internal arrays, with the
-C> direction of the data transfer determined by the context of IO.
-C> The data values correspond to internal arrays representing parsed
-C> strings of mnemonics which are part of a delayed-replication
-C> sequence, or for which there is no replication at all.
-C>
-C> This subroutine should never be directly called by an application
-C> program; instead, an application program should directly call ufbint()
-C> which will internally call this subroutine.
-C>
-C> @param[in] LUN - integer: file ID.
-C> @param[inout] USR - real*8(*,*): Data values
-C> @param[in] I1 - integer: length of first dimension of USR.
-C> @param[in] I2 - integer: length of second dimension of USR.
-C> @param[in] IO - integer: status indicator for BUFR file associated
-C> with LUN:
-C> - 0 input file
-C> - 1 output file
-C> @param[out] IRET - integer: number of "levels" of data values read
-C> from or written to data subset
-C> - -1 none of the mnemonics in the string passed to ufbint() were found
-C> in the data subset template
-C>
-C> @author J. Woollen @date 1994-01-06
- SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET)
-
- use modv_vars, only: bmiss
-
- use moda_usrint
- use moda_tables
- use moda_msgcwd
-
- COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
- COMMON /QUIET / IPRT
-
- CHARACTER*128 ERRSTR
- CHARACTER*10 TAGSTR
- CHARACTER*10 SUBSET
- REAL*8 USR(I1,I2)
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
- SUBSET=TAG(INODE(LUN))
- IRET = 0
-
-C LOOP OVER COND WINDOWS
-C ----------------------
-
- INC1 = 1
- INC2 = 1
-
-1 CALL CONWIN(LUN,INC1,INC2)
- IF(NNOD.EQ.0) THEN
- IRET = I2
- GOTO 100
- ELSEIF(INC1.EQ.0) THEN
- GOTO 100
- ELSE
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- INS2 = INC1
- CALL GETWIN(NODS(I),LUN,INS1,INS2)
- IF(INS1.EQ.0) GOTO 100
- GOTO 2
- ENDIF
- ENDDO
- IRET = -1
- GOTO 100
- ENDIF
-
-C LOOP OVER STORE NODES
-C ---------------------
-
-2 IRET = IRET+1
-
- IF(IPRT.GE.2) THEN
- CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
- CALL ERRWRT('UFBRW LEV TAG IO INS1 INVN INS2 '//SUBSET)
- CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
- DO I=1,NNOD
- 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)
- WRITE(ERRSTR,'("LEV=",I5,1X,A,3I7)') IRET,TAGSTR,INS1,INVN,INS2
- CALL ERRWRT(ERRSTR)
- enddo
- endif
-
-C WRITE USER VALUES
-C -----------------
-
- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- IF(IBFMS(USR(I,IRET)).EQ.0) THEN
- INVN = INVWIN(NODS(I),LUN,INS1,INS2)
- IF(INVN.EQ.0) THEN
- CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
- IF(INVN.EQ.0) THEN
- IRET = 0
- GOTO 100
- ENDIF
- CALL NEWWIN(LUN,INC1,INC2)
- VAL(INVN,LUN) = USR(I,IRET)
- ELSEIF(LSTJPB(NODS(I),LUN,'RPS').EQ.0) THEN
- VAL(INVN,LUN) = USR(I,IRET)
- ELSEIF(IBFMS(VAL(INVN,LUN)).NE.0) THEN
- VAL(INVN,LUN) = USR(I,IRET)
- ELSE
- CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN)
- IF(INVN.EQ.0) THEN
- IRET = 0
- GOTO 100
- ENDIF
- CALL NEWWIN(LUN,INC1,INC2)
- VAL(INVN,LUN) = USR(I,IRET)
- ENDIF
- ENDIF
- ENDIF
- ENDDO
- ENDIF
-
-C READ USER VALUES
-C ----------------
-
- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
- DO I=1,NNOD
- USR(I,IRET) = BMISS
- IF(NODS(I).GT.0) THEN
- INVN = INVWIN(NODS(I),LUN,INS1,INS2)
- IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
- ENDIF
- ENDDO
- ENDIF
-
-C DECIDE WHAT TO DO NEXT
-C ----------------------
-
- IF(IO.EQ.1.AND.IRET.EQ.I2) GOTO 100
- CALL NXTWIN(LUN,INS1,INS2)
- IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2
- IF(NCON.GT.0) GOTO 1
-
-C EXIT
-C ----
-
-100 RETURN
- END
diff --git a/src/ufbseq.f b/src/ufbseq.f
deleted file mode 100644
index 3104f4cd4..000000000
--- a/src/ufbseq.f
+++ /dev/null
@@ -1,404 +0,0 @@
-C> @file
-C> @brief Read/write an entire sequence of data values from/to
-C> a data subset.
-C>
-C> @authors J. Woollen @authors J. Ator @date 2000-09-19
-
-C> Reads or write an entire sequence of data values
-C> from or to the BUFR data subset that is currently open within the
-C> NCEPLIBS_bufr internal arrays. The direction of the data transfer is
-C> determined by the context of ABS(LUNIN):
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> input using subroutine openbf(), then data values are read from
-C> the current data subset.
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> output using subroutine openbf(), then data values are written to
-C> the current data subset.
-C>
-C> This subroutine is specifically designed for use with a single
-C> Table A or Table D mnemonic. In the latter case, the mnemonic
-C> may be replicated within the overall subset definition, and in
-C> which case the subroutine will return all data values within all
-C> replications of the sequence defined by the mnemonic. But in
-C> either case, the mnemonic itself may contain, within its own
-C> sequence definition, any number of data values defined by Table B
-C> mnemonics and/or subsequences of data values defined by other
-C> Table D mnemonics, and any such subsequences may themselves be
-C> replicated using any manner of fixed or delayed replication.
-C> See [DX BUFR Tables](@ref ufbsubs) for more details including
-C> an example use case, and see also subroutines ufbint(), ufbrep()
-C> and ufbstp() which are also used to read/write one or more data
-C> values from/to a data subset but cannot themselves be directly
-C> used with Table A or Table D mnemonics.
-C>
-C> It is the user's responsibility to ensure that USR is dimensioned
-C> sufficiently large enough to accommodate the number of data values
-C> that are to be read from or written to the data subset. Note also
-C> that USR is an array of real*8 values; therefore, any data that are
-C> to be written out as character (i.e. CCITT IA5) values in
-C> BUFR must be converted from character into real*8 format within the
-C> application program before calling this subroutine. Conversely,
-C> when this subroutine is being used to read character values from a
-C> data subset, the value that is returned will be in real*8 format
-C> and must be converted back into character format by the application
-C> program before it can be used as such. Alternatively, there are
-C> different subroutines such as readlc() and writlc() which can be
-C> used to read/write character data directly from/to a data subset
-C> without the need to convert from/to real*8 format as an intermediate
-C> step.
-C>
-C> Numeric (i.e. non-character) data values within USR are always in
-C> the exact units specified for the corresponding mnemonic within the
-C> relevant DX or master BUFR table, without any scale or reference
-C> values applied. Specifically, this means that, when writing
-C> data values into an output subset, the user only needs to store each
-C> respective value into USR using the units specified within the table,
-C> and the NCEPLIBS-bufr software will take care of any necessary scaling or
-C> referencing of the value before it is actually encoded into BUFR.
-C> Conversely, when reading data values from an input subset, the
-C> values returned in USR are already de-scaled and de-referenced and,
-C> thus, are already in the exact units that were defined for the
-C> corresponding mnemonics within the table.
-C>
-C> "Missing" values in USR are always denoted by a unique
-C> placeholder value. This placeholder value is initially set
-C> to a default value of 10E10_8, but it can be reset to
-C> any substitute value of the user's choice via a separate
-C> call to subroutine setbmiss(). In any case, and whenever this
-C> subroutine is used to read data values from an input subset, any
-C> returned value in USR can be easily checked for equivalence to the
-C> current placeholder value via a call to function ibfms(), and a
-C> positive result means that the value for the corresponding mnemonic
-C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
-C> original data subset. Conversely, whenever this subroutine
-C> is used to write data values to an output subset, the current
-C> placeholder value can be obtained via a separate call to function
-C> getbmiss(), and the resulting value can then be stored into the
-C> USR array whereever the user desires a BUFR "missing" value (i.e.
-C> all bits set to 1) to be encoded for the corresponding mnemonic
-C> within the output subset.
-C>
-C> @remarks
-C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
-C> for output (writing BUFR), then the subroutine will treat the file
-C> pointed to by ABS(LUNIN) as though it was open for input (reading
-C> BUFR). This is a special capability for use by some applications
-C> that need to read certain values back out from a BUFR file during
-C> the same time that it is in the process of being written to.
-C> - If ABS(LUNIN) points to a file that is open for output
-C> (writing BUFR), and if the data values to be written are part of
-C> a sequence replicated using delayed replication, then a call to
-C> subroutine drfini() must be made prior to calling this subroutine,
-C> in order to pre-allocate the necessary internal array space for
-C> the number of replications of the sequence.
-C>
-C> @param[in] LUNIN -- integer: Absolute value is Fortran logical
-C> unit number for BUFR file
-C> @param[in,out] USR -- real*8(*,*): Data values
-C> - If ABS(LUNIN) was opened for input, then
-C> USR is output from this subroutine and
-C> contains data values that were read
-C> from the current data subset.
-C> - If ABS(LUNIN) was opened for output, then
-C> USR is input to this subroutine and
-C> contains data values that are to be
-C> written to the current data subset.
-C> @param[in] I1 -- integer: First dimension of USR as allocated
-C> within the calling program
-C> @param[in] I2 -- integer:
-C> - If ABS(LUNIN) was opened for input, then I2
-C> must be set equal to the second dimension
-C> of USR as allocated within the calling program
-C> - If ABS(LUNIN) was opened for output, then I2
-C> must be set equal to the number of replications
-C> of STR that are to be written to the data subset
-C> @param[out] IRET -- integer: Number of replications of STR that were
-C> read/written from/to the data subset
-C> @param[in] STR -- character*(*): String consisting of a single Table A
-C> or Table D mnemonic whose sequence definition is
-C> in one-to-one correspondence with the number of data
-C> values that will be read/written from/to the data
-C> subset within the first dimension of USR
-C> (see [DX BUFR Tables](@ref dfbftab) for further
-C> information about Table A and Table D mnemonics)
-C>
-C> @authors J. Woollen @authors J. Ator @date 2000-09-19
-
- RECURSIVE SUBROUTINE UFBSEQ(LUNIN,USR,I1,I2,IRET,STR)
-
- use modv_vars, only: im8b, bmiss
-
- use moda_usrint
- use moda_msgcwd
- use moda_tables
-
- PARAMETER (MTAG=10)
-
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) STR
- CHARACTER*156 BORT_STR
- CHARACTER*128 ERRSTR
- CHARACTER*10 TAGS(MTAG)
- REAL*8 USR(I1,I2)
-
- DATA IFIRST1/0/,IFIRST2/0/
-
- SAVE IFIRST1, IFIRST2
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIN,MY_LUNIN,1)
- CALL X84(I1,MY_I1,1)
- CALL X84(I2,MY_I2,1)
- CALL UFBSEQ(MY_LUNIN,USR,MY_I1,MY_I2,IRET,STR)
- CALL X48(IRET,IRET,1)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IRET = 0
-
-C CHECK THE FILE STATUS AND I-NODE
-C --------------------------------
-
- LUNIT = ABS(LUNIN)
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IM.EQ.0) GOTO 901
-
- IO = MIN(MAX(0,IL),1)
- IF(LUNIT.NE.LUNIN) IO = 0
-
- IF(I1.LE.0) THEN
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSEQ - 3rd ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 100
- ELSEIF(I2.LE.0) THEN
- IF(IPRT.EQ.-1) IFIRST1 = 1
- IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSEQ - 4th ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST1 = 1
- ENDIF
- GOTO 100
- ENDIF
-
-C CHECK FOR VALID SEQUENCE AND SEQUENCE LENGTH ARGUMENTS
-C ------------------------------------------------------
-
- CALL PARSTR(STR,TAGS,MTAG,NTAG,' ',.TRUE.)
- IF(NTAG.LT.1) GOTO 902
- IF(NTAG.GT.1) GOTO 903
- IF(INODE(LUN).NE.INV(1,LUN)) GOTO 906
-
-
-C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
-C --------------------------------------------------
-
- IF(IO.EQ.0) THEN
- DO J=1,I2
- DO I=1,I1
- USR(I,J) = BMISS
- ENDDO
- ENDDO
- ENDIF
-
-
-C FIND THE PARAMETERS OF THE SPECIFIED SEQUENCE
-C ---------------------------------------------
-
- DO NODE=INODE(LUN),ISC(INODE(LUN))
- IF(STR.EQ.TAG(NODE)) THEN
- IF(TYP(NODE).EQ.'SEQ'.OR.TYP(NODE).EQ.'RPC') THEN
- INS1 = 1
-5 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN))
- IF(INS1.EQ.0) GOTO 200
- IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN
- INS1 = INS1+1
- GOTO 5
- ENDIF
- INS2 = INVTAG(NODE,LUN,INS1+1,NVAL(LUN))
- IF(INS2.EQ.0) INS2 = 10E5
- NODS = NODE
- DO WHILE(LINK(NODS).EQ.0.AND.JMPB(NODS).GT.0)
- NODS = JMPB(NODS)
- ENDDO
- IF(LINK(NODS).EQ.0) THEN
- INSX = NVAL(LUN)
- ELSEIF(LINK(NODS).GT.0) THEN
- INSX = INVWIN(LINK(NODS),LUN,INS1+1,NVAL(LUN))-1
- ENDIF
- INS2 = MIN(INS2,INSX)
- ELSEIF(TYP(NODE).EQ.'SUB') THEN
- INS1 = 1
- INS2 = NVAL(LUN)
- ELSE
- GOTO 907
- ENDIF
- NSEQ = 0
- DO ISQ=INS1,INS2
- ITYP = ITP(INV(ISQ,LUN))
- IF(ITYP.GT.1) NSEQ = NSEQ+1
- ENDDO
- IF(NSEQ.GT.I1) GOTO 908
- GOTO 1
- ENDIF
- ENDDO
-
- GOTO 200
-
-C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
-C ----------------------------------------------------
-
-1 INS1 = INVTAG(NODE,LUN,INS1,NVAL(LUN))
- IF(INS1.GT.NVAL(LUN)) GOTO 200
- IF(INS1.GT.0) THEN
- IF(TYP(NODE).EQ.'RPC'.AND.VAL(INS1,LUN).EQ.0.) THEN
- INS1 = INS1+1
- GOTO 1
- ELSEIF(IO.EQ.0.AND.IRET+1.GT.I2) THEN
- IF(IPRT.GE.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'
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT('++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 200
- ENDIF
- ELSEIF(INS1.EQ.0) THEN
- IF(IO.EQ.1.AND.IRET.LT.I2) GOTO 910
- ELSE
- GOTO 911
- ENDIF
-
- IF(INS1.EQ. 0) GOTO 200
- IF(IRET.EQ.I2) GOTO 200
-
- IRET = IRET+1
- INS1 = INS1+1
-
-C READ/WRITE USER VALUES
-C ----------------------
-
- J = INS1
- DO I=1,NSEQ
- DO WHILE(ITP(INV(J,LUN)).LT.2)
- J = J+1
- ENDDO
- IF(IO.EQ.0) USR(I,IRET) = VAL(J,LUN )
- IF(IO.EQ.1) VAL(J,LUN ) = USR(I,IRET)
- J = J+1
- ENDDO
-
-C CHECK FOR NEXT FRAME
-C --------------------
-
- GOTO 1
-
-200 CONTINUE
-
- IF(IRET.EQ.0) THEN
- IF(IO.EQ.0) THEN
- IF(IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES READ IN, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- ELSE
- IF(IPRT.EQ.-1) IFIRST2 = 1
- IF(IFIRST2.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSEQ - NO SPECIFIED VALUES WRITTEN OUT, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('MAY NOT BE IN THE BUFR TABLE(?)')
- IF(IPRT.EQ.0) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST2 = 1
- ENDIF
- ENDIF
- ENDIF
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: UFBSEQ - BUFR FILE IS CLOSED, IT MUST BE'//
- . ' OPEN')
-901 CALL BORT('BUFRLIB: UFBSEQ - A MESSAGE MUST BE OPEN IN BUFR '//
- . 'FILE, NONE ARE')
-902 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THE INPUT STRING (",A,") '//
- . 'DOES NOT CONTAIN ANY MNEMONICS!!")') STR
- CALL BORT(BORT_STR)
-903 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - THERE CANNOT BE MORE THAN '//
- . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",I3'//
- . ',")")') STR,NTAG
- CALL BORT(BORT_STR)
-906 CALL BORT('BUFRLIB: UFBSEQ - LOCATION OF INTERNAL TABLE FOR '//
- . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
- . 'SUBSET ARRAY')
-907 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT MNEMONIC ",A," MUST '//
- . 'BE A SEQUENCE (HERE IT IS TYPE """,A,""")")') TAGS(1),TYP(NODE)
- CALL BORT(BORT_STR)
-908 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - INPUT SEQ. MNEM. ",A,'//
- . '" CONSISTS OF",I4," TABLE B MNEM., .GT. THE MAX. SPECIFIED IN'//
- . ' (INPUT) ARGUMENT 3 (",I3,")")') TAGS(1),NSEQ,I1
- CALL BORT(BORT_STR)
-910 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - NO. OF ''LEVELS'' WRITTEN '//
- . '(",I5,") .LT. NO. REQUESTED (",I5,") - INCOMPLETE WRITE '//
- . '(INPUT MNEMONIC IS ",A,")")') IRET,I2,TAGS(1)
- CALL BORT(BORT_STR)
-911 WRITE(BORT_STR,'("BUFRLIB: UFBSEQ - VARIABLE INS1 MUST BE .GE. '//
- . 'ZERO, HERE IT IS",I4," - INPUT MNEMONIC IS ",A)') INS1,TAGS(1)
- CALL BORT(BORT_STR)
- END
diff --git a/src/ufbsp.f b/src/ufbsp.f
deleted file mode 100644
index 66a251ede..000000000
--- a/src/ufbsp.f
+++ /dev/null
@@ -1,99 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1999-11-18
-
-C> Write or read specified values to or
-C> from the current BUFR data subset within internal arrays, with the
-C> direction of the data transfer determined by the context of IO.
-C> The data values correspond to internal arrays representing parsed
-C> strings of mnemonics which are either part of a fixed (i.e. non-delayed)
-C> replication sequence, or for mnememonics which are replicated by being
-C> directly listed more than once within an overall subset definition.
-C>
-C> This subroutine should never be directly called by an application
-C> program; instead, an application program should directly call ufbstp()
-C> which will internally call this subroutine.
-C>
-C> This subroutine is similar to subroutine ufbrp(), but it is designed
-C> for different use cases. For a more detailed explanation of how
-C> subroutine ufbstp() differs from subroutine ufbrep(), and therefore
-C> how this subroutine differs from subroutine ufbrp(), see the
-C> discussion in [DX BUFR Tables](@ref ufbsubs).
-C>
-C> @param[in] LUN - integer: file ID.
-C> @param[inout] USR - real*8(*,*): Data values
-C> @param[in] I1 - integer: length of first dimension of USR.
-C> @param[in] I2 - integer: length of second dimension of USR.
-C> @param[in] IO - integer: status indicator for BUFR file associated
-C> with LUN:
-C> - 0 input file
-C> - 1 output file
-C> @param[out] IRET - integer: number of "levels" of data values read
-C> from or written to data subset
-C>
-C> @author J. Woollen @date 1999-11-18
- SUBROUTINE UFBSP(LUN,USR,I1,I2,IO,IRET)
-
- use moda_usrint
-
- COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
-
- REAL*8 USR(I1,I2)
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
- IRET = 0
- INS1 = 0
- INS2 = 0
-
-C FRAME A SECTION OF THE BUFFER - RETURN WHEN NO FRAME
-C ----------------------------------------------------
-
-1 IF(INS1+1.GT.NVAL(LUN)) GOTO 100
- INS1 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN))
- IF(INS1.EQ.0) GOTO 100
-
- INS2 = INVTAG(NODS(1),LUN,INS1+1,NVAL(LUN))
- IF(INS2.EQ.0) INS2 = NVAL(LUN)
- IRET = IRET+1
-
-C READ USER VALUES
-C ----------------
-
- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN
- INVM = INS1
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- INVN = INVTAG(NODS(I),LUN,INVM,INS2)
- IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN)
- INVM = MAX(INVN,INVM)
- ENDIF
- ENDDO
- ENDIF
-
-C WRITE USER VALUES
-C -----------------
-
- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN
- INVM = INS1
- DO I=1,NNOD
- IF(NODS(I).GT.0) THEN
- INVN = INVTAG(NODS(I),LUN,INVM,INS2)
- IF(INVN.GT.0) VAL(INVN,LUN) = USR(I,IRET)
- INVM = MAX(INVN,INVM)
- ENDIF
- ENDDO
- ENDIF
-
-C GO FOR NEXT FRAME
-C -----------------
-
- GOTO 1
-
-C EXIT
-C ----
-
-100 RETURN
- END
diff --git a/src/ufbstp.f b/src/ufbstp.f
deleted file mode 100644
index b69663425..000000000
--- a/src/ufbstp.f
+++ /dev/null
@@ -1,255 +0,0 @@
-C> @file
-C> @brief Read/write one or more data values from/to a data subset.
-C>
-C> @author J. Woollen @date 1994-01-06
-
-C> Read or write one or more data values from or to
-C> the BUFR data subset that is currently open within the NCEPLIBS-bufr
-C> internal arrays. The direction of the data transfer is determined
-C> by the context of ABS(LUNIN):
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> input using subroutine openbf(), then data values are read from
-C> the current data subset.
-C> - If ABS(LUNIN) points to a file that was previously opened for
-C> output using subroutine openbf(), then data values are written to
-C> the current data subset.
-C>
-C> This subroutine is specifically designed for use with Table B
-C> mnemonics which are part of a fixed (i.e. non-delayed) replication
-C> sequence, or for mnemonics which are replicated by being directly
-C> listed more than once within an overall subset definition.
-C> It is very similar to subroutine ufbrep(), but it differs in how it
-C> processes the input mnemonic string STR. For more details, see
-C> the discussion and example use case in [DX BUFR Tables](@ref ufbsubs).
-C> See also subroutines ufbint() and ufbseq(), which can also be used
-C> to read/write one or more data values from/to a data subset but are
-C> also designed for different use cases as noted in
-C> [DX BUFR Tables](@ref ufbsubs).
-C>
-C> It is the user's responsibility to ensure that USR is dimensioned
-C> sufficiently large enough to accommodate the number of data values
-C> that are to be read from or written to the data subset. Note also
-C> that USR is an array of real*8 values; therefore, any data that are
-C> to be written out as character (i.e. CCITT IA5) values in
-C> BUFR must be converted from character into real*8 format within the
-C> application program before calling this subroutine. Conversely,
-C> when this subroutine is being used to read character values from a
-C> data subset, the value that is returned will be in real*8 format
-C> and must be converted back into character format by the application
-C> program before it can be used as such. Alternatively, there are
-C> different subroutines such as readlc() and writlc() which can be
-C> used to read/write character data directly from/to a data subset
-C> without the need to convert from/to real*8 format as an intermediate
-C> step.
-C>
-C> Numeric (i.e. non-character) data values within USR are always in
-C> the exact units specified for the corresponding mnemonic within the
-C> relevant DX or master BUFR table, without any scale or reference
-C> values applied. Specifically, this means that, when writing
-C> data values into an output subset, the user only needs to store each
-C> respective value into USR using the units specified within the table,
-C> and the NCEPLIBS-bufr software will take care of any necessary scaling or
-C> referencing of the value before it is actually encoded into BUFR.
-C> Conversely, when reading data values from an input subset, the
-C> values returned in USR are already de-scaled and de-referenced and,
-C> thus, are already in the exact units that were defined for the
-C> corresponding mnemonics within the table.
-C>
-C> "Missing" values in USR are always denoted by a unique
-C> placeholder value. This placeholder value is initially set
-C> to a default value of 10E10_8, but it can be reset to
-C> any substitute value of the user's choice via a separate
-C> call to subroutine setbmiss(). In any case, and whenever this
-C> subroutine is used to read data values from an input subset, any
-C> returned value in USR can be easily checked for equivalence to the
-C> current placeholder value via a call to function ibfms(), and a
-C> positive result means that the value for the corresponding mnemonic
-C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
-C> original data subset. Conversely, whenever this subroutine
-C> is used to write data values to an output subset, the current
-C> placeholder value can be obtained via a separate call to function
-C> getbmiss(), and the resulting value can then be stored into the
-C> USR array whereever the user desires a BUFR "missing" value (i.e.
-C> all bits set to 1) to be encoded for the corresponding mnemonic
-C> within the output subset.
-C>
-C> @remarks
-C> - If LUNIN < 0, and if ABS(LUNIN) points to a file that is open
-C> for output (writing BUFR), then the subroutine will treat the file
-C> pointed to by ABS(LUNIN) as though it was open for input (reading
-C> BUFR). This is a special capability for use by some applications
-C> that need to read certain values back out from a BUFR file during
-C> the same time that it is in the process of being written to.
-C>
-C> @param[in] LUNIN -- integer: Absolute value is Fortran logical
-C> unit number for BUFR file
-C> @param[in,out] USR -- real*8(*,*): Data values
-C> - If ABS(LUNIN) was opened for input, then
-C> USR is output from this subroutine and
-C> contains data values that were read
-C> from the current data subset.
-C> - If ABS(LUNIN) was opened for output, then
-C> USR is input to this subroutine and
-C> contains data values that are to be
-C> written to the current data subset.
-C> @param[in] I1 -- integer: First dimension of USR as allocated
-C> within the calling program
-C> @param[in] I2 -- integer:
-C> - If ABS(LUNIN) was opened for input, then I2
-C> must be set equal to the second dimension
-C> of USR as allocated within the calling program
-C> - If ABS(LUNIN) was opened for output, then I2
-C> must be set equal to the number of replications
-C> of STR that are to be written to the data subset
-C> @param[out] IRET -- integer: Number of replications of STR that were
-C> read/written from/to the data subset
-C> @param[in] STR -- character*(*): String of blank-separated
-C> Table B mnemonics
-C> in one-to-one correspondence with the number of data
-C> values that will be read/written from/to the data
-C> subset within the first dimension of USR (see
-C> [DX BUFR Tables](@ref dfbftab) for further
-C> information about Table B mnemonics)
-C>
-C> @author J. Woollen @date 1994-01-06
- RECURSIVE SUBROUTINE UFBSTP(LUNIN,USR,I1,I2,IRET,STR)
-
- use modv_vars, only: im8b, bmiss
-
- use moda_usrint
- use moda_msgcwd
-
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) STR
- CHARACTER*128 BORT_STR1,BORT_STR2,ERRSTR
- REAL*8 USR(I1,I2)
-
- DATA IFIRST1/0/
-
- SAVE IFIRST1
-
-C----------------------------------------------------------------------
-C----------------------------------------------------------------------
-
-C CHECK FOR I8 INTEGERS
-C ---------------------
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIN,MY_LUNIN,1)
- CALL X84(I1,MY_I1,1)
- CALL X84(I2,MY_I2,1)
- CALL UFBSTP(MY_LUNIN,USR,MY_I1,MY_I2,IRET,STR)
- CALL X48(IRET,IRET,1)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
- IRET = 0
-
-C CHECK THE FILE STATUS AND I-NODE
-C --------------------------------
-
- LUNIT = ABS(LUNIN)
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IM.EQ.0) GOTO 901
- IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902
-
- IO = MIN(MAX(0,IL),1)
- IF(LUNIN.NE.LUNIT) IO = 0
-
- IF(I1.LE.0) THEN
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSTP - 3rd ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 100
- ELSEIF(I2.LE.0) THEN
- IF(IPRT.EQ.-1) IFIRST1 = 1
- IF(IO.EQ.0 .OR. IFIRST1.EQ.0 .OR. IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSTP - 4th ARG. (INPUT) IS .LE. 0, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- IF(IPRT.EQ.0 .AND. IO.EQ.1) THEN
- ERRSTR = 'Note: Only the first occurrence of this WARNING ' //
- . 'message is printed, there may be more. To output all ' //
- . 'such messages,'
- CALL ERRWRT(ERRSTR)
- ERRSTR = 'modify your application program to add ' //
- . '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
- . 'to a BUFRLIB routine.'
- CALL ERRWRT(ERRSTR)
- ENDIF
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- IFIRST1 = 1
- ENDIF
- GOTO 100
- ENDIF
-
-C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
-C --------------------------------------------------
-
- IF(IO.EQ.0) THEN
- DO J=1,I2
- DO I=1,I1
- USR(I,J) = BMISS
- ENDDO
- ENDDO
- ENDIF
-
-C PARSE OR RECALL THE INPUT STRING - READ/WRITE VALUES
-C ----------------------------------------------------
-
- CALL STRING(STR,LUN,I1,IO)
-
-C CALL THE MNEMONIC READER/WRITER
-C -------------------------------
-
- CALL UFBSP(LUN,USR,I1,I2,IO,IRET)
-
- IF(IO.EQ.1 .AND. IRET.NE.I2) GOTO 903
-
- IF(IRET.EQ.0) THEN
- IF(IO.EQ.0) THEN
- IF(IPRT.GE.1) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: UFBSTP - NO SPECIFIED VALUES READ IN, ' //
- . 'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT(STR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- ENDIF
- ENDIF
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: UFBSTP - BUFR FILE IS CLOSED, IT MUST BE'//
- . ' OPEN')
-901 CALL BORT('BUFRLIB: UFBSTP - A MESSAGE MUST BE OPEN IN BUFR '//
- . 'FILE, NONE ARE')
-902 CALL BORT('BUFRLIB: UFBSTP - LOCATION OF INTERNAL TABLE FOR '//
- . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
- . 'SUBSET ARRAY')
-903 WRITE(BORT_STR1,'("BUFRLIB: UFBSTP - MNEMONIC STRING READ IN IS'//
- . ': ",A)') STR
- WRITE(BORT_STR2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
- . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
- . ' - INCOMPLETE WRITE")') IRET,I2
- CALL BORT2(BORT_STR1,BORT_STR2)
- END
diff --git a/src/writlc.f b/src/writlc.f
deleted file mode 100644
index 0d4bc060e..000000000
--- a/src/writlc.f
+++ /dev/null
@@ -1,226 +0,0 @@
-C> @file
-C> @brief Write a long character string (greater than 8 bytes) to a data subset.
-C>
-C> @author J. Woollen @author J. Ator @date 2003-11-04
-
-C> Write a long character string (greater than 8 bytes) to a data subset.
-C>
-C> The data subset should have already been written into a BUFR message before
-C> calling this subroutine to write a long character string into the subset.
-C>
-C> If there is more than one occurrence of STR within the data subset
-C> definition, then each occurrence can be written via a separate call
-C> to this subroutine, and by appending the ordinal number of the
-C> occurrence to STR in each case. For example, if there are 5
-C> occurrences of mnemonic LSTID within a given data subset definition,
-C> then 5 separate calls should be made to this subroutine, once each
-C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
-C> 'LSTID#5'. However, the first notation is superfluous, because
-C> omitting the ordinal number always defaults to the first occurrence
-C> of a particular string, so a user could just specify 'LSTID'
-C> instead of 'LSTID#1'.
-C>
-C> Character strings which are 8 bytes or less in length can be
-C> written by converting the string into a real*8 value within the
-C> application program, and then using the real*8 USR array within a
-C> call to one of the NCEPLIBS-bufr
-C> [values-writing subroutines](@ref hierarchy)
-C> prior to calling one of the
-C> [subset-writing subroutines](@ref hierarchy)
-C> for the data subset.
-C>
-C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
-C> @param[in] CHR - character*(*): Value corresponding to STR.
-C> @param[in] STR - character*(*): Table B mnemonic of long character
-C> string to be written, possibly supplemented with an ordinal occurrence notation.
-C>
-C> @author J. Woollen @author J. Ator @date 2003-11-04
-
- RECURSIVE SUBROUTINE WRITLC(LUNIT,CHR,STR)
-
- use modv_vars, only: im8b, mxlcc
-
- use moda_usrint
- use moda_msgcwd
- use moda_bitbuf
- use moda_tables
- use moda_comprs
-
- COMMON /QUIET / IPRT
-
- CHARACTER*(*) CHR,STR
- CHARACTER*128 BORT_STR
- CHARACTER*128 ERRSTR
- CHARACTER*10 CTAG
- CHARACTER*14 TGS(10)
-
- DATA MAXTG /10/
-
-C-----------------------------------------------------------------------
-C-----------------------------------------------------------------------
-
-C Check for I8 integers.
-
- IF(IM8B) THEN
- IM8B=.FALSE.
-
- CALL X84(LUNIT,MY_LUNIT,1)
- CALL WRITLC(MY_LUNIT,CHR,STR)
-
- IM8B=.TRUE.
- RETURN
- ENDIF
-
-C Check the file status.
-
- CALL STATUS(LUNIT,LUN,IL,IM)
- IF(IL.EQ.0) GOTO 900
- IF(IL.LT.0) GOTO 901
- IF(IM.EQ.0) GOTO 902
-
-C Check for tags (mnemonics) in input string (there can only be one)
-
- CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
- IF(NTG.GT.1) GOTO 903
-
-C Check if a specific occurrence of the input string was requested;
-C if not, then the default is to write the first occurrence.
-
- CALL PARUTG(LUN,1,TGS(1),NNOD,KON,ROID)
- IF(KON.EQ.6) THEN
- IOID=NINT(ROID)
- IF(IOID.LE.0) IOID = 1
- CTAG = ' '
- II = 1
- DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#'))
- CTAG(II:II)=TGS(1)(II:II)
- II = II + 1
- ENDDO
- ELSE
- IOID = 1
- CTAG = TGS(1)(1:10)
- ENDIF
-
- IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN
-
-C The message is compressed.
-
- N = 1
- ITAGCT = 0
- CALL USRTPL(LUN,N,N)
- DO WHILE (N+1.LE.NVAL(LUN))
- N = N+1
- NODE = INV(N,LUN)
- IF(ITP(NODE).EQ.1) THEN
- NBMP=INT(MATX(N,NCOL))
- CALL USRTPL(LUN,N,NBMP)
- ELSEIF(CTAG.EQ.TAG(NODE)) THEN
- ITAGCT = ITAGCT + 1
- IF(ITAGCT.EQ.IOID) THEN
- IF(ITP(NODE).NE.3) GOTO 904
- CATX(N,NCOL)=' '
-
-C The following statement enforces a limit of MXLCC
-C characters per long character string when writing
-C compressed messages. This limit keeps the array
-C CATX to a reasonable dimensioned size.
-
- NCHR=MIN(MXLCC,IBT(NODE)/8)
- CATX(N,NCOL)=CHR(1:NCHR)
- CALL USRTPL(LUN,1,1)
- GOTO 100
- ENDIF
- ENDIF
- ENDDO
- ELSE
-
-C The message is not compressed. Locate the beginning of the
-C data (Section 4) in the message.
-
- CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5)
- MBYTE = LEN0 + LEN1 + LEN2 + LEN3 + 4
- NSUBS = 1
-
-C Find the most recently written subset in the message.
-
- DO WHILE(NSUBS.LT.NSUB(LUN))
- IBIT = MBYTE*8
- CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
- MBYTE = MBYTE + NBYT
- NSUBS = NSUBS + 1
- ENDDO
-
- IF(NSUBS.NE.NSUB(LUN)) THEN
- IF(IPRT.GE.0) THEN
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- ERRSTR = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // CTAG
- . // ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
- GOTO 100
- ENDIF
-
-C Locate and write the long character string within this subset.
-
- ITAGCT = 0
- MBIT = MBYTE*8 + 16
- NBIT = 0
- N = 1
- CALL USRTPL(LUN,N,N)
- DO WHILE (N+1.LE.NVAL(LUN))
- N = N+1
- NODE = INV(N,LUN)
- MBIT = MBIT+NBIT
- NBIT = IBT(NODE)
- IF(ITP(NODE).EQ.1) THEN
- CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
- CALL USRTPL(LUN,N,IVAL)
- ELSEIF(CTAG.EQ.TAG(NODE)) THEN
- ITAGCT = ITAGCT + 1
- IF(ITAGCT.EQ.IOID) THEN
- IF(ITP(NODE).NE.3) GOTO 904
- NCHR = NBIT/8
- IBIT = MBIT
- DO J=1,NCHR
- CALL PKC(' ',1,MBAY(1,LUN),IBIT)
- ENDDO
- CALL PKC(CHR,NCHR,MBAY(1,LUN),MBIT)
- CALL USRTPL(LUN,1,1)
- GOTO 100
- ENDIF
- ENDIF
- ENDDO
- ENDIF
-
- IF(IPRT.GE.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'
- CALL ERRWRT(ERRSTR)
- ERRSTR = '(' // CTAG // ' MAY NOT BE IN THE BUFR TABLE(?))'
- CALL ERRWRT(ERRSTR)
- CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
- CALL ERRWRT(' ')
- ENDIF
-
-C EXITS
-C -----
-
-100 RETURN
-900 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '//
- . 'MUST BE OPEN FOR OUTPUT')
-901 CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '//
- . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
-902 CALL BORT('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '//
- . 'BUFR FILE, NONE ARE')
-903 WRITE(BORT_STR,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '//
- . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'//
- . ',")")') STR,NTG
- CALL BORT(BORT_STR)
-904 WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '//
- . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') CTAG,TYP(NODE)
- CALL BORT(BORT_STR)
- END