ufbin3.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 2003-11-04
      
C> THIS SUBROUTINE READS SPECIFIED VALUES FROM THE CURRENT
C>   BUFR DATA SUBSET WITHIN INTERNAL ARRAYS.  THE DATA VALUES
C>   CORRESPOND TO MNEMONICS WHICH ARE PART OF A MULTIPLE-REPLICATION
C>   SEQUENCE WITHIN ANOTHER MULTIPLE-REPLICATION SEQUENCE.  THE INNER
C>   SEQUENCE IS USUALLY ASSOCIATED WITH DATA "LEVELS" AND THE OUTER
C>   SEQUENCE WITH DATA "EVENTS".  THE BUFR FILE IN LOGICAL UNIT LUNIT
C>   MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR ARCHIVE
C>   LIBRARY SUBROUTINE OPENBF.  IN ADDITION, THE DATA SUBSET MUST HAVE
C>   SUBSEQUENTLY BEEN READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY
C>   ARRAYS VIA CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR
C>   READERME FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE
C>   READSB (OR VIA A SINGLE CALL TO BUFR ARCHIVE LIBRARY
C>   SUBROUTINE READNS).  THIS SUBROUTINE IS DESIGNED TO READ EVENT
C>   INFORMATION FROM "PREPFITS" TYPE BUFR FILES (BUT NOT FROM
C>   "PREPBUFR" TYPE FILES!!).  PREPFITS FILES HAVE THE FOLLOWING BUFR
C>   TABLE EVENT STRUCTURE (NOTE SIXTEEN CHARACTERS HAVE BEEN REMOVED
C>   FROM THE LAST COLUMN TO ALLOW THE TABLE TO FIT IN THIS DOCBLOCK):
C>
C>   | ADPUPA   | HEADR  {PLEVL}
C>   |----------|----------------   
C>   | HEADR    | SID XOB YOB DHR ELV TYP T29 ITP                   
C>   | PLEVL    | CAT PRC PQM QQM TQM ZQM WQM CDTP_QM [OBLVL]       
C>   | OBLVL    | SRC FHR <PEVN> <QEVN> <TEVN> <ZEVN> <WEVN> <CEVN> 
C>   | OBLVL    | <CTPEVN>                                          
C>   | PEVN     | POB  PMO                                          
C>   | QEVN     | QOB                                               
C>   | TEVN     | TOB                                               
C>   | ZEVN     | ZOB                                               
C>   | WEVN     | UOB  VOB                                          
C>   | CEVN     | CAPE CINH LI                                      
C>   | CTPEVN   | CDTP GCDTT TOCC                                   
C>
C>   NOTE THAT THE ONE-BIT DELAYED REPLICATED SEQUENCES "<xxxx>" ARE
C>   NESTED INSIDE THE EIGHT-BIT DELAYED REPLIATION EVENT SEQUENCES
C>   "[yyyy]".  THE ANALOGOUS BUFR ARCHIVE LIBRARY SUBROUTINE UFBEVN
C>   DOES NOT WORK PROPERLY ON THIS TYPE OF EVENT STRUCTURE.  IT WORKS
C>   ONLY ON THE EVENT STRUCTURE FOUND IN "PREPBUFR" TYPE BUFR FILES
C>   (SEE UFBEVN FOR MORE DETAILS).  IN TURN, UFBIN3 DOES NOT WORK
C>   PROPERLY ON THE EVENT STRUCTURE FOUND IN PREPBUFR FILES (ALWAYS USE
C>   UFBEVN IN THIS CASE).  ONE OTHER DIFFERENCE BETWEEN UFBIN3 AND
C>   UFBEVN IS THAT UFBIN3 RETURNS THE MAXIMUM NUMBER OF EVENTS FOUND
C>   FOR ALL DATA VALUES SPECIFIED AS AN OUTPUT ARGUMENT (JRET).  UFBEVN
C>   DOES NOT DO THIS, BUT RATHER IT STORES THIS VALUE INTERNALLY IN
C>   COMMON BLOCK /UFBN3C/.
C>
C> PROGRAM HISTORY LOG:
C> 2003-11-04  J. WOOLLEN -- ORIGINAL AUTHOR (WAS IN VERIFICATION
C>                           VERSION)
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY OR UNUSUAL THINGS HAPPEN
C> 2009-04-21  J. ATOR    -- USE ERRWRT
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL UFBIN3 (LUNIT, USR, I1, I2, I3, IRET, JRET, STR)
C>   INPUT ARGUMENT LIST:
C>     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C>     I1       - INTEGER: LENGTH OF FIRST DIMENSION OF USR (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 USR
C>     I3       - INTEGER: LENGTH OF THIRD DIMENSION OF USR (MAXIMUM
C>                VALUE IS 255)
C>     STR      - CHARACTER*(*): STRING OF BLANK-SEPARATED TABLE B
C>                MNEMONICS IN ONE-TO-ONE CORRESPONDENCE WITH FIRST
C>                DIMENSION OF USR
C>                  - THERE ARE THREE "GENERIC" MNEMONICS NOT RELATED
C>                     TO TABLE B, THESE RETURN THE FOLLOWING
C>                     INFORMATION IN CORRESPONDING USR LOCATION:
C>                     'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
C>                     'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
C>                            MESSAGE (RECORD) NUMBER IN WHICH THIS
C>                            SUBSET RESIDES
C>                     'ISUB' WHICH ALWAYS RETURNS THE CURRENT SUBSET
C>                            NUMBER OF THIS SUBSET WITHIN THE BUFR
C>                            MESSAGE (RECORD) NUMBER 'IREC'
C>
C>   OUTPUT ARGUMENT LIST:
C>     USR      - REAL*8: (I1,I2,I3) STARTING ADDRESS OF DATA VALUES
C>                READ FROM DATA SUBSET
C>     IRET     - INTEGER: NUMBER OF "LEVELS" OF DATA VALUES READ FROM
C>                DATA SUBSET (MUST BE NO LARGER THAN I2)
C>     JRET     - INTEGER: MAXIMUM NUMBER OF "EVENTS" FOUND FOR ALL DATA
C>                VALUES SPECIFIED AMONGST ALL LEVELS READ FROM DATA
C>                SUBSET (MUST BE NO LARGER THAN I3)
C>
C> REMARKS:
C>    IMPORTANT: THIS ROUTINE SHOULD ONLY BE CALLED BY THE VERIFICATION
C>               APPLICATION PROGRAM "GRIDTOBS", WHERE IT WAS PREVIOUSLY
C>               AN IN-LINE SUBROUTINE.  IN GENERAL, UFBIN3 DOES NOT
C>               WORK PROPERLY IN OTHER APPLICATION PROGRAMS (I.E, THOSE
C>               THAT ARE READING PREPBUFR FILES) AT THIS TIME.  ALWAYS
C>               USE UFBEVN INSTEAD!!
C>
C>    THIS ROUTINE CALLS:        BORT     CONWIN   ERRWRT   GETWIN
C>                               NEVN     NXTWIN   STATUS   STRING
C>    THIS ROUTINE IS CALLED BY: None
C>                               SHOULD NOT BE CALLED BY ANY APPLICATION
C>                               PROGRAMS EXCEPT GRIDTOBS!!
C>
      SUBROUTINE ufbin3(LUNIT,USR,I1,I2,I3,IRET,JRET,STR)
 
      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /quiet / iprt
 
      CHARACTER*(*) STR
      CHARACTER*128 ERRSTR
      real*8        usr(i1,i2,i3)
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
      iret = 0
      jret = 0
 
C  CHECK THE FILE STATUS AND I-NODE
C  --------------------------------
 
      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) GOTO 900
      IF(il.GT.0) GOTO 901
      IF(im.EQ.0) GOTO 902
      IF(inode(lun).NE.inv(1,lun)) GOTO 903
 
      IF(i1.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBIN3 - 3rd ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
     .   '8th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         GOTO 100
      ELSEIF(i2.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBIN3 - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
     .   '8th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         GOTO 100
      ELSEIF(i3.LE.0) THEN
         IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBIN3 - 5th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th AND 7th ARGS. (IRET, JRET) = 0; ' //
     .   '8th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         GOTO 100
      ENDIF
 
C  PARSE OR RECALL THE INPUT STRING
C  --------------------------------
 
      CALL string(str,lun,i1,0)
 
C  INITIALIZE USR ARRAY
C  --------------------
 
      DO k=1,i3
      DO j=1,i2
      DO i=1,i1
      usr(i,j,k) = bmiss
      ENDDO
      ENDDO
      ENDDO
 
C  LOOP OVER COND WINDOWS
C  ----------------------
 
      inc1 = 1
      inc2 = 1
 
1     CALL conwin(lun,inc1,inc2)
      IF(nnod.EQ.0) THEN
        iret = i2
        GOTO 100
      ELSEIF(inc1.EQ.0) THEN
        GOTO 100
      ELSE
        DO i=1,nnod
        IF(nods(i).GT.0) THEN
           ins2 = inc1
           CALL getwin(nods(i),lun,ins1,ins2)
           IF(ins1.EQ.0) GOTO 100
           GOTO 2
        ENDIF
        ENDDO
        ins1 = inc1
        ins2 = inc2
      ENDIF
 
C  READ PUSH DOWN STACK DATA INTO 3D ARRAYS
C  ----------------------------------------
 
2     iret = iret+1
      IF(iret.LE.i2) THEN
         DO i=1,nnod
            nnvn = nevn(nods(i),lun,ins1,ins2,i1,i2,i3,usr(i,iret,1))
            jret = max(jret,nnvn)
         ENDDO
      ENDIF
 
C  DECIDE WHAT TO DO NEXT
C  ----------------------
 
      CALL nxtwin(lun,ins1,ins2)
      IF(ins1.GT.0 .AND. ins1.LT.inc2) GOTO 2
      IF(ncon.GT.0) GOTO 1
 
      IF(iret.EQ.0 .OR. jret.EQ.0)  THEN
         IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBIN3 - NO SPECIFIED VALUES READ IN, ' //
     .   'SO RETURN WITH 6th AND/OR 7th ARGS. (IRET, JRET) = 0; ' //
     .   '8th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
      ENDIF
 
C  EXITS
C  -----
 
100   RETURN
900   CALL bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBIN3 - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: UFBIN3 - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL bort('BUFRLIB: UFBIN3 - LOCATION OF INTERNAL TABLE FOR '//
     . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
     . 'INTERNAL SUBSET ARRAY')
      END