nemtbb.f

Go to the documentation of this file.

C> @file
C> @brief Get information about a Table B descriptor
 
C> This subroutine returns information about a Table B descriptor
C> from the internal DX BUFR tables.
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] LUN -- integer: Internal I/O stream index associated
C>                   with DX BUFR tables
C> @param[in] ITAB -- integer: Positional index of descriptor within
C>                    internal Table B
C> @param[out] UNIT -- character*24: Units of descriptor
C> @param[out] ISCL -- integer: Scale factor of descriptor
C> @param[out] IREF -- integer: Reference value of descriptor
C> @param[out] IBIT -- integer: Bit width of descriptor
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 1994-01-06 | J. Woollen | Original author |
C> | 1995-06-28 | J. Woollen | Increased the size of internal BUFR table arrays in order to handle bigger files |
C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort() |
C> | 1999-11-18 | J. Woollen | Changed call to function "val$" to valx() |
C> | 2003-11-04 | J. Ator    | Added documentation |
C> | 2003-11-04 | S. Bender  | Added remarks/bufrlib routine interdependencies |
C> | 2003-11-04 | D. Keyser  | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally |
C> | 2014-12-10 | J. Ator    | Use modules instead of COMMON blocks |
C>
      SUBROUTINE nemtbb(LUN,ITAB,UNIT,ISCL,IREF,IBIT)
 
      USE moda_tababd
 
      CHARACTER*128 BORT_STR
      CHARACTER*24  UNIT
      CHARACTER*8   NEMO
      real*8        mxr
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
      mxr = 1e11-1
 
      IF(itab.LE.0 .OR. itab.GT.ntbb(lun)) GOTO 900
 
C  PULL OUT TABLE B INFORMATION
C  ----------------------------
 
      idn  = idnb(itab,lun)
      nemo = tabb(itab,lun)( 7:14)
      unit = tabb(itab,lun)(71:94)
      iscl = valx(tabb(itab,lun)( 95: 98))
      iref = valx(tabb(itab,lun)( 99:109))
      ibit = valx(tabb(itab,lun)(110:112))
 
C  CHECK TABLE B CONTENTS
C  ----------------------
 
      IF(idn.LT.ifxy('000000')) GOTO 901
      IF(idn.GT.ifxy('063255')) GOTO 901
 
      IF(iscl.LT.-999 .OR. iscl.GT.999) GOTO 902
      IF(iref.LE.-mxr .OR. iref.GE.mxr) GOTO 903
      IF(ibit.LE.0) GOTO 904
      IF(unit(1:5).NE.'CCITT' .AND. ibit.GT.32      ) GOTO 904
      IF(unit(1:5).EQ.'CCITT' .AND. mod(ibit,8).NE.0) GOTO 905
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: NEMTBB - ITAB (",I7,") NOT FOUND IN '//
     . 'TABLE B")') itab
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: NEMTBB - INTEGER REPRESENTATION OF '//
     . 'DESCRIPTOR FOR TABLE B MNEMONIC ",A," (",I7,") IS OUTSIDE '//
     . 'RANGE 0-16383 (16383 -> 0-63-255)")') nemo,idn
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: NEMTBB - SCALE VALUE FOR TABLE B '//
     .'MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE -999 TO 999")')
     . nemo,iscl
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: NEMTBB - REFERENCE VALUE FOR TABLE B'//
     .' MNEMONIC ",A," (",I7,") IS OUTSIDE RANGE +/- 1E11-1")')
     . nemo,iref
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: NEMTBB - BIT WIDTH FOR NON-CHARACTER'//
     . ' TABLE B MNEMONIC ",A," (",I7,") IS > 32")') nemo,ibit
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: NEMTBB - BIT WIDTH FOR CHARACTER '//
     . 'TABLE B MNEMONIC ",A," (",I7,") IS NOT A MULTIPLE OF 8")')
     . nemo,ibit
      CALL bort(bort_str)
      END