ufbin3.f

Go to the documentation of this file.

C> @file
C> @brief Read one or more data values from an NCEP prepfits file.
C>
C> @author J. Woollen @date 2003-11-04
 
C> Read one or more data values from an NCEP prepfits 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 prepfits 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 ufbevn(), except that ufbevn() is used
C> for NCEP prepbufr files and stores the maximum number of data
C> events for any data value within an internal COMMON block,
C> whereas this subroutine is used for NCEP prepfits files and
C> has one extra argument which returns the same information to
C> the calling program.
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 prepfits 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
C>                     to the second dimension of USR
C> @param[out] JRET -- integer: Maximum number of data events for any
C>                     data value that was read from the data subset at
C>                     any replicated vertical level, and
C>                     corresponding to the third dimension of USR
C> @param[in] STR -- character*(*): String of blank-separated
C>                   Table B mnemonics
C>                   in one-to-one correspondence with the number of data
C>                   values that will be read from the data
C>                   subset within the first dimension of USR (see
C>                   [DX BUFR Tables](@ref dfbftab) for further
C>                   information about Table B mnemonics)
C>
C> @author J. Woollen @date 2003-11-04
      RECURSIVE SUBROUTINE ufbin3(LUNIT,USR,I1,I2,I3,IRET,JRET,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 /quiet / iprt
 
      CHARACTER*(*) str
      CHARACTER*128 errstr
      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 ufbin3(my_lunit,usr,my_i1,my_i2,my_i3,iret,jret,str)
         CALL x48(iret,iret,1)
         CALL x48(jret,jret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      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