var/external/bufr/seqsdx.f

   1       SUBROUTINE SEQSDX(CARD,LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    SEQSDX
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE DECODES THE TABLE D SEQUENCE INFORMATION
   9 C   FROM A MNEMONIC DEFINITION CARD THAT WAS PREVIOUSLY READ FROM A
  10 C   USER-SUPPLIED BUFR DICTIONARY TABLE IN CHARACTER FORMAT BY
  11 C   BUFR ARCHIVE LIBRARY SUBROUTINE RDUSDX.  THESE ARE THEN ADDED TO
  12 C   THE ALREADY-EXISTING ENTRY FOR THAT MNEMONIC (BUILT IN RDUSDX)
  13 C   WITHIN THE INTERNAL BUFR TABLE D ARRAY TABD(*,LUN) IN COMMON BLOCK
  14 C   /TABABD/.
  15 C
  16 C PROGRAM HISTORY LOG:
  17 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  18 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  19 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  20 C                           ROUTINE "BORT"
  21 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  22 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  23 C                           INTERDEPENDENCIES
  24 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  25 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  26 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  27 C                           ABNORMALLY; CHANGED CALL FROM BORT TO BORT2
  28 C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  29 C
  30 C USAGE:    CALL SEQSDX (CARD, LUN)
  31 C   INPUT ARGUMENT LIST:
  32 C     CARD     - CHARACTER*80: MNEMONIC DEFINITION CARD THAT WAS READ
  33 C                FROM A USER-SUPPLIED BUFR DICTIONARY TABLE
  34 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  35 C
  36 C REMARKS:
  37 C    THIS ROUTINE CALLS:        ADN30    BORT2    NEMOCK   NEMTAB
  38 C                               PARSTR   PKTDD    RSVFVM   STRNUM
  39 C    THIS ROUTINE IS CALLED BY: RDUSDX
  40 C                               Normally not called by any application
  41 C                               programs.
  42 C
  43 C ATTRIBUTES:
  44 C   LANGUAGE: FORTRAN 77
  45 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  46 C
  47 C$$$
  48
  49       COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5)
  50
  51       CHARACTER*128 BORT_STR1,BORT_STR2
  52       CHARACTER*80  CARD,SEQS
  53       CHARACTER*12  ATAG,TAGS(250)
  54       CHARACTER*8   NEMO,NEMA,NEMB
  55       CHARACTER*6   ADN30,CLEMON
  56       CHARACTER*3   TYPS
  57       CHARACTER*1   REPS,TAB
  58
  59       DATA MAXTGS /250/
  60       DATA MAXTAG /12/
  61
  62 C-----------------------------------------------------------------------
  63 C-----------------------------------------------------------------------
  64
  65 C  FIND THE SEQUENCE TAG IN TABLE D AND PARSE THE SEQUENCE STRING
  66 C  --------------------------------------------------------------
  67
  68       NEMO = CARD( 3:10)
  69       SEQS = CARD(14:78)
  70
  71 C     Note that an entry for this mnemonic should already exist within
  72 C     the internal BUFR Table D array TABD(*,LUN); this entry should
  73 C     have been created by subroutine RDUSDX when the mnemonic and its
  74 C     associated FXY value and description were initially defined
  75 C     within a card read from the "Descriptor Definition" section at
  76 C     the top of the user-supplied BUFR dictionary table in character
  77 C     format.  Now, we need to retrieve the positional index for that
  78 C     entry within TABD(*,LUN) so that we can access the entry and then
  79 C     add the decoded sequence information to it.
  80
  81       CALL NEMTAB(LUN,NEMO,IDN,TAB,ISEQ)
  82       IF(TAB.NE.'D') GOTO 900
  83       CALL PARSTR(SEQS,TAGS,MAXTGS,NTAG,' ',.TRUE.)
  84       IF(NTAG.EQ.0 ) GOTO 901
  85
  86       DO N=1,NTAG
  87       ATAG = TAGS(N)
  88       IREP = 0
  89
  90 C  CHECK FOR REPLICATOR
  91 C  --------------------
  92
  93       DO I=1,5
  94       IF(ATAG(1:1).EQ.REPS(I,1)) THEN
  95
  96 C        Note that REPS(*,*), which contains all of the symbols used to
  97 C        denote all of the various replication schemes that are
  98 C        possible within a user-supplied BUFR dictionary table in
  99 C        character format, was previously defined within subroutine
 100 C        BFRINI.
 101
 102          DO J=2,MAXTAG
 103          IF(ATAG(J:J).EQ.REPS(I,2)) THEN
 104             IF(J.EQ.MAXTAG) GOTO 902
 105
 106 C           Note that subroutine STRNUM will return NUMR = 0 if the
 107 C           string passed to it contains all blanks (as *should* be the
 108 C           case whenever I = 2 '(' ')', 3 '{' '}', 4 '[' ']', or
 109 C           5 '<' '>').
 110
 111 C           However, when I = 1 '"' '"', then subroutine STRNUM will
 112 C           return NUMR = (the number of replications for the mnemonic
 113 C           using F=1 "regular" (i.e. non-delayed) replication).
 114
 115             CALL STRNUM(ATAG(J+1:MAXTAG),NUMR)
 116             IF(I.EQ.1 .AND. NUMR.LE.0  ) GOTO 903
 117             IF(I.EQ.1 .AND. NUMR.GT.255) GOTO 904
 118             IF(I.NE.1 .AND. NUMR.NE.0  ) GOTO 905
 119             ATAG = ATAG(2:J-1)
 120             IREP = I
 121             GOTO 1
 122          ENDIF
 123          ENDDO
 124          GOTO 902
 125       ENDIF
 126       ENDDO
 127
 128 C  CHECK FOR VALID TAG
 129 C  -------------------
 130
 131 1     IRET=NEMOCK(ATAG)
 132       IF(IRET.EQ.-1) GOTO 906
 133       IF(IRET.EQ.-2) GOTO 907
 134       CALL NEMTAB(LUN,ATAG,IDN,TAB,IRET)
 135       IF(IRET.GT.0) THEN
 136
 137 C        Note that the next code line checks that we are not trying to
 138 C        replicate a Table B mnemonic (which is currently not allowed).
 139 C        The logic works because, for replicated mnemonics, IREP = I =
 140 C        (the index within REPS(*,*) of the symbol associated with the
 141 C        type of replication in question (e.g. "{, "<", etc.))
 142
 143          IF(TAB.EQ.'B' .AND. IREP.NE.0) GOTO 908
 144          IF(ATAG(1:1).EQ.'.') THEN
 145
 146 C           This mnemonic is a "following value" mnemonic
 147 C           (i.e. it relates to the mnemonic that immediately
 148 C           follows it within the user-supplied character-format BUFR
 149 C           dictionary table sequence), so confirm that it contains, as
 150 C           a substring, this mnemonic that immediately follows it.
 151
 152             NEMB = TAGS(N+1)
 153 c  .... get NEMA from IDN
 154             CALL NUMTAB(LUN,IDN,NEMA,TAB,ITAB)
 155             CALL NEMTAB(LUN,NEMB,JDN,TAB,IRET)
 156             CALL RSVFVM(NEMA,NEMB)
 157             IF(NEMA.NE.ATAG) GOTO 909
 158 c  .... DK: I don't think the next test can ever be satisfied
 159 c  ....     should probably be IF(N.EQ.NTAG ) GOTO 910
 160             IF(N.GT.NTAG ) GOTO 910
 161             IF(TAB.NE.'B') GOTO 911
 162          ENDIF
 163       ELSE
 164          GOTO 912
 165       ENDIF
 166
 167 C  WRITE THE DESCRIPTOR STRING INTO TABD ARRAY
 168 C  -------------------------------------------
 169 c  .... first look for a replication descriptor
 170       IF(IREP.GT.0) CALL PKTDD(ISEQ,LUN,IDNR(IREP,1)+NUMR,IRET)
 171       IF(IRET.LT.0) GOTO 913
 172       CALL PKTDD(ISEQ,LUN,IDN,IRET)
 173       IF(IRET.LT.0) GOTO 914
 174
 175       ENDDO
 176
 177 C  EXITS
 178 C  -----
 179
 180       RETURN
 181 900   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 182       WRITE(BORT_STR2,'(18X,"MNEMONIC ",A," IS NOT A TABLE D ENTRY '//
 183      . '(UNDEFINED, TAB=",A,")")') NEMO,TAB
 184       CALL BORT2(BORT_STR1,BORT_STR2)
 185 901   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 186       WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
 187      . '" DOES NOT CONTAIN ANY CHILD MNEMONICS")') NEMO
 188       CALL BORT2(BORT_STR1,BORT_STR2)
 189 902   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 190       WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
 191      . '" CONTAINS A BADLY FORMED CHILD MNEMONIC",A)') NEMO,TAGS(N)
 192       CALL BORT2(BORT_STR1,BORT_STR2)
 193 903   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 194       WRITE(BORT_STR2,'(9X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
 195      . 'CHILD MNEM. ",A," W/ INVALID # OF REPLICATIONS (",I3,") AFTER'//
 196      . ' 2ND QUOTE")') NEMO,TAGS(N),NUMR
 197       CALL BORT2(BORT_STR1,BORT_STR2)
 198 904   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 199       WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS REG. REPL. '//
 200      . 'CHILD MNEM. ",A," W/ # OF REPLICATIONS (",I3,") > LIMIT OF '//
 201      . '255")') NEMO,TAGS(N),NUMR
 202       CALL BORT2(BORT_STR1,BORT_STR2)
 203 905   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 204       WRITE(BORT_STR2,'(18X,"TBL D MNEM. ",A," CONTAINS DELAYED REPL.'//
 205      . ' CHILD MNEM. ",A," W/ # OF REPL. (",I3,") SPECIFIED - A NO-'//
 206      . 'NO")') NEMO,TAGS(N),NUMR
 207       CALL BORT2(BORT_STR1,BORT_STR2)
 208 906   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 209       WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
 210      .' A CHILD MNEMONIC ",A," NOT BETWEEN 1 & 8 CHARACTERS")')
 211      . NEMO,TAGS(N)
 212       CALL BORT2(BORT_STR1,BORT_STR2)
 213 907   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 214       WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
 215      . ' A CHILD MNEMONIC ",A," WITH INVALID CHARACTERS")') NEMO,TAGS(N)
 216       CALL BORT2(BORT_STR1,BORT_STR2)
 217 908   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 218       WRITE(BORT_STR2,'(18X,"TABLE D (PARENT) MNEMONIC ",A," CONTAINS'//
 219      . ' A REPLICATED CHILD TABLE B MNEMONIC ",A," - A NO-NO")')
 220      . NEMO,TAGS(N)
 221       CALL BORT2(BORT_STR1,BORT_STR2)
 222 909   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 223       WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS AN '//
 224      . 'INVALID ''FOLLOWING VALUE'' MNEMONIC ",A,"(SHOULD BE ",A,")")')
 225      . NEMO,TAGS(N),NEMA
 226       CALL BORT2(BORT_STR1,BORT_STR2)
 227 910   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 228       WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A," CONTAINS A '//
 229      . '''FOLLOWING VALUE'' MNEMONIC ",A," WHICH IS LAST IN THE '//
 230      . 'STRING")') NEMO,NEMA
 231       CALL BORT2(BORT_STR1,BORT_STR2)
 232 911   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 233       WRITE(BORT_STR2,'(18X,"TBL D (PARENT) MNEM. ",A,", THE MNEM. ",'//
 234      . 'A," FOLLOWING A ''FOLLOWING VALUE'' MNEM. IS NOT A TBL B '//
 235      . 'ENTRY")') NEMO,NEMB
 236       CALL BORT2(BORT_STR1,BORT_STR2)
 237 912   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 238       WRITE(BORT_STR2,'(18X,"TABLE D SEQUENCE (PARENT) MNEMONIC ",A,'//
 239      . '" CONTAINS A CHILD MNEMONIC ",A," NOT FOUND IN ANY TABLE")')
 240      .  NEMO,TAGS(N)
 241       CALL BORT2(BORT_STR1,BORT_STR2)
 242 913   CLEMON = ADN30(IDNR(IREP,1)+NUMR,6)
 243       WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 244       WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
 245      . 'FROM PKTDD TRYING TO STORE REPL. DESC. ",A,", SEE PREV. '//
 246      . 'WARNING MSG")') NEMO,CLEMON
 247       CALL BORT2(BORT_STR1,BORT_STR2)
 248 914   WRITE(BORT_STR1,'("BUFRLIB: SEQSDX - CARD READ IN IS: ",A)') CARD
 249       WRITE(BORT_STR2,'(9X,"TBL D (PARENT) MNEM. ",A," - BAD RETURN '//
 250      . 'FROM PKTDD TRYING TO STORE CHILD MNEM. ",A,", SEE PREV. '//
 251      . 'WARNING MSG")') NEMO,TAGS(N)
 252       CALL BORT2(BORT_STR1,BORT_STR2)
 253       END