var/external/bufr/ufbtam.f

   1       SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBTAM
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES INTO INTERNAL ARRAYS
   9 C   FROM ALL DATA SUBSETS IN BUFR MESSAGES STORED IN INTERNAL MEMORY.
  10 C   THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE IS NO
  11 C   REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT THIS
  12 C   SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC IN
  13 C   EACH SUBSET).  UFBTAM PROVIDES A MECHANISM WHEREBY A USER CAN DO A
  14 C   QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE OR MORE
  15 C   MNEMNONICS AMONGST ALL DATA SUBSETS FOR A GROUP OF BUFR MESSAGES
  16 C   STORED IN INTERNAL MEMORY, NO OTHER BUFR ARCHIVE LIBRARY ROUTINES
  17 C   HAVE TO BE CALLED.  THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE
  18 C   LIBRARY SUBROUTINE UFBTAB EXCEPT UFBTAB READS SUBSETS FROM MESSAGES
  19 C   IN A PHYSICAL BUFR FILE.  UFBTAM CURRENTLY CANNOT READ DATA FROM
  20 C   COMPRESSED BUFR MESSAGES.
  21 C
  22 C PROGRAM HISTORY LOG:
  23 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  24 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  25 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  26 C                           ROUTINE "BORT"
  27 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  28 C                           LINING CODE WITH FPP DIRECTIVES
  29 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  30 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  31 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  32 C                           BUFR FILES UNDER THE MPI)
  33 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  34 C                           10,000 TO 20,000 BYTES
  35 C 2001-08-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  36 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  37 C                           INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
  38 C                           16 MBYTES; MODIFIED TO NOT ABORT WHEN THERE
  39 C                           ARE TOO MANY SUBSETS COMING IN (I.E., .GT.
  40 C                           I2), BUT RATHER JUST PROCESS I2 REPORTS AND
  41 C                           PRINT A DIAGNOSTIC
  42 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  43 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  44 C                           INTERDEPENDENCIES
  45 C 2003-11-04  D. KEYSER  -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
  46 C                           BUFR MESSAGES WHICH CAN BE STORED
  47 C                           INTERNALLY) INCREASED FROM 50000 TO 200000;
  48 C                           MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  49 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  50 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  51 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  52 C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
  53 C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
  54 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  55 C                           20,000 TO 50,000 BYTES
  56 C 2004-11-15  D. KEYSER  -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
  57 C                           BYTES REQUIRED TO STORE ALL MESSAGES
  58 C                           INTERNALLY) WAS INCREASED FROM 16 MBYTES TO
  59 C                           50 MBYTES
  60 C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  61 C 2009-04-21  J. ATOR    -- USE ERRWRT
  62 C 2009-10-21  D. KEYSER  -- ADDED OPTION TO INPUT NEW MNEMONIC "ITBL"
  63 C                           IN ARGUMENT STR, RETURNS THE BUFR
  64 C                           DICTIONARY TABLE NUMBER ASSOCIATED WITH
  65 C                           EACH SUBSET IN INTERNAL MEMORY
  66 C 2012-03-02  J. ATOR    -- USE FUNCTION UPS
  67 C
  68 C USAGE:    CALL UFBTAM (TAB, I1, I2, IRET, STR)
  69 C   INPUT ARGUMENT LIST:
  70 C     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF TAB OR THE
  71 C                NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
  72 C                MUST BE .GE. LATTER)
  73 C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF TAB
  74 C     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
  75 C                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
  76 C                DIMENSION OF TAB
  77 C                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
  78 C                     TO TABLE B, THESE RETURN THE FOLLOWING
  79 C                     INFORMATION IN CORRESPONDING TAB LOCATION:
  80 C                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
  81 C                     'IREC' WHICH ALWAYS RETURNS THE BUFR MESSAGE
  82 C                            (RECORD) NUMBER IN WHICH EACH SUBSET IN
  83 C                            INTERNAL MEMORY RESIDES
  84 C                     'ISUB' WHICH ALWAYS RETURNS THE LOCATION WITHIN
  85 C                            MESSAGE "IREC" (I.E., THE SUBSET NUMBER)
  86 C                            FOR EACH SUBSET IN INTERNAL MEMORY
  87 C                     'ITBL' WHICH ALWAYS RETURNS THE BUFR DICTIONARY
  88 C                            TABLE NUMBER ASSOCIATED WITH EACH SUBSET
  89 C                            IN INTERNAL MEMORY
  90 C
  91 C   OUTPUT ARGUMENT LIST:
  92 C     TAB      - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ
  93 C                FROM INTERNAL MEMORY
  94 C     IRET     - INTEGER: NUMBER OF DATA SUBSETS IN INTERNAL MEMORY
  95 C                (MUST BE NO LARGER THAN I2)
  96 C
  97 C REMARKS:
  98 C    NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR
  99 C    MESSAGES INTO INTERNAL MEMORY.
 100 C
 101 C    THIS ROUTINE CALLS:        BORT     ERRWRT   NMSUB    PARSTR
 102 C                               RDMEMM   STATUS   STRING   UPB
 103 C                               UPBB     UPC      UPS      USRTPL
 104 C    THIS ROUTINE IS CALLED BY: None
 105 C                               Normally called only by application
 106 C                               programs.
 107 C
 108 C ATTRIBUTES:
 109 C   LANGUAGE: FORTRAN 77
 110 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 111 C
 112 C$$$
 113
 114       INCLUDE 'bufrlib.prm'
 115
 116       COMMON /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
 117      .                MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
 118      .                IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
 119       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 120      .                INODE(NFILES),IDATE(NFILES)
 121       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
 122      .                MBAY(MXMSGLD4,NFILES)
 123       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 124       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),VALS(10),KONS(10)
 125       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
 126      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
 127      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
 128      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
 129      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
 130       COMMON /QUIET / IPRT
 131
 132       CHARACTER*(*) STR
 133       CHARACTER*128 BORT_STR,ERRSTR
 134       CHARACTER*10  TAG,TGS(100)
 135       CHARACTER*8   SUBSET,CVAL
 136       CHARACTER*3   TYP
 137       EQUIVALENCE   (CVAL,RVAL)
 138       REAL*8        TAB(I1,I2),VAL,RVAL,UPS
 139
 140       DATA MAXTG /100/
 141
 142 C-----------------------------------------------------------------------
 143       MPS(NODE) = 2**(IBT(NODE))-1
 144 C-----------------------------------------------------------------------
 145
 146       IRET = 0
 147
 148       IF(MSGP(0).EQ.0) GOTO 100
 149
 150       DO J=1,I2
 151       DO I=1,I1
 152       TAB(I,J) = BMISS
 153       ENDDO
 154       ENDDO
 155
 156 C  CHECK FOR SPECIAL TAGS IN STRING
 157 C  --------------------------------
 158
 159       CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
 160       IREC = 0
 161       ISUB = 0
 162       ITBL = 0
 163       DO I=1,NTG
 164       IF(TGS(I).EQ.'IREC') IREC = I
 165       IF(TGS(I).EQ.'ISUB') ISUB = I
 166       IF(TGS(I).EQ.'ITBL') ITBL = I
 167       ENDDO
 168
 169 C  READ A MESSAGE AND PARSE A STRING
 170 C  ---------------------------------
 171
 172       CALL STATUS(MUNIT,LUN,IL,IM)
 173
 174       DO IMSG=1,MSGP(0)
 175       CALL RDMEMM(IMSG,SUBSET,JDATE,MRET)
 176       IF(MRET.LT.0) GOTO 900
 177
 178       CALL STRING(STR,LUN,I1,0)
 179       IF(IREC.GT.0) NODS(IREC) = 0
 180       IF(ISUB.GT.0) NODS(ISUB) = 0
 181       IF(ITBL.GT.0) NODS(ITBL) = 0
 182
 183 C  PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE
 184 C  ---------------------------------------------
 185
 186       DO WHILE (NSUB(LUN).LT.MSUB(LUN))
 187          IF(IRET+1.GT.I2) GOTO 99
 188          IRET = IRET+1
 189
 190          DO I=1,NNOD
 191          NODS(I) = ABS(NODS(I))
 192          ENDDO
 193
 194          CALL USRTPL(LUN,1,1)
 195          MBIT = MBYT(LUN)*8+16
 196          NBIT = 0
 197          N = 1
 198
 199 20       IF(N+1.LE.NVAL(LUN)) THEN
 200             N = N+1
 201             NODE = INV(N,LUN)
 202             MBIT = MBIT+NBIT
 203             NBIT = IBT(NODE)
 204             IF(ITP(NODE).EQ.1) THEN
 205                CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 206                CALL USRTPL(LUN,N,IVAL)
 207             ENDIF
 208             DO I=1,NNOD
 209             IF(NODS(I).EQ.NODE) THEN
 210                IF(ITP(NODE).EQ.1) THEN
 211                   CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 212                   TAB(I,IRET) = IVAL
 213                ELSEIF(ITP(NODE).EQ.2) THEN
 214                   CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 215                   IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE)
 216                ELSEIF(ITP(NODE).EQ.3) THEN
 217                   CVAL = ' '
 218                   KBIT = MBIT
 219                   CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT)
 220                   TAB(I,IRET) = RVAL
 221                ENDIF
 222                NODS(I) = -NODS(I)
 223                GOTO 20
 224             ENDIF
 225             ENDDO
 226             DO I=1,NNOD
 227             IF(NODS(I).GT.0) GOTO 20
 228             ENDDO
 229          ENDIF
 230
 231 C  UPDATE THE SUBSET POINTERS BEFORE NEXT READ
 232 C  -------------------------------------------
 233
 234          IBIT = MBYT(LUN)*8
 235          CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
 236          MBYT(LUN) = MBYT(LUN) + NBYT
 237          NSUB(LUN) = NSUB(LUN) + 1
 238          IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN)
 239          IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN)
 240          IF(ITBL.GT.0) TAB(ITBL,IRET) = LDXTS
 241       ENDDO
 242
 243       ENDDO
 244
 245       GOTO 200
 246
 247 C  EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
 248 C  -------------------------------------------
 249
 250 99    CALL RDMEMM(0,SUBSET,JDATE,MRET)
 251       NREP = 0
 252       DO IMSG=1,MSGP(0)
 253       CALL RDMEMM(IMSG,SUBSET,JDATE,MRET)
 254       IF(MRET.LT.0) GOTO 900
 255       NREP = NREP+NMSUB(MUNIT)
 256       ENDDO
 257       IF(IPRT.GE.0) THEN
 258       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 259       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' )
 260      . 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ',
 261      . 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - ',
 262      . 'INCOMPLETE READ'
 263       CALL ERRWRT(ERRSTR)
 264       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 265      . '>>>UFBTAM STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<'
 266       CALL ERRWRT(ERRSTR)
 267       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 268       CALL ERRWRT(' ')
 269       ENDIF
 270
 271 C  RESET THE MEMORY FILE
 272 C  ---------------------
 273
 274 200   CALL RDMEMM(0,SUBSET,JDATE,MRET)
 275
 276 C  EXITS
 277 C  -----
 278
 279 100   RETURN
 280 900   WRITE(BORT_STR,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '//
 281      . 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') IMSG
 282       CALL BORT(BORT_STR)
 283       END