var/external/bufr/writlc.f

   1       SUBROUTINE WRITLC(LUNIT,CHR,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    WRITLC
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2003-11-04
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PACKS A CHARACTER DATA ELEMENT ASSOCIATED
   9 C   WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER
  10 C   (ARRAY MBAY IN COMMON BLOCK /BITBUF/).  IT IS DESIGNED TO BE USED
  11 C   TO STORE CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT
  12 C   BYTES.  NOTE THAT SUBROUTINE WRITSB OR WRITSA MUST HAVE ALREADY
  13 C   BEEN CALLED TO STORE ALL OTHER ELEMENTS OF THE SUBSET BEFORE THIS
  14 C   SUBROUTINE CAN BE CALLED TO FILL IN ANY LONG CHARACTER STRINGS.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR
  18 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  19 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  20 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  21 C                           ABNORMALLY
  22 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  23 C                           20,000 TO 50,000 BYTES
  24 C 2005-11-29  J. ATOR    -- USE GETLENS
  25 C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  26 C 2009-03-23  J. ATOR    -- ADDED '#' OPTION FOR MORE THAN ONE
  27 C                           OCCURRENCE OF STR
  28 c 2009-08-11  J. WOOLLEN -- ADDED COMMON COMPRS ALONG WITH LOGIC TO
  29 c                           WRITE LONG STRINGS INTO COMPRESSED SUBSETS
  30 C 2012-12-07  J. ATOR    -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS
  31 C                           WHEN USED WITH '#' OCCURRENCE CODE
  32 C
  33 C USAGE:    CALL WRITLC (LUNIT, CHR, STR)
  34 C   INPUT ARGUMENT LIST:
  35 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  36 C     CHR      - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E.,
  37 C                CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES)
  38 C     STR      - CHARACTER*(*): MNEMONIC ASSOCIATED WITH STRING IN CHR
  39 C
  40 C REMARKS:
  41 C    THIS ROUTINE CALLS:        BORT     GETLENS  IUPBS3   PARSTR
  42 C                               PARUTG   PKC      STATUS   UPB
  43 C                               UPBB     USRTPL
  44 C    THIS ROUTINE IS CALLED BY: None
  45 C                               Normally called only by application
  46 C                               programs.
  47 C
  48 C ATTRIBUTES:
  49 C   LANGUAGE: FORTRAN 77
  50 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  51 C
  52 C$$$
  53
  54       INCLUDE 'bufrlib.prm'
  55
  56       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  57      .                MBAY(MXMSGLD4,NFILES)
  58       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  59      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  60      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  61      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  62      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  63       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  64      .                INODE(NFILES),IDATE(NFILES)
  65       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  66       COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB)
  67
  68       CHARACTER*(*) CHR,STR
  69       CHARACTER*128 BORT_STR
  70       CHARACTER*(MXLCC)  CATX
  71       CHARACTER*10  TAG,CTAG
  72       CHARACTER*14  TGS(10)
  73       CHARACTER*3   TYP
  74       REAL*8        VAL
  75
  76       DATA MAXTG /10/
  77
  78 C-----------------------------------------------------------------------
  79 C-----------------------------------------------------------------------
  80
  81 C  CHECK THE FILE STATUS
  82 C  ---------------------
  83
  84       CALL STATUS(LUNIT,LUN,IL,IM)
  85       IF(IL.EQ.0) GOTO 900
  86       IF(IL.LT.0) GOTO 901
  87       IF(IM.EQ.0) GOTO 902
  88
  89 C  CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
  90 C  ------------------------------------------------------------------
  91
  92       CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
  93       IF(NTG.GT.1) GOTO 903
  94
  95 C     Check if a specific occurrence of the input string was requested;
  96 C     if not, then the default is to write the first occurrence.
  97
  98       CALL PARUTG(LUN,1,TGS(1),NNOD,KON,ROID)
  99       IF(KON.EQ.6) THEN
 100          IOID=NINT(ROID)
 101          IF(IOID.LE.0) IOID = 1
 102          CTAG = ' '
 103          II = 1
 104          DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#'))
 105             CTAG(II:II)=TGS(1)(II:II)
 106             II = II + 1
 107          ENDDO
 108       ELSE
 109          IOID = 1
 110          CTAG = TGS(1)(1:10)
 111       ENDIF
 112
 113 C  USE THIS LEG FOR STRINGING COMPRESSED DATA (UP TO MXLCC CHARACTERS)
 114 C  ----------------------------------------------------------------
 115
 116       IF(IUPBS3(MBAY(1,LUN),'ICMP').GT.0) THEN
 117          N = 1
 118          ITAGCT = 0
 119          CALL USRTPL(LUN,N,N)
 120          DO WHILE (N+1.LE.NVAL(LUN))
 121             N = N+1
 122             NODE = INV(N,LUN)
 123             IF(ITP(NODE).EQ.1) THEN
 124                CALL USRTPL(LUN,N,MATX(N,NCOL))
 125             ELSEIF(CTAG.EQ.TAG(NODE)) THEN
 126                ITAGCT = ITAGCT + 1
 127                IF(ITAGCT.EQ.IOID) THEN
 128                   IF(ITP(NODE).NE.3) GOTO 904
 129                   CATX(N,NCOL)=' '
 130 C                 --------------------------------------------------
 131 C                 Note: the following stmt enforces a limit of MXLCC
 132 C                 characters per long character string when writing
 133 C                 compressed messages.  This limit keeps the static
 134 C                 array CATX to a reasonable dimensioned size.
 135 C                 --------------------------------------------------
 136                   NCHR=MIN(MXLCC,IBT(NODE)/8)
 137                   CATX(N,NCOL)=CHR(1:NCHR)
 138                   CALL USRTPL(LUN,1,1)
 139                   GOTO 100
 140                ENDIF
 141             ENDIF
 142          ENDDO
 143          GOTO 906
 144       ENDIF
 145
 146 C  OTHERWISE LOCATE THE BEGINNING OF THE DATA (SECTION 4) IN THE MESSAGE
 147 C  ---------------------------------------------------------------------
 148
 149       CALL GETLENS(MBAY(1,LUN),3,LEN0,LEN1,LEN2,LEN3,L4,L5)
 150       MBYTE = LEN0 + LEN1 + LEN2 + LEN3 + 4
 151       NSUBS = 1
 152
 153 C  FIND THE MOST RECENTLY WRITTEN SUBSET IN THE MESSAGE
 154 C  ----------------------------------------------------
 155
 156       DO WHILE(NSUBS.LT.NSUB(LUN))
 157          IBIT = MBYTE*8
 158          CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
 159          MBYTE = MBYTE + NBYT
 160          NSUBS = NSUBS + 1
 161       ENDDO
 162
 163       IF(NSUBS.NE.NSUB(LUN)) GOTO 905
 164
 165 C  LOCATE AND WRITE THE LONG CHARACTER STRING WITHIN THIS SUBSET
 166 C  -------------------------------------------------------------
 167
 168       ITAGCT = 0
 169       MBIT = MBYTE*8 + 16
 170       NBIT = 0
 171       N = 1
 172       CALL USRTPL(LUN,N,N)
 173       DO WHILE (N+1.LE.NVAL(LUN))
 174          N = N+1
 175          NODE = INV(N,LUN)
 176          MBIT = MBIT+NBIT
 177          NBIT = IBT(NODE)
 178          IF(ITP(NODE).EQ.1) THEN
 179             CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 180             CALL USRTPL(LUN,N,IVAL)
 181          ELSEIF(CTAG.EQ.TAG(NODE)) THEN
 182             ITAGCT = ITAGCT + 1
 183             IF(ITAGCT.EQ.IOID) THEN
 184               IF(ITP(NODE).NE.3) GOTO 904
 185               NCHR = NBIT/8
 186               IBIT = MBIT
 187               DO J=1,NCHR
 188                 CALL PKC(' ',1,MBAY(1,LUN),IBIT)
 189               ENDDO
 190               CALL PKC(CHR,NCHR,MBAY(1,LUN),MBIT)
 191               CALL USRTPL(LUN,1,1)
 192               GOTO 100
 193             ENDIF
 194          ENDIF
 195       ENDDO
 196       GOTO 906
 197
 198 C  EXITS
 199 C  -----
 200
 201 100   RETURN
 202 900   CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '//
 203      . 'MUST BE OPEN FOR OUTPUT')
 204 901   CALL BORT('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '//
 205      . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
 206 902   CALL BORT('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '//
 207      . 'BUFR FILE, NONE ARE')
 208 903   WRITE(BORT_STR,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '//
 209      . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'//
 210      . ',")")') STR,NTG
 211       CALL BORT(BORT_STR)
 212 904   WRITE(BORT_STR,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '//
 213      . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') TGS(1),TYP(NODE)
 214       CALL BORT(BORT_STR)
 215 905   WRITE(BORT_STR,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '//
 216      . ' SUBSET NO. (",I3,") IN MSG .NE. THE STORED VALUE FOR THE NO.'//
 217      . ' OF SUBSETS (",I3,") IN MSG")') NSUBS,NSUB(LUN)
 218       CALL BORT(BORT_STR)
 219 906   WRITE(BORT_STR,'("BUFRLB: WRITLC - UNABLE TO FIND ",A," IN '//
 220      . 'SUBSET")') TGS(1)
 221       CALL BORT(BORT_STR)
 222       END