setvalnb.f

Go to the documentation of this file.

C> @file
C> @brief Write one data value to a data subset.
C>
C> @author J. Ator @date 2016-07-29
 
C> This subroutine can be used to 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> BUFRLIB [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 moda_usrint
        USE moda_msgcwd
        USE moda_tables
        USE modv_im8b
 
        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