writlc.f

Go to the documentation of this file.

C> @file
C> @brief Write a long character string (greater than 8 bytes) to a data subset.
C>
C> @author J. Woollen @author J. Ator @date 2003-11-04
 
C> Write a long character string (greater than 8 bytes) to a data subset.
C>
C> The data subset should have already been written into a BUFR message before
C> calling this subroutine to write a long character string into the subset.
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> 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> @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 with an ordinal occurrence notation.
C>
C> @author J. Woollen @author J. Ator @date 2003-11-04
 
      RECURSIVE SUBROUTINE writlc(LUNIT,CHR,STR)
 
      USE modv_im8b
      USE modv_mxlcc
 
      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 for I8 integers.
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL writlc(my_lunit,chr,str)
 
         im8b=.true.
         RETURN
      ENDIF
 
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
               nbmp=int(matx(n,ncol))
               CALL usrtpl(lun,n,nbmp)
            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)
      END