hold4wlc.f

Go to the documentation of this file.

C> @file
C> @brief Write a long character string (greater than 8 bytes) to
C> a data subset
C>
C> @author J. Ator @date 2014-02-05
 
C> This subroutine writes a long character string (greater than 8 bytes)
C> to a data subset.
C>
C> Normally, subroutine writlc() is used to write a long character
C> string to a data subset.  However, subroutine writlc() can only be
C> called <b>after</b> a call to one of the
C> [subset-writing subroutines](@ref hierarchy), so it will not work
C> for cases when one of those subroutines flushes the message
C> containing the data subset in question to logical unit LUNIT during
C> the same call to that subroutine, such as when the data subset
C> contains more than 65530 bytes.  When this happens, there is no
C> longer any way for a subsequent writlc() call to write a long
C> character string into that data subset, because the data subset has
C> already been flushed from internal memory.  This subroutine solves
C> that problem, by allowing a long character string to be specified
C> <b>before</b> calling one of the
C> [subset-writing subroutines](@ref hierarchy), and the string value
C> will be held and stored automatically (via an internal call to
C> subroutine writlc()) at the proper time during the subsequent call
C> to the [subset-writing subroutines](@ref hierarchy).
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
C>                     with an ordinal occurrence notation
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> @remarks
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 BUFRLIB
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> @author J. Ator @date 2014-02-05
      RECURSIVE SUBROUTINE hold4wlc(LUNIT,CHR,STR)
 
      USE moda_h4wlc
      USE modv_im8b
 
      COMMON /quiet/ iprt
 
      CHARACTER*(*) chr,str
 
      CHARACTER*128 errstr
      CHARACTER*14  mystr
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C     CHECK FOR I8 INTEGERS
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL hold4wlc(my_lunit,chr,str)
 
         im8b=.true.
         RETURN
      ENDIF
 
      CALL strsuc( str, mystr, lens )
      IF ( lens .EQ. -1 ) RETURN
 
      lenc = min( len( chr ), 120 )
 
C     IF THIS SUBROUTINE HAS ALREADY BEEN CALLED WITH THIS MNEMONIC FOR
C     THIS PARTICULAR SUBSET, THEN OVERWRITE THE CORRESPONDING ENTRY IN
C     THE INTERNAL HOLDING AREA.
 
      IF ( nh4wlc .GT. 0 ) THEN
        DO i = 1, nh4wlc
          IF ( ( lunit .EQ. luh4wlc(i) ) .AND.
     .         ( mystr(1:lens) .EQ. sth4wlc(i)(1:lens) ) ) THEN
            chh4wlc(i) = ''
            chh4wlc(i)(1:lenc) = chr(1:lenc)
            RETURN
          ENDIF
        ENDDO
      ENDIF
 
C     OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN THE HOLDING AREA.
 
      IF ( nh4wlc .GE. mxh4wlc ) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,A,I3)' )
     . 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ',
     . 'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
         ENDIF
      ELSE
         nh4wlc = nh4wlc + 1
         luh4wlc(nh4wlc) = lunit
         sth4wlc(nh4wlc) = ''
         sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
         chh4wlc(nh4wlc) = ''
         chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
      ENDIF
 
      RETURN
      END