nemtbd.f

Go to the documentation of this file.

C> @file
C> @brief Get information about a Table D descriptor

C> This subroutine returns information about a Table D 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 D
C> @param[out] NSEQ -- integer: Number of child mnemonics for descriptor
C> @param[out] NEMS -- character*8(*): Child mnemonics
C> @param[out] IRPS -- integer(*): Array of values corresponding to NEMS
C>                     - 5, if corresponding NEMS value is a Table D
C>                       mnemonic using 1-bit delayed replication
C>                     - 4, if corresponding NEMS value is a Table D
C>                       mnemonic using 8-bit delayed (stack) replication
C>                     - 3, if corresponding NEMS value is a Table D
C>                       mnemonic using 8-bit delayed replication
C>                     - 2, if corresponding NEMS value is a Table D
C>                       mnemonic using 16-bit delayed replication
C>                     - 1, if corresponding NEMS value is a Table D
C>                       mnemonic using regular (non-delayed) replication
C>                     - 0, otherwise
C> @param[out] KNTS -- integer(*): Array of values corresponding to NEMS
C>                     - Number of replications, if corresponding NEMS
C>                       value is a Table D mnemonic using regular
C>                       (non-delayed) replication
C>                     - 0, otherwise
C>
C> @remarks
C> - This subroutine does not recursively resolve any child mnemonics
C> which may themselves be Table D mnemonics.  Instead, this subroutine
C> only returns the list of mnemonics which are direct children of the
C> descriptor referenced by ITAB.  This information should have already
C> been stored into internal arrays via previous calls to subroutine
C> pktdd().
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 | The number of BUFR files which can be opened at one time increased from 10 to 32 |
C> | 2000-09-19 | J. Woollen | Handle child mnemonics which are Table C operators |
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 nemtbd(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS)

      USE modv_maxcd
      USE moda_tababd

      CHARACTER*128 bort_str
      CHARACTER*8   nemo,nems,nemt,nemf
      CHARACTER*6   adn30,clemon
      CHARACTER*1   tab
      dimension     nems(*),irps(*),knts(*)
      LOGICAL       rep

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      IF(itab.LE.0 .OR. itab.GT.ntbd(lun)) goto 900

      rep  = .false.

C  CLEAR THE RETURN VALUES
C  -----------------------

      nseq = 0

      DO i=1,maxcd
      nems(i) = ' '
      irps(i) = 0
      knts(i) = 0
      ENDDO

C  PARSE THE TABLE D ENTRY
C  -----------------------

      nemo = tabd(itab,lun)(7:14)
      idsc = idnd(itab,lun)
      CALL uptdd(itab,lun,0,ndsc)

      IF(idsc.LT.ifxy('300000')) goto 901
      IF(idsc.GT.ifxy('363255')) goto 901
cccc  IF(NDSC.LE.0             ) GOTO 902

C     Loop through each child mnemonic.

c  .... DK: What happens here if NDSC=0 ?
      DO j=1,ndsc
      IF(nseq+1.GT.maxcd) goto 903
      CALL uptdd(itab,lun,j,idsc)
c  .... get NEMT from IDSC
      CALL numtab(lun,idsc,nemt,tab,iret)
      IF(tab.EQ.'R') THEN
         IF(rep) goto 904
         rep = .true.
         IF(iret.LT.0) THEN

C           F=1 regular (i.e. non-delayed) replication.

            irps(nseq+1) = 1
            knts(nseq+1) = abs(iret)
         ELSEIF(iret.GT.0) THEN

C           Delayed replication.

            irps(nseq+1) = iret
         ENDIF
      ELSEIF(tab.EQ.'F') THEN

C            Replication factor.

         IF(.NOT.rep) goto 904
         irps(nseq+1) = iret
         rep = .false.
      ELSEIF(tab.EQ.'D'.OR.tab.EQ.'C') THEN
         rep = .false.
         nseq = nseq+1
         nems(nseq) = nemt
      ELSEIF(tab.EQ.'B') THEN
         rep = .false.
         nseq = nseq+1
         IF((nemt(1:1).EQ.'.').AND.(j.LT.ndsc)) THEN

C            This is a "following value" mnemonic.

            CALL uptdd(itab,lun,j+1,idsc)
c  .... get NEMF from IDSC
            CALL numtab(lun,idsc,nemf,tab,iret)
            CALL rsvfvm(nemt,nemf)
            IF(tab.NE.'B') goto 906
         ENDIF
         nems(nseq) = nemt
      ELSE
         goto 905
      ENDIF
      ENDDO

C  EXITS
C  -----

      RETURN
900   WRITE(bort_str,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN '//
     . 'TABLE D")') itab
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: NEMTBD - INTEGER REPRESENTATION OF '//
     . 'DESCRIPTOR FOR TABLE D MNEMONIC ",A," (",I7,") IS OUTSIDE '//
     . 'RANGE 0-65535 (65535 -> 3-63-255)")') nemo,idsc
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'//
     . ' ZERO LENGTH SEQUENCE")') nemo
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '//
     . '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '//
     . 'MNEMONIC ",A)') maxcd, nemo
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '//
     . 'IN TABLE D SEQUENCE MNEMONIC ",A)') nemo
      CALL bort(bort_str)
905   clemon = adn30(idsc,6)
      WRITE(bort_str,'("BUFRLIB: NEMTBD - UNRECOGNIZED DESCRIPTOR '//
     . '",A," IN TABLE D SEQUENCE MNEMONIC ",A)') clemon,nemo
      CALL bort(bort_str)
906   WRITE(bort_str,'("BUFRLIB: NEMTBD - A ''FOLLOWING VALUE'' '//
     . 'MNEMONIC (",A,") IS FROM TABLE ",A,", IT MUST BE FROM TABLE B'//
     . '")') nemf,tab
      CALL bort(bort_str)
      END