ufbtam.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> 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
C> 2012-03-02  J. ATOR    -- USE FUNCTION UPS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2022-05-06  J. WOOLLEN -- REPLACE UPBB WITH UPB8 FOR 8BYTE INTEGERS
C>                           USE NBMP FOR USRTPL             
C>
C> USAGE:    CALL UFBTAM (TAB, I1, I2, IRET, STR)
C>   INPUT ARGUMENT LIST:
C>     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF TAB (MUST BE AT
C>                LEAST AS LARGE AS THE NUMBER OF BLANK-SEPARATED
C>                MNEMONICS IN STR)
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>                               UPB8     UPC      UPS      USRTPL
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE ufbtam(TAB,I1,I2,IRET,STR)
 
      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_msgmem
      USE moda_tables
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),vals(10),kons(10)
      COMMON /quiet / iprt
 
      CHARACTER*(*) STR
      CHARACTER*128 BORT_STR,ERRSTR
      CHARACTER*10  TGS(100)
      CHARACTER*8   SUBSET,CVAL
      equivalence(cval,rval)
      integer*8     mps,ival
      real*8        tab(i1,i2),rval,ups
 
      DATA maxtg /100/
 
C-----------------------------------------------------------------------
      mps(node) = 2_8**(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 upb8(ival,nbit,mbit,mbay(1,lun))
               nbmp=ival; CALL usrtpl(lun,n,nbmp)
            ENDIF
            DO i=1,nnod
            IF(nods(i).EQ.node) THEN
               IF(itp(node).EQ.1) THEN
                  CALL upb8(ival,nbit,mbit,mbay(1,lun))
                  tab(i,iret) = ival
               ELSEIF(itp(node).EQ.2) THEN
                  CALL upb8(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,.true.)
                  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 ',
     . .GT.'IS  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