var/external/bufr/ufbget.f

   1       SUBROUTINE UFBGET(LUNIT,TAB,I1,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBGET
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE UNPACKS AND RETURNS THE VALUES FOR ONE-
   9 C   DIMENSIONAL DESCRIPTORS IN THE INPUT STRING WITHOUT ADVANCING THE
  10 C   SUBSET POINTER.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  15 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  16 C                           ROUTINE "BORT"; IMPROVED MACHINE
  17 C                           PORTABILITY
  18 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  19 C                           LINING CODE WITH FPP DIRECTIVES
  20 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  21 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  22 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  23 C                           BUFR FILES UNDER THE MPI)
  24 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  25 C                           10,000 TO 20,000 BYTES
  26 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  27 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  28 C                           INTERDEPENDENCIES
  29 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  30 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  31 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  32 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  33 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  34 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  35 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  36 C                           20,000 TO 50,000 BYTES
  37 C 2012-03-02  J. ATOR    -- USE FUNCTION UPS
  38 C
  39 C USAGE:    CALL UFBGET (LUNIT, TAB, I1, IRET, STR)
  40 C   INPUT ARGUMENT LIST:
  41 C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
  42 C     I1       - INTEGER: LENGTH OF TAB
  43 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
  44 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH THE WORDS
  45 C                IN THE ARRAY TAB
  46 C                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
  47 C                     TO TABLE B, THESE RETURN THE FOLLOWING
  48 C                     INFORMATION IN CORRESPONDING TAB LOCATION:
  49 C                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
  50 C                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
  51 C                            MESSAGE (RECORD) NUMBER IN WHICH THIS
  52 C                            SUBSET RESIDES
  53 C                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
  54 C                            NUMBER OF THIS SUBSET WITHIN THE BUFR
  55 C                            MESSAGE (RECORD) NUMBER 'IREC'
  56 C
  57 C   OUTPUT ARGUMENT LIST:
  58 C     TAB      - REAL*8: (I1) STARTING ADDRESS OF DATA VALUES READ FROM
  59 C                DATA SUBSET
  60 C     IRET     - INTEGER: RETURN CODE:
  61 C                       0 = normal return
  62 C                      -1 = there are no more subsets in the BUFR
  63 C                           message
  64 C
  65 C REMARKS:
  66 C    THIS ROUTINE CALLS:        BORT     INVWIN   STATUS   STRING
  67 C                               UPBB     UPC      UPS      USRTPL
  68 C    THIS ROUTINE IS CALLED BY: None
  69 C                               Normally called only by application
  70 C                               programs.
  71 C
  72 C ATTRIBUTES:
  73 C   LANGUAGE: FORTRAN 77
  74 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  75 C
  76 C$$$
  77
  78       INCLUDE 'bufrlib.prm'
  79
  80       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  81      .                INODE(NFILES),IDATE(NFILES)
  82       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  83      .                MBAY(MXMSGLD4,NFILES)
  84       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  85       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
  86       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  87      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  88      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  89      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  90      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  91       COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS)
  92
  93       CHARACTER*(*) STR
  94       CHARACTER*10  TAG
  95       CHARACTER*8   CVAL
  96       CHARACTER*3   TYP
  97       EQUIVALENCE   (CVAL,RVAL)
  98       REAL*8        VAL,RVAL,TAB(I1),UPS
  99
 100 C-----------------------------------------------------------------------
 101       MPS(NODE) = 2**(IBT(NODE))-1
 102 C-----------------------------------------------------------------------
 103
 104       IRET = 0
 105
 106       DO I=1,I1
 107       TAB(I) = BMISS
 108       ENDDO
 109
 110 C  MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT
 111 C  ------------------------------------------
 112
 113       CALL STATUS(LUNIT,LUN,IL,IM)
 114       IF(IL.EQ.0) GOTO 900
 115       IF(IL.GT.0) GOTO 901
 116       IF(IM.EQ.0) GOTO 902
 117
 118 C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
 119 C  ---------------------------------------------
 120
 121       IF(NSUB(LUN).EQ.MSUB(LUN)) THEN
 122          IRET = -1
 123          GOTO 100
 124       ENDIF
 125
 126 C  PARSE THE STRING
 127 C  ----------------
 128
 129       CALL STRING(STR,LUN,I1,0)
 130
 131 C  EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE
 132 C  ---------------------------------------------------------
 133
 134       N = 1
 135       NBIT(N) = 0
 136       MBIT(N) = MBYT(LUN)*8 + 16
 137       CALL USRTPL(LUN,N,N)
 138
 139 10    DO N=N+1,NVAL(LUN)
 140       NODE = INV(N,LUN)
 141       NBIT(N) = IBT(NODE)
 142       MBIT(N) = MBIT(N-1)+NBIT(N-1)
 143       IF(NODE.EQ.NODS(NNOD)) THEN
 144          NVAL(LUN) = N
 145          GOTO 20
 146       ELSEIF(ITP(NODE).EQ.1) THEN
 147          CALL UPBB(IVAL,NBIT(N),MBIT(N),MBAY(1,LUN))
 148          CALL USRTPL(LUN,N,IVAL)
 149          GOTO 10
 150       ENDIF
 151       ENDDO
 152 20    CONTINUE
 153
 154 C  UNPACK ONLY THE NODES FOUND IN THE STRING
 155 C  -----------------------------------------
 156
 157       DO I=1,NNOD
 158       NODE = NODS(I)
 159       INVN = INVWIN(NODE,LUN,1,NVAL(LUN))
 160       IF(INVN.GT.0) THEN
 161          CALL UPBB(IVAL,NBIT(INVN),MBIT(INVN),MBAY(1,LUN))
 162          IF(ITP(NODE).EQ.1) THEN
 163             TAB(I) = IVAL
 164          ELSEIF(ITP(NODE).EQ.2) THEN
 165             IF(IVAL.LT.MPS(NODE)) TAB(I) = UPS(IVAL,NODE)
 166          ELSEIF(ITP(NODE).EQ.3) THEN
 167             CVAL = ' '
 168             KBIT = MBIT(INVN)
 169             CALL UPC(CVAL,NBIT(INVN)/8,MBAY(1,LUN),KBIT)
 170             TAB(I) = RVAL
 171          ENDIF
 172       ELSE
 173          TAB(I) = BMISS
 174       ENDIF
 175       ENDDO
 176
 177 C  EXITS
 178 C  -----
 179
 180 100   RETURN
 181 900   CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'//
 182      . ' BE OPEN FOR INPUT')
 183 901   CALL BORT('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
 184      . ', IT MUST BE OPEN FOR INPUT')
 185 902   CALL BORT('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '//
 186      . 'BUFR FILE, NONE ARE')
 187       END