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