ufbint.f

Go to the documentation of this file.

C> @file
C> @brief Read/write one or more data values from/to a data subset.

C> This subroutine reads or writes one or more data values from or to
C> the BUFR data subset that is currently open within the BUFRLIB
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> <p>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> @author J. Woollen
C> @date 1994-01-06
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: Actual 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 actual 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>                    actually 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> <p>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> <p>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 BUFRLIB 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> <p>"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> - If ABS(LUNIN) points to a file that is open for input (reading
C> BUFR), there are a few additional special mnemonics that can be
C> included within STR when calling this subroutine, and which in turn
C> will result in special information being returned within the
C> corresponding location in USR.  These special mnemonics are not
C> considered to be part of Table B or Table D and therefore do not
C> need to be definied within the DX or master table file associated
C> with ABS(LUNIN):
C>      - NUL - returns the "missing" value
C>      - IREC - returns the number of the BUFR message within the
C>               file pointed to by ABS(LUNIN) (counting from the
C>               beginning of the file) in which the current data
C>               subset resides
C>      - ISUB - returns the number of the current data subset within
C>               the BUFR message pointed to by IREC, counting from
C>               the beginning of the message
C>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
C> - 1996-11-25  J. Woollen -- Modified to add a return code when
C>                            mnemonics are not found when reading
C> - 1996-12-17  J. Woollen -- Modified to always initialize USR array
C>                           to "missing" when BUFR file is being read
C> - 1998-07-08  J. Woollen -- Replaced call to Cray library routine ABORT
C>                             with call to new internal routine bort()
C> - 1999-11-18  J. Woollen -- The number of BUFR files which can be
C>                             opened at one time increased from 10 to 32
C>                             (necessary in order to process multiple
C>                             BUFR files under the MPI)
C> - 2003-11-04  S. Bender  -- Added remarks and routine interdependencies
C> - 2003-11-04  D. Keyser  -- Unified/portable for WRF; added history
C>                             documentation; outputs more complete
C>                             diagnostic info when routine terminates
C>                             abnormally, unusual things happen or for
C>                             informational purposes
C> - 2004-08-18  J. Ator    -- Added SAVE for IFIRST1 and IFIRST2 flags
C> - 2009-04-21  J. Ator    -- Use errwrt()
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C>
      SUBROUTINE ufbint(LUNIN,USR,I1,I2,IRET,STR)

      USE modv_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----------------------------------------------------------------------

      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 = .LE.'BUFRLIB: UFBINT - 3rd ARG. (INPUT) IS  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 = .LE.'BUFRLIB: UFBINT - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
            IF(iprt.EQ.0 .AND. io.EQ.1) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
            ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ifirst1 = 1
         ENDIF
         goto 100
      ENDIF

C  PARSE OR RECALL THE INPUT STRING
C  --------------------------------

      CALL string(str,lun,i1,io)

C  INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION
C  --------------------------------------------------

      IF(io.EQ.0) THEN
         DO j=1,i2
         DO i=1,i1
         usr(i,j) = bmiss
         ENDDO
         ENDDO
      ENDIF

C  CALL THE MNEMONIC READER/WRITER
C  -------------------------------

      CALL ufbrw(lun,usr,i1,i2,io,iret)

C  IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN
C  ---------------------------------------------------------------------

      IF(io.EQ.1 .AND. iret.NE.i2 .AND. iret.GE.0) THEN
         CALL trybump(lunit,lun,usr,i1,i2,io,iret)
         IF(iret.NE.i2) goto 903
      ELSEIF(iret.EQ.-1) THEN
         iret = 0
      ENDIF

      IF(iret.EQ.0)  THEN
         IF(io.EQ.0) THEN
            IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES READ IN, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
            ENDIF
         ELSE
            IF(iprt.EQ.-1)  ifirst2 = 1
            IF(ifirst2.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBINT - NO SPECIFIED VALUES WRITTEN OUT, ' //
     .   'SO RETURN WITH 5th ARG. (IRET) = 0; 6th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('MAY NOT BE IN THE BUFR TABLE(?)')
               IF(iprt.EQ.0) THEN
      errstr = 'Note: Only the first occurrence of this WARNING ' //
     .   'message is printed, there may be more.  To output all ' //
     .   'such messages,'
      CALL errwrt(errstr)
      errstr = 'modify your application program to add ' //
     .   '"CALL OPENBF(0,''QUIET'',1)" prior to the first call ' //
     .   'to a BUFRLIB routine.'
      CALL errwrt(errstr)
               ENDIF
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
               ifirst2 = 1
            ENDIF
         ENDIF
      ENDIF

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: UFBINT - BUFR FILE IS CLOSED, IT MUST BE'//
     . ' OPEN')
901   CALL bort('BUFRLIB: UFBINT - A MESSAGE MUST BE OPEN IN BUFR '//
     . 'FILE, NONE ARE')
902   CALL bort('BUFRLIB: UFBINT - LOCATION OF INTERNAL TABLE FOR '//
     . 'BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL '//
     . 'SUBSET ARRAY')
903   WRITE(bort_str1,'("BUFRLIB: UFBINT - MNEMONIC STRING READ IN IS'//
     . ': ",A)') str
      WRITE(bort_str2,'(18X,"THE NUMBER OF ''LEVELS'' ACTUALLY '//
     . 'WRITTEN (",I3,") DOES NOT EQUAL THE NUMBER REQUESTED (",I3,")'//
     . ' - INCOMPLETE WRITE")')  iret,i2
      CALL bort2(bort_str1,bort_str2)
      END