nemtbd.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE RETURNS A LIST OF THE MNEMONICS (I.E.,
C>   "CHILD" MNEMONICS) CONTAINED WITHIN A TABLE D SEQUENCE MNEMONIC
C>   (I.E., A "PARENT MNEMONIC").  THIS INFORMATION SHOULD HAVE BEEN
C>   PACKED INTO THE INTERNAL BUFR TABLE D ENTRY FOR THE PARENT
C>   MNEMONIC (IN MODULE TABABD) VIA PREVIOUS CALLS TO BUFR ARCHIVE
C>   LIBRARY SUBROUTINE PKTDD.  NOTE THAT NEMTBD DOES NOT RECURSIVELY
C>   RESOLVE CHILD MNEMONICS WHICH ARE THEMSELVES TABLE D SEQUENCE
C>   MNEMONICS; RATHER, SUCH RESOLUTION MUST BE DONE VIA SEPARATE
C>   SUBSEQUENT CALLS TO THIS SUBROUTINE.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
C>                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2000-09-19  J. WOOLLEN -- MUST NOW CHECK FOR TABLE C (OPERATOR
C>                           DESCRIPTOR) MNEMONICS SINCE THE CAPABILITY
C>                           HAS NOW BEEN ADDED TO ENCODE AND DECODE
C>                           THESE
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C>                           DOCUMENTATION; OUTPUTS MORE COMPLETE
C>                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C>                           ABNORMALLY
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL NEMTBD (LUN, ITAB, NSEQ, NEMS, IRPS, KNTS)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     ITAB     - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN
C>                INTERNAL BUFR TABLE D ARRAY TABD(*,*)
C>
C>   OUTPUT ARGUMENT LIST:
C>     NSEQ     - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS FOR THE
C>                PARENT MNEMONIC GIVEN BY TABD(ITAB,LUN)
C>     NEMS     - CHARACTER*8: (NSEQ)-WORD ARRAY OF CHILD MNEMONICS
C>     IRPS     - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS)
C>     KNTS     - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS)
C>
C> REMARKS:
C>    VALUE FOR OUTPUT ARGUMENT IRPS:
C>       The interpretation of the return value IRPS(I) depends upon the
C>       type of descriptor corresponding to NEMS(I), as follows:
C>
C>       IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed)
C>            replication descriptor ) THEN
C>          IRPS(I) = 1
C>       ELSE IF ( NEMS(I) corresponds to a delayed replicator or
C>                 replication factor descriptor )  THEN
C>          IRPS(I) = positional index of corresponding descriptor
C>                    within internal replication array IDNR(*,*)
C>       ELSE
C>          IRPS(I) = 0
C>       END IF
C>
C>
C>    VALUE FOR OUTPUT ARGUMENT KNTS:
C>       The interpretation of the return value KNTS(I) depends upon the
C>       type of descriptor corresponding to NEMS(I), as follows:
C>
C>       IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed)
C>            replication descriptor ) THEN
C>          KNTS(I) = number of replications
C>       ELSE
C>          KNTS(I) = 0
C>       END IF
C>
C>
C>    THIS ROUTINE CALLS:        ADN30    BORT     IFXY     NUMTAB
C>                               RSVFVM   UPTDD
C>    THIS ROUTINE IS CALLED BY: CHEKSTAB DXDUMP   GETABDB  TABSUB
C>                               Normally not called by any application
C>                               programs.
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