readlc.f

Go to the documentation of this file.

C> @file
C> @brief Read a long character string (greater than 8 bytes) from
C> a data subset.

C> This subroutine reads a long character string (greater than 8 bytes)
C> from a data subset.
C>
C> <p>The data subset should have already been read into internal arrays
C> via a previous call to one of the
C> [subset-reading subroutines](@ref hierarchy).
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[out] CHR  -- character*(*): Value corresponding to STR
C> @param[in] STR   -- character*(*): Table B mnemonic of long character
C>                     string to be retrieved, 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 retrieved 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 read
C> using the real*8 USR array within a call to one of the BUFRLIB
C> [values-reading subroutines](@ref hierarchy) and then converting the
C> corresponding real*8 value to character format within the
C> application program.
C> - If STR is not found within the data subset definition, then CHR is
C> returned with all bits set to 1, which is the standard WMO BUFR value
C> for "missing" data.  Any CHR value returned by this subroutine can be
C> checked for equivalence to this "missing" value via a call to
C> function icbfms().
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2003-11-04 | J. Woollen | Original author |
C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
C> | 2007-01-19 | J. Ator | Replaced call to parseq with call to parstr() |
C> | 2009-03-23 | J. Ator | Added capability for compressed messages; added check for overflow of chr; added '#' option for more than one occurrence of STR |
C> | 2009-04-21 | J. Ator | Use errwrt() |
C> | 2012-12-07 | J. Ator | Allow str mnemonic length of up to 14 chars when used with '#' occurrence code |
C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
C> | 2020-09-09 | J. Ator | Set CHR to "missing" instead of all blanks if STR isn't found in subset |
C>
      SUBROUTINE readlc(LUNIT,CHR,STR)

      USE moda_usrint
      USE moda_usrbit
      USE moda_unptyp
      USE moda_bitbuf
      USE moda_tables
      USE moda_rlccmn

      COMMON /quiet / iprt

      CHARACTER*(*) chr,str
      CHARACTER*128 bort_str,errstr
      CHARACTER*10  ctag
      CHARACTER*14  tgs(10)

      DATA maxtg /10/

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      chr = ' '
      lchr=len(chr)

C  CHECK THE FILE STATUS
C  ---------------------

      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) goto 900
      IF(il.GT.0) goto 901
      IF(im.EQ.0) goto 902

C  CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
C  ------------------------------------------------------------------

      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 return the first occurrence.

      CALL parutg(lun,0,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

C  LOCATE AND DECODE THE LONG CHARACTER STRING
C  -------------------------------------------

      IF(msgunp(lun).EQ.0.OR.msgunp(lun).EQ.1) THEN

C        The message is uncompressed

         itagct = 0
         DO n=1,nval(lun)
           nod = inv(n,lun)
           IF(ctag.EQ.tag(nod)) THEN
             itagct = itagct + 1
             IF(itagct.EQ.ioid) THEN
               IF(itp(nod).NE.3) goto 904
               nchr = nbit(n)/8
               IF(nchr.GT.lchr) goto 905
               kbit = mbit(n)
               CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
               goto 100
             ENDIF
           ENDIF
         ENDDO
      ELSEIF(msgunp(lun).EQ.2) THEN

C        The message is compressed

         IF(nrst.GT.0) THEN
           itagct = 0
           DO ii=1,nrst
             IF(ctag.EQ.crtag(ii)) THEN
               itagct = itagct + 1
               IF(itagct.EQ.ioid) THEN
                 nchr = irnch(ii)
                 IF(nchr.GT.lchr) goto 905
                 kbit = irbit(ii)
                 CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
                 goto 100
               ENDIF
             ENDIF
           ENDDO
         ENDIF
      ELSE
         goto 906
      ENDIF

C     If we made it here, then we couldn't find the requested string.

      IF(iprt.GE.0) THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) //
     .   ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' //
     .   ' STRING FOR CHARACTER DATA ELEMENT'
      CALL errwrt(errstr)
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
      DO ii=1,lchr
        CALL ipkm(chr(ii:ii),1,255)
      ENDDO

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
     . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   WRITE(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
     . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
     . 'I3,")")') str,ntg
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
     . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
     . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
     . 'FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
      CALL bort(bort_str)
906   WRITE(bort_str,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'//
     . '" IS NOT RECOGNIZED")') msgunp
      CALL bort(bort_str)
      END