<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='UFBTAM'><A href='../../html_code/bufr/ufbtam.f.html#UFBTAM' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE UFBTAM(TAB,I1,I2,IRET,STR) 1
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: UFBTAM
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE READS SPECIFIED VALUES INTO INTERNAL ARRAYS
C FROM ALL DATA SUBSETS IN BUFR MESSAGES STORED IN INTERNAL MEMORY.
C THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE IS NO
C REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT THIS
C SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC IN
C EACH SUBSET). UFBTAM PROVIDES A MECHANISM WHEREBY A USER CAN DO A
C QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE OR MORE
C MNEMNONICS AMONGST ALL DATA SUBSETS FOR A GROUP OF BUFR MESSAGES
C STORED IN INTERNAL MEMORY, NO OTHER BUFR ARCHIVE LIBRARY ROUTINES
C HAVE TO BE CALLED. THIS SUBROUTINE IS SIMILAR TO BUFR ARCHIVE
C LIBRARY SUBROUTINE UFBTAB EXCEPT UFBTAB READS SUBSETS FROM MESSAGES
C IN A PHYSICAL BUFR FILE. UFBTAM CURRENTLY CANNOT READ DATA FROM
C COMPRESSED BUFR MESSAGES.
C
C PROGRAM HISTORY LOG:
C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C ROUTINE "BORT"
C 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C LINING CODE WITH FPP DIRECTIVES
C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C OPENED AT ONE TIME INCREASED FROM 10 TO 32
C (NECESSARY IN ORDER TO PROCESS MULTIPLE
C BUFR FILES UNDER THE MPI)
C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C 10,000 TO 20,000 BYTES
C 2001-08-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
C BYTES REQUIRED TO STORE ALL MESSAGES
C INTERNALLY) WAS INCREASED FROM 8 MBYTES TO
C 16 MBYTES; MODIFIED TO NOT ABORT WHEN THERE
C ARE TOO MANY SUBSETS COMING IN (I.E., .GT.
C I2), BUT RATHER JUST PROCESS I2 REPORTS AND
C PRINT A DIAGNOSTIC
C 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- PARAMETER MAXMSG (THE MAXIMUM NUMBER OF
C BUFR MESSAGES WHICH CAN BE STORED
C INTERNALLY) INCREASED FROM 50000 TO 200000;
C MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C INCREASED FROM 15000 TO 16000 (WAS IN
C VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C WRF; ADDED DOCUMENTATION (INCLUDING
C HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C INFO WHEN ROUTINE TERMINATES ABNORMALLY
C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C 20,000 TO 50,000 BYTES
C 2004-11-15 D. KEYSER -- PARAMETER MAXMEM (THE MAXIMUM NUMBER OF
C BYTES REQUIRED TO STORE ALL MESSAGES
C INTERNALLY) WAS INCREASED FROM 16 MBYTES TO
C 50 MBYTES
C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C 2009-04-21 J. ATOR -- USE ERRWRT
C 2009-10-21 D. KEYSER -- ADDED OPTION TO INPUT NEW MNEMONIC "ITBL"
C IN ARGUMENT STR, RETURNS THE BUFR
C DICTIONARY TABLE NUMBER ASSOCIATED WITH
C EACH SUBSET IN INTERNAL MEMORY
<A NAME='UPS'><A href='../../html_code/bufr/ufbtam.f.html#UPS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
C 2012-03-02 J. ATOR -- USE FUNCTION UPS 6,87
C
C USAGE: CALL UFBTAM
(TAB, I1, I2, IRET, STR)
C INPUT ARGUMENT LIST:
C I1 - INTEGER: LENGTH OF FIRST DIMENSION OF TAB OR THE
C NUMBER OF BLANK-SEPARATED MNEMONICS IN STR (FORMER
C MUST BE .GE. LATTER)
C I2 - INTEGER: LENGTH OF SECOND DIMENSION OF TAB
C STR - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
C MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
C DIMENSION OF TAB
C - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
C TO TABLE B, THESE RETURN THE FOLLOWING
C INFORMATION IN CORRESPONDING TAB LOCATION:
C 'NUL' WHICH ALWAYS RETURNS BMISS ("MISSING")
C 'IREC' WHICH ALWAYS RETURNS THE BUFR MESSAGE
C (RECORD) NUMBER IN WHICH EACH SUBSET IN
C INTERNAL MEMORY RESIDES
C 'ISUB' WHICH ALWAYS RETURNS THE LOCATION WITHIN
C MESSAGE "IREC" (I.E., THE SUBSET NUMBER)
C FOR EACH SUBSET IN INTERNAL MEMORY
C 'ITBL' WHICH ALWAYS RETURNS THE BUFR DICTIONARY
C TABLE NUMBER ASSOCIATED WITH EACH SUBSET
C IN INTERNAL MEMORY
C
C OUTPUT ARGUMENT LIST:
C TAB - REAL*8: (I1,I2) STARTING ADDRESS OF DATA VALUES READ
C FROM INTERNAL MEMORY
C IRET - INTEGER: NUMBER OF DATA SUBSETS IN INTERNAL MEMORY
C (MUST BE NO LARGER THAN I2)
C
C REMARKS:
C NOTE THAT UFBMEM IS CALLED PRIOR TO THIS TO STORE THE BUFR
C MESSAGES INTO INTERNAL MEMORY.
C
C THIS ROUTINE CALLS: BORT ERRWRT NMSUB PARSTR
C RDMEMM STATUS STRING UPB
C UPBB UPC UPS 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 /MSGMEM/ MUNIT,MLAST,MSGP(0:MAXMSG),MSGS(MAXMEM),
. MDX(MXDXW),IPDXM(MXDXM),LDXM,NDXM,LDXTS,NDXTS,
. IFDXTS(MXDXTS),ICDXTS(MXDXTS),IPMSGS(MXDXTS)
COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
. INODE(NFILES),IDATE(NFILES)
COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
. MBAY(MXMSGLD4,NFILES)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),VALS(10),KONS(10)
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 /QUIET / IPRT
CHARACTER*(*) STR
CHARACTER*128 BORT_STR,ERRSTR
CHARACTER*10 TAG,TGS(100)
CHARACTER*8 SUBSET,CVAL
CHARACTER*3 TYP
EQUIVALENCE (CVAL,RVAL)
REAL*8 TAB(I1,I2),VAL,RVAL,UPS
DATA MAXTG /100/
C-----------------------------------------------------------------------
MPS(NODE) = 2**(IBT(NODE))-1
C-----------------------------------------------------------------------
IRET = 0
IF(MSGP(0).EQ.0) GOTO 100
DO J=1,I2
DO I=1,I1
TAB(I,J) = BMISS
ENDDO
ENDDO
C CHECK FOR SPECIAL TAGS IN STRING
C --------------------------------
CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
IREC = 0
ISUB = 0
ITBL = 0
DO I=1,NTG
IF(TGS(I).EQ.'IREC') IREC = I
IF(TGS(I).EQ.'ISUB') ISUB = I
IF(TGS(I).EQ.'ITBL') ITBL = I
ENDDO
C READ A MESSAGE AND PARSE A STRING
C ---------------------------------
CALL STATUS(MUNIT,LUN,IL,IM)
DO IMSG=1,MSGP(0)
CALL RDMEMM(IMSG,SUBSET,JDATE,MRET)
IF(MRET.LT.0) GOTO 900
CALL STRING(STR,LUN,I1,0)
IF(IREC.GT.0) NODS(IREC) = 0
IF(ISUB.GT.0) NODS(ISUB) = 0
IF(ITBL.GT.0) NODS(ITBL) = 0
C PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE
C ---------------------------------------------
DO WHILE (NSUB(LUN).LT.MSUB(LUN))
IF(IRET+1.GT.I2) GOTO 99
IRET = IRET+1
DO I=1,NNOD
NODS(I) = ABS(NODS(I))
ENDDO
CALL USRTPL(LUN,1,1)
MBIT = MBYT(LUN)*8+16
NBIT = 0
N = 1
20 IF(N+1.LE.NVAL(LUN)) THEN
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)
ENDIF
DO I=1,NNOD
IF(NODS(I).EQ.NODE) THEN
IF(ITP(NODE).EQ.1) THEN
CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
TAB(I,IRET) = IVAL
ELSEIF(ITP(NODE).EQ.2) THEN
CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE)
ELSEIF(ITP(NODE).EQ.3) THEN
CVAL = ' '
KBIT = MBIT
CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT)
TAB(I,IRET) = RVAL
ENDIF
NODS(I) = -NODS(I)
GOTO 20
ENDIF
ENDDO
DO I=1,NNOD
IF(NODS(I).GT.0) GOTO 20
ENDDO
ENDIF
C UPDATE THE SUBSET POINTERS BEFORE NEXT READ
C -------------------------------------------
IBIT = MBYT(LUN)*8
CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
MBYT(LUN) = MBYT(LUN) + NBYT
NSUB(LUN) = NSUB(LUN) + 1
IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN)
IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN)
IF(ITBL.GT.0) TAB(ITBL,IRET) = LDXTS
ENDDO
ENDDO
GOTO 200
C EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
C -------------------------------------------
99 CALL RDMEMM(0,SUBSET,JDATE,MRET)
NREP = 0
DO IMSG=1,MSGP(0)
CALL RDMEMM(IMSG,SUBSET,JDATE,MRET)
IF(MRET.LT.0) GOTO 900
NREP = NREP+NMSUB(MUNIT)
ENDDO
IF(IPRT.GE.0) THEN
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' )
. 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ',
. 'IS .GT. LIMIT OF ', I2, ' IN THE 3RD ARG. (INPUT) - ',
. 'INCOMPLETE READ'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
. '>>>UFBTAM STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<'
CALL ERRWRT(ERRSTR)
CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
C RESET THE MEMORY FILE
C ---------------------
200 CALL RDMEMM(0,SUBSET,JDATE,MRET)
C EXITS
C -----
100 RETURN
900 WRITE(BORT_STR,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '//
. 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') IMSG
CALL BORT(BORT_STR)
END