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>
C> @authors J. Woollen J. Ator @date 2003-11-04
 
C> Read a long character string (greater than 8 bytes)
C> from a data subset.
C>
C> 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> 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.
C>
C> 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'.
C>      
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> @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 with an ordinal
C> occurrence notation.
C>
C> @authors J. Woollen J. Ator @date 2003-11-04
 
      RECURSIVE SUBROUTINE readlc(LUNIT,CHR,STR)
 
      USE moda_usrint
      USE moda_usrbit
      USE moda_unptyp
      USE moda_bitbuf
      USE moda_tables
      USE moda_rlccmn
      USE modv_im8b
 
      COMMON /quiet / iprt
 
      CHARACTER*(*) chr,str
      CHARACTER*128 bort_str,errstr
      CHARACTER*10  ctag
      CHARACTER*14  tgs(10)
 
      DATA maxtg /10/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL readlc(my_lunit,chr,str)
 
         im8b=.true.
         RETURN
      ENDIF
 
      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