writlc.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> This subroutine writes a long character string (greater than 8 bytes)
C> to a data subset.
C>
C> <p>The data subset should have already been written into a BUFR
C> message via a previous call to one of the
C> [subset-writing subroutines](@ref hierarchy), before calling this
C> subroutine to write any long character strings into the same subset.
C>
C> @authors J. Woollen
C> @authors J. Ator
C> @date 2003-11-04
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> <p>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> <b>Program history log:</b>
C> - 2003-11-04  J. Woollen -- Original author
C> - 2004-08-09  J. Ator    -- Maximum message length increased from
C>                             20,000 to 50,000 bytes
C> - 2005-11-29  J. Ator    -- Use getlens()
C> - 2007-01-19  J. Ator    -- Replaced call to parseq with call to
C>                             parstr()
C> - 2009-03-23  J. Ator    -- Added '#' option for more than one
C>                             occurrence of STR
C> - 2009-08-11  J. Woollen -- Added COMMON COMPRS along with logic to
C>                             write long strings into compressed subsets
C> - 2012-12-07  J. Ator    -- Allow str mnemonic length of up to 14 chars
C>                             when used with '#' occurrence code
C> - 2014-10-22  J. Ator    -- No longer abort if no subset available for
C>                             writing; just print a warning message
C> - 2014-12-10  J. Ator    -- USE modules instead of COMMON blocks
C> - 2020-09-09  J. Ator    -- No longer abort if STR not available within
C>                             subset definition; instead, just print a
C>                             warning message
C>
      SUBROUTINE writlc(LUNIT,CHR,STR)

      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 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
               CALL usrtpl(lun,n,matx(n,ncol))
            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)
905   WRITE(bort_str,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '//
     . .NE.' SUBSET NO. (",I3,") IN MSG  THE STORED VALUE FOR THE NO.'//
     . ' OF SUBSETS (",I3,") IN MSG")') nsubs,nsub(lun)
      CALL bort(bort_str)
      END