var/external/bufr/readlc.f

   1       SUBROUTINE READLC(LUNIT,CHR,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    READLC
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2003-11-04
   7 C
   8 C ABSTRACT: THIS SUBROUTINE RETURNS 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 RETURN CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT
  12 C   BYTES.
  13 C
  14 C PROGRAM HISTORY LOG:
  15 C 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR
  16 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  17 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  18 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  19 C                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
  20 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  21 C                           20,000 TO 50,000 BYTES
  22 C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  23 C 2009-03-23  J. ATOR    -- ADDED CAPABILITY FOR COMPRESSED MESSAGES;
  24 C                           ADDED CHECK FOR OVERFLOW OF CHR; ADDED '#'
  25 C                           OPTION FOR MORE THAN ONE OCCURRENCE OF STR
  26 C 2009-04-21  J. ATOR    -- USE ERRWRT
  27 C 2012-12-07  J. ATOR    -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS
  28 C                           WHEN USED WITH '#' OCCURRENCE CODE
  29 C
  30 C USAGE:    CALL READLC (LUNIT, CHR, STR)
  31 C   INPUT ARGUMENT LIST:
  32 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  33 C     STR      - CHARACTER*(*): STRING (I.E., MNEMONIC)
  34 C
  35 C   OUTPUT ARGUMENT LIST:
  36 C     CHR      - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E.,
  37 C                CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES)
  38 C
  39 C REMARKS:
  40 C    THIS ROUTINE CALLS:        BORT     ERRWRT   PARSTR   PARUTG
  41 C                               STATUS   UPC
  42 C    THIS ROUTINE IS CALLED BY: UFBDMP   UFDUMP   WRTREE
  43 C                               Also called by application programs.
  44 C
  45 C ATTRIBUTES:
  46 C   LANGUAGE: FORTRAN 77
  47 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  48 C
  49 C$$$
  50
  51       INCLUDE 'bufrlib.prm'
  52
  53       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  54      .                MBAY(MXMSGLD4,NFILES)
  55       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  56      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  57      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  58      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  59      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  60       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  61       COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST)
  62       COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS)
  63       COMMON /UNPTYP/ MSGUNP(NFILES)
  64       COMMON /QUIET / IPRT
  65
  66       CHARACTER*(*) CHR,STR
  67       CHARACTER*128 BORT_STR,ERRSTR
  68       CHARACTER*10  TAG,CTAG,CRTAG
  69       CHARACTER*14  TGS(10)
  70       CHARACTER*3   TYP
  71       REAL*8        VAL
  72
  73       DATA MAXTG /10/
  74
  75 C-----------------------------------------------------------------------
  76 C-----------------------------------------------------------------------
  77
  78       CHR = ' '
  79
  80 C  CHECK THE FILE STATUS
  81 C  ---------------------
  82
  83       CALL STATUS(LUNIT,LUN,IL,IM)
  84       IF(IL.EQ.0) GOTO 900
  85       IF(IL.GT.0) GOTO 901
  86       IF(IM.EQ.0) GOTO 902
  87
  88 C  CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
  89 C  ------------------------------------------------------------------
  90
  91       CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
  92       IF(NTG.GT.1) GOTO 903
  93
  94 C     Check if a specific occurrence of the input string was requested;
  95 C     if not, then the default is to return the first occurrence.
  96
  97       CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID)
  98       IF(KON.EQ.6) THEN
  99          IOID=NINT(ROID)
 100          IF(IOID.LE.0) IOID = 1
 101          CTAG = ' '
 102          II = 1
 103          DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#'))
 104             CTAG(II:II)=TGS(1)(II:II)
 105             II = II + 1
 106          ENDDO
 107       ELSE
 108          IOID = 1
 109          CTAG = TGS(1)(1:10)
 110       ENDIF
 111
 112 C  LOCATE AND DECODE THE LONG CHARACTER STRING
 113 C  -------------------------------------------
 114
 115       IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN
 116
 117 C        The message is uncompressed
 118
 119          ITAGCT = 0
 120          DO N=1,NVAL(LUN)
 121            NOD = INV(N,LUN)
 122            IF(CTAG.EQ.TAG(NOD)) THEN
 123              ITAGCT = ITAGCT + 1
 124              IF(ITAGCT.EQ.IOID) THEN
 125                IF(ITP(NOD).NE.3) GOTO 904
 126                NCHR = NBIT(N)/8
 127                IF(NCHR.GT.LEN(CHR)) GOTO 905
 128                KBIT = MBIT(N)
 129                CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT)
 130                GOTO 100
 131              ENDIF
 132            ENDIF
 133          ENDDO
 134       ELSEIF(MSGUNP(LUN).EQ.2) THEN
 135
 136 C        The message is compressed
 137
 138          IF(NRST.GT.0) THEN
 139            ITAGCT = 0
 140            DO II=1,NRST
 141              IF(CTAG.EQ.CRTAG(II)) THEN
 142                ITAGCT = ITAGCT + 1
 143                IF(ITAGCT.EQ.IOID) THEN
 144                  NCHR = IRNCH(II)
 145                  IF(NCHR.GT.LEN(CHR)) GOTO 905
 146                  KBIT = IRBIT(II)
 147                  CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT)
 148                  GOTO 100
 149                ENDIF
 150              ENDIF
 151            ENDDO
 152          ENDIF
 153       ELSE
 154          GOTO 906
 155       ENDIF
 156
 157 C     If we made it here, then we couldn't find the requested string.
 158
 159       IF(IPRT.GE.0) THEN
 160       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 161       ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) //
 162      .   ' NOT LOCATED IN REPORT SUBSET - RETURN WITH BLANK' //
 163      .   ' STRING FOR CHARACTER DATA ELEMENT'
 164       CALL ERRWRT(ERRSTR)
 165       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 166       CALL ERRWRT(' ')
 167       ENDIF
 168
 169 C  EXITS
 170 C  -----
 171
 172 100   RETURN
 173 900   CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
 174      . ' BE OPEN FOR INPUT')
 175 901   CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
 176      . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
 177 902   CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
 178      . 'BUFR FILE, NONE ARE')
 179 903   WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
 180      . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
 181      . 'I3,")")') STR,NTG
 182       CALL BORT(BORT_STR)
 183 904   WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
 184      . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD)
 185       CALL BORT(BORT_STR)
 186 905   WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
 187      . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
 188      . 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LEN(CHR)
 189       CALL BORT(BORT_STR)
 190 906   WRITE(BORT_STR,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'//
 191      . '" IS NOT RECOGNIZED")') MSGUNP
 192       CALL BORT(BORT_STR)
 193       END