      SUBROUTINE WRITLC(LUNIT,CHR,STR)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    WRITLC
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2003-11-04
C
C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER DATA ELEMENT ASSOCIATED
C   WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER
C   (ARRAY MBAY IN COMMON BLOCK /BITBUF/).  IT IS DESIGNED TO BE USED
C   TO STORE CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT
C   BYTES.  NOTE THAT SUBROUTINE WRITSB OR WRITSA MUST HAVE ALREADY
C   BEEN CALLED TO STORE ALL OTHER ELEMENTS OF THE SUBSET BEFORE THIS
C   SUBROUTINE CAN BE CALLED TO FILL IN ANY LONG CHARACTER STRINGS.
C
C PROGRAM HISTORY LOG:
C 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C                           ABNORMALLY
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 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
C USAGE:    CALL WRITLC (LUNIT, CHR, STR)
C   INPUT ARGUMENT LIST:
C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C     CHR      - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E.,
C                CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES)
C     STR      - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR
C
C REMARKS:
C    THIS ROUTINE CALLS:        BORT     GETLENS  IUPBS3   PARSTR
C                               PARUTG   PKC      STATUS   UPB
C                               UPBB     USRTPL
C    THIS ROUTINE IS CALLED BY: None
C                               Normally called only by application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
     .                MBAY(MXMSGLD4,NFILES)
      COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
     .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
     .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
     .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
     .                ISEQ(MAXJL,2),JSEQ(MAXJL)
      COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
     .                INODE(NFILES),IDATE(NFILES)
      COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
      COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB)

      CHARACTER*(*) CHR,STR
      CHARACTER*128 BORT_STR
      CHARACTER*(MXLCC)  CATX        
      CHARACTER*10  TAG,CTAG
      CHARACTER*14  TGS(10)
      CHARACTER*3   TYP
      REAL*8        VAL

      DATA MAXTG /10/

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

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

      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)
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 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

C  USE THIS LEG FOR STRINGING COMPRESSED DATA (UP TO MXLCC CHARACTERS)
C  ----------------------------------------------------------------

      IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN       
         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                 --------------------------------------------------
C                 Note: the following stmt enforces a limit of MXLCC 
C                 characters per long character string when writing
C                 compressed messages.  This limit keeps the static
C                 array CATX to a reasonable dimensioned size. 
C                 --------------------------------------------------
                  NCHR=MIN(MXLCC,IBT(NODE)/8)
                  CATX(N,NCOL)=CHR(1:NCHR)
                  CALL USRTPL(LUN,1,1)
                  GOTO 100
               ENDIF
            ENDIF
         ENDDO
         GOTO 906
      ENDIF

C  OTHERWISE LOCATE THE BEGINNING OF THE DATA (SECTION 4) IN THE MESSAGE
C  ---------------------------------------------------------------------

      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
C  ----------------------------------------------------

      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)) GOTO 905

C  LOCATE AND WRITE THE LONG CHARACTER STRING WITHIN THIS SUBSET
C  -------------------------------------------------------------

      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
      GOTO 906

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,")")') TGS(1),TYP(NODE)
      CALL BORT(BORT_STR)
905   WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '//
     . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'//
     . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN)
      CALL BORT(BORT_STR)
906   WRITE(BORT_STR,'("BUFRLB: WRITLC - UNABLE TO FIND ",A," IN '//
     . 'SUBSET")') TGS(1)
      CALL BORT(BORT_STR)
      END
