var/external/bufr/nemtbd.f

   1       SUBROUTINE NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    NEMTBD
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE RETURNS A LIST OF THE MNEMONICS (I.E.,
   9 C   "CHILD" MNEMONICS) CONTAINED WITHIN A TABLE D SEQUENCE MNEMONIC
  10 C   (I.E., A "PARENT MNEMONIC").  THIS INFORMATION SHOULD HAVE BEEN
  11 C   PACKED INTO THE INTERNAL BUFR TABLE D ENTRY FOR THE PARENT MNEMONIC
  12 C   (IN COMMON BLOCK /TABABD/) VIA PREVIOUS CALLS TO BUFR ARCHIVE
  13 C   LIBRARY SUBROUTINE PKTDD.  NOTE THAT NEMTBD DOES NOT RECURSIVELY
  14 C   RESOLVE CHILD MNEMONICS WHICH ARE THEMSELVES TABLE D SEQUENCE
  15 C   MNEMONICS; RATHER, SUCH RESOLUTION MUST BE DONE VIA SEPARATE
  16 C   SUBSEQUENT CALLS TO THIS SUBROUTINE.
  17 C
  18 C PROGRAM HISTORY LOG:
  19 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  20 C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  21 C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  22 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  23 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  24 C                           ROUTINE "BORT"
  25 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  26 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  27 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  28 C                           BUFR FILES UNDER THE MPI)
  29 C 2000-09-19  J. WOOLLEN -- MUST NOW CHECK FOR TABLE C (OPERATOR
  30 C                           DESCRIPTOR) MNEMONICS SINCE THE CAPABILITY
  31 C                           HAS NOW BEEN ADDED TO ENCODE AND DECODE
  32 C                           THESE
  33 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  34 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  35 C                           INTERDEPENDENCIES
  36 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  37 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  38 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  39 C                           ABNORMALLY
  40 C
  41 C USAGE:    CALL NEMTBD (LUN, ITAB, NSEQ, NEMS, IRPS, KNTS)
  42 C   INPUT ARGUMENT LIST:
  43 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  44 C     ITAB     - INTEGER: POSITIONAL INDEX OF PARENT MNEMONIC WITHIN
  45 C                INTERNAL BUFR TABLE D ARRAY TABD(*,*)
  46 C
  47 C   OUTPUT ARGUMENT LIST:
  48 C     NSEQ     - INTEGER: TOTAL NUMBER OF CHILD MNEMONICS FOR THE
  49 C                PARENT MNEMONIC GIVEN BY TABD(ITAB,LUN)
  50 C     NEMS     - CHARACTER*8: (NSEQ)-WORD ARRAY OF CHILD MNEMONICS
  51 C     IRPS     - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS)
  52 C     KNTS     - INTEGER: (NSEQ)-WORD RETURN VALUE ARRAY (SEE REMARKS)
  53 C
  54 C REMARKS:
  55 C    VALUE FOR OUTPUT ARGUMENT IRPS:
  56 C       The interpretation of the return value IRPS(I) depends upon the
  57 C       type of descriptor corresponding to NEMS(I), as follows:
  58 C
  59 C       IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed)
  60 C            replication descriptor ) THEN
  61 C          IRPS(I) = 1
  62 C       ELSE IF ( NEMS(I) corresponds to a delayed replicator or
  63 C                 replication factor descriptor )  THEN
  64 C          IRPS(I) = positional index of corresponding descriptor
  65 C                    within internal replication array IDNR(*,*)
  66 C       ELSE
  67 C          IRPS(I) = 0
  68 C       END IF
  69 C
  70 C
  71 C    VALUE FOR OUTPUT ARGUMENT KNTS:
  72 C       The interpretation of the return value KNTS(I) depends upon the
  73 C       type of descriptor corresponding to NEMS(I), as follows:
  74 C
  75 C       IF ( NEMS(I) corresponds to an F=1 regular (i.e. non-delayed)
  76 C            replication descriptor ) THEN
  77 C          KNTS(I) = number of replications
  78 C       ELSE
  79 C          KNTS(I) = 0
  80 C       END IF
  81 C
  82 C
  83 C    THIS ROUTINE CALLS:        ADN30    BORT     IFXY     NUMTAB
  84 C                               RSVFVM   UPTDD
  85 C    THIS ROUTINE IS CALLED BY: CHEKSTAB DXDUMP   GETABDB  TABSUB
  86 C                               Normally not called by any application
  87 C                               programs.
  88 C
  89 C ATTRIBUTES:
  90 C   LANGUAGE: FORTRAN 77
  91 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  92 C
  93 C$$$
  94
  95       INCLUDE 'bufrlib.prm'
  96
  97       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  98      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  99      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
 100      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
 101      .                TABD(MAXTBD,NFILES)
 102
 103       CHARACTER*600 TABD
 104       CHARACTER*128 TABB
 105       CHARACTER*128 TABA
 106       CHARACTER*128 BORT_STR
 107       CHARACTER*8   NEMO,NEMS,NEMT,NEMF
 108       CHARACTER*6   ADN30,CLEMON
 109       CHARACTER*1   TAB
 110       DIMENSION     NEMS(MAXCD),IRPS(MAXCD),KNTS(MAXCD)
 111       LOGICAL       REP
 112
 113 C-----------------------------------------------------------------------
 114 C-----------------------------------------------------------------------
 115
 116       IF(ITAB.LE.0 .OR. ITAB.GT.NTBD(LUN)) GOTO 900
 117
 118       REP  = .FALSE.
 119
 120 C  CLEAR THE RETURN VALUES
 121 C  -----------------------
 122
 123       NSEQ = 0
 124
 125       DO I=1,MAXCD
 126       NEMS(I) = ' '
 127       IRPS(I) = 0
 128       KNTS(I) = 0
 129       ENDDO
 130
 131 C  PARSE THE TABLE D ENTRY
 132 C  -----------------------
 133
 134       NEMO = TABD(ITAB,LUN)(7:14)
 135       IDSC = IDND(ITAB,LUN)
 136       CALL UPTDD(ITAB,LUN,0,NDSC)
 137
 138       IF(IDSC.LT.IFXY('300000')) GOTO 901
 139       IF(IDSC.GT.IFXY('363255')) GOTO 901
 140 cccc  IF(NDSC.LE.0             ) GOTO 902
 141
 142 C     Loop through each child mnemonic.
 143
 144 c  .... DK: What happens here if NDSC=0 ?
 145       DO J=1,NDSC
 146       IF(NSEQ+1.GT.MAXCD) GOTO 903
 147       CALL UPTDD(ITAB,LUN,J,IDSC)
 148 c  .... get NEMT from IDSC
 149       CALL NUMTAB(LUN,IDSC,NEMT,TAB,IRET)
 150       IF(TAB.EQ.'R') THEN
 151          IF(REP) GOTO 904
 152          REP = .TRUE.
 153          IF(IRET.LT.0) THEN
 154
 155 C           F=1 regular (i.e. non-delayed) replication.
 156
 157             IRPS(NSEQ+1) = 1
 158             KNTS(NSEQ+1) = ABS(IRET)
 159          ELSEIF(IRET.GT.0) THEN
 160
 161 C           Delayed replication.
 162
 163             IRPS(NSEQ+1) = IRET
 164          ENDIF
 165       ELSEIF(TAB.EQ.'F') THEN
 166
 167 C            Replication factor.
 168
 169          IF(.NOT.REP) GOTO 904
 170          IRPS(NSEQ+1) = IRET
 171          REP = .FALSE.
 172       ELSEIF(TAB.EQ.'D'.OR.TAB.EQ.'C') THEN
 173          REP = .FALSE.
 174          NSEQ = NSEQ+1
 175          NEMS(NSEQ) = NEMT
 176       ELSEIF(TAB.EQ.'B') THEN
 177          REP = .FALSE.
 178          NSEQ = NSEQ+1
 179          IF(NEMT(1:1).EQ.'.') THEN
 180
 181 C            This is a "following value" mnemonic.
 182
 183             CALL UPTDD(ITAB,LUN,J+1,IDSC)
 184 c  .... get NEMF from IDSC
 185             CALL NUMTAB(LUN,IDSC,NEMF,TAB,IRET)
 186             CALL RSVFVM(NEMT,NEMF)
 187             IF(TAB.NE.'B') GOTO 906
 188          ENDIF
 189          NEMS(NSEQ) = NEMT
 190       ELSE
 191          GOTO 905
 192       ENDIF
 193       ENDDO
 194
 195 C  EXITS
 196 C  -----
 197
 198       RETURN
 199 900   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - ITAB (",I7,") NOT FOUND IN '//
 200      . 'TABLE D")') ITAB
 201       CALL BORT(BORT_STR)
 202 901   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - INTEGER REPRESENTATION OF '//
 203      . 'DESCRIPTOR FOR TABLE D MNEMONIC ",A," (",I7,") IS OUTSIDE '//
 204      . 'RANGE 0-65535 (65535 -> 3-63-255)")') NEMO,IDSC
 205       CALL BORT(BORT_STR)
 206 902   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - TABLE D MNEMONIC ",A," IS A'//
 207      . ' ZERO LENGTH SEQUENCE")') NEMO
 208       CALL BORT(BORT_STR)
 209 903   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - THERE ARE MORE THAN '//
 210      . '(",I4,") DESCRIPTORS (THE LIMIT) IN TABLE D SEQUENCE '//
 211      . 'MNEMONIC ",A)') MAXCD, NEMO
 212       CALL BORT(BORT_STR)
 213 904   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - REPLICATOR IS OUT OF ORDER '//
 214      . 'IN TABLE D SEQUENCE MNEMONIC ",A)') NEMO
 215       CALL BORT(BORT_STR)
 216 905   CLEMON = ADN30(IDSC,6)
 217       WRITE(BORT_STR,'("BUFRLIB: NEMTBD - UNRECOGNIZED DESCRIPTOR '//
 218      . '",A," IN TABLE D SEQUENCE MNEMONIC ",A)') CLEMON,NEMO
 219       CALL BORT(BORT_STR)
 220 906   WRITE(BORT_STR,'("BUFRLIB: NEMTBD - A ''FOLLOWING VALUE'' '//
 221      . 'MNEMONIC (",A,") IS FROM TABLE ",A,", IT MUST BE FROM TABLE B'//
 222      . '")') NEMF,TAB
 223       CALL BORT(BORT_STR)
 224       END