ufbstp.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 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> @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>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
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 ufbstp(LUNIN,USR,I1,I2,IRET,STR)

      USE modv_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/,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(lunin.NE.lunit) io = 0

      IF(i1.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBSTP - 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: UFBSTP - 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  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
         ELSE
            IF(iprt.EQ.-1)  ifirst2 = 1
            IF(ifirst2.EQ.0 .OR. iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBSTP - 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: 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