ufbevn.f

Go to the documentation of this file.

C> @file
C> @brief Read one or more data values from an NCEP prepbufr file.
C>
C> @author J. Woollen @date 1994-01-06
 
C> Read one or more data values from an NCEP prepbufr file.
C>
C> This subroutine reads one or more data values from the BUFR data
C> subset that is currently open within the BUFRLIB internal arrays.
C> It is specifically designed for use with NCEP prepbufr files,
C> which contain a third dimension of data events for every
C> reported data value at every replicated vertical level.  It is
C> similar to subroutine ufbin3(), except that ufbin3() is used
C> for NCEP prepfits files and has one extra argument containing
C> the maximum number of data events for any data value, whereas
C> this subroutine is used for NCEP prepbufr files and stores the
C> same information internally within a COMMON block.
C>
C> It is the user's responsibility to ensure that USR is dimensioned
C> sufficiently large enough to accommodate the number of data values
C> that are to be read from the data subset.  Note also
C> that USR is an array of real*8 values; therefore, any
C> character (i.e. CCITT IA5) value in the data subset will be
C> returned in real*8 format and must be converted back into character
C> format by the application program before it can be used as such.
C>
C> "Missing" values in USR are always denoted by a unique
C> placeholder value.  This placeholder value is initially set
C> to a default value of 10E10_8, but it can be reset to
C> any substitute value of the user's choice via a separate
C> call to subroutine setbmiss().  In any case, any
C> returned value in USR can be easily checked for equivalence to the
C> current placeholder value via a call to function ibfms(), and a
C> positive result means that the value for the corresponding mnemonic
C> was encoded as "missing" in BUFR (i.e. all bits set to 1) within the
C> original data subset.
C>
C> @param[in] LUNIT - integer: Fortran logical unit number for
C> NCEP prepbufr file.
C> @param[out] USR - real*8(*,*): Data values.
C> @param[in] I1 - integer: First dimension of USR as allocated
C> within the calling program.
C> @param[in] I2 - integer: Second dimension of USR as allocated
C> within the calling program.
C> @param[in] I3 - integer: Third dimension of USR as allocated
C> within the calling program.
C> @param[out] IRET - integer: Number of replications of STR that were
C> read from the data subset, corresponding to the second dimension of USR.
C> @param[in] STR - character*(*): String of blank-separated Table B
C> mnemonics in one-to-one correspondence with the number of data
C> values that will be read from the data subset within the first
C> dimension of USR (see [DX BUFR Tables](@ref dfbftab) for further
C> information about Table B mnemonics).
C>
C> @author J. Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE ufbevn(LUNIT,USR,I1,I2,I3,IRET,STR)
 
      USE modv_im8b
      USE modv_bmiss
 
      USE moda_usrint
      USE moda_msgcwd
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /ufbn3c/ maxevn
      COMMON /quiet / iprt
 
      CHARACTER*(*) str
      CHARACTER*128 errstr
      dimension     invn(255)
      real*8        usr(i1,i2,i3)
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(i1,my_i1,1)
         CALL x84(i2,my_i2,1)
         CALL x84(i3,my_i3,1)
         CALL ufbevn(my_lunit,usr,my_i1,my_i2,my_i3,iret,str)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      maxevn = 0
      iret   = 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: UFBEVN - 3rd ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th 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: UFBEVN - 4th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th 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: UFBEVN - 5th ARG. (INPUT) IS  0, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th 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
         IF(nods(i).GT.0) THEN
            nnvn = nvnwin(nods(i),lun,ins1,ins2,invn,i3)
            maxevn = max(nnvn,maxevn)
            DO n=1,nnvn
            usr(i,iret,n) = val(invn(n),lun)
            ENDDO
         ENDIF
         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)  THEN
         IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = 'BUFRLIB: UFBEVN - NO SPECIFIED VALUES READ IN, ' //
     .   'SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
      CALL errwrt(errstr)
      CALL errwrt(str)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
      ENDIF
 
C  EXITS
C  -----
 
100   RETURN
900   CALL bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBEVN - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: UFBEVN - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL bort('BUFRLIB: UFBEVN - LOCATION OF INTERNAL TABLE FOR '//
     . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
     . 'INTERNAL SUBSET ARRAY')
      END